aboutsummaryrefslogtreecommitdiff
path: root/gcc/ada
diff options
context:
space:
mode:
Diffstat (limited to 'gcc/ada')
-rw-r--r--gcc/ada/.gitignore2
-rw-r--r--gcc/ada/ChangeLog7868
-rw-r--r--gcc/ada/Make-generated.in99
-rw-r--r--gcc/ada/Makefile.rtl99
-rw-r--r--gcc/ada/ada_get_targ.adb4
-rw-r--r--gcc/ada/adabkend.adb2
-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.c9
-rw-r--r--gcc/ada/adaint.h8
-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.adb476
-rw-r--r--gcc/ada/ali.ads22
-rw-r--r--gcc/ada/alloc.ads12
-rw-r--r--gcc/ada/argv-lynxos178-raven-cert.c7
-rw-r--r--gcc/ada/argv.c8
-rw-r--r--gcc/ada/aspects.adb23
-rw-r--r--gcc/ada/aspects.ads31
-rw-r--r--gcc/ada/atree.adb9103
-rw-r--r--gcc/ada/atree.ads3877
-rw-r--r--gcc/ada/atree.h887
-rw-r--r--gcc/ada/aux-io.c2
-rw-r--r--gcc/ada/back_end.adb18
-rw-r--r--gcc/ada/back_end.ads3
-rw-r--r--gcc/ada/bcheck.adb2
-rw-r--r--gcc/ada/bcheck.ads2
-rw-r--r--gcc/ada/binde.adb22
-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.adb8
-rw-r--r--gcc/ada/bindgen.ads2
-rw-r--r--gcc/ada/bindo-augmentors.adb2
-rw-r--r--gcc/ada/bindo-augmentors.ads2
-rw-r--r--gcc/ada/bindo-builders.adb2
-rw-r--r--gcc/ada/bindo-builders.ads2
-rw-r--r--gcc/ada/bindo-diagnostics.adb2
-rw-r--r--gcc/ada/bindo-diagnostics.ads2
-rw-r--r--gcc/ada/bindo-elaborators.adb2
-rw-r--r--gcc/ada/bindo-elaborators.ads2
-rw-r--r--gcc/ada/bindo-graphs.adb2
-rw-r--r--gcc/ada/bindo-graphs.ads2
-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.adb6
-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.adb2
-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.adb226
-rw-r--r--gcc/ada/checks.adb836
-rw-r--r--gcc/ada/checks.ads6
-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.adb39
-rw-r--r--gcc/ada/comperr.ads2
-rw-r--r--gcc/ada/contracts.adb134
-rw-r--r--gcc/ada/contracts.ads2
-rw-r--r--gcc/ada/csets.adb50
-rw-r--r--gcc/ada/csets.ads2
-rw-r--r--gcc/ada/csinfo.adb639
-rw-r--r--gcc/ada/cstand.adb256
-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.adb48
-rw-r--r--gcc/ada/debug.ads2
-rw-r--r--gcc/ada/debug_a.adb25
-rw-r--r--gcc/ada/debug_a.ads2
-rw-r--r--gcc/ada/doc/Makefile2
-rw-r--r--gcc/ada/doc/gnat-style.rst691
-rw-r--r--gcc/ada/doc/gnat_rm/implementation_advice.rst16
-rw-r--r--gcc/ada/doc/gnat_rm/implementation_defined_aspects.rst21
-rw-r--r--gcc/ada/doc/gnat_rm/implementation_defined_attributes.rst69
-rw-r--r--gcc/ada/doc/gnat_rm/implementation_defined_characteristics.rst25
-rw-r--r--gcc/ada/doc/gnat_rm/implementation_defined_pragmas.rst220
-rw-r--r--gcc/ada/doc/gnat_rm/implementation_of_specific_ada_features.rst20
-rw-r--r--gcc/ada/doc/gnat_rm/intrinsic_subprograms.rst14
-rw-r--r--gcc/ada/doc/gnat_rm/representation_clauses_and_pragmas.rst2
-rw-r--r--gcc/ada/doc/gnat_ugn/building_executable_programs_with_gnat.rst68
-rw-r--r--gcc/ada/doc/gnat_ugn/the_gnat_compilation_model.rst3
-rw-r--r--gcc/ada/doc/share/conf.py42
-rw-r--r--gcc/ada/doc/share/gnat.sty72
-rw-r--r--gcc/ada/einfo-utils.adb3331
-rw-r--r--gcc/ada/einfo-utils.ads713
-rw-r--r--gcc/ada/einfo.adb11555
-rw-r--r--gcc/ada/einfo.ads6911
-rw-r--r--gcc/ada/elists.adb2
-rw-r--r--gcc/ada/elists.ads2
-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.ads4
-rw-r--r--gcc/ada/errno.c2
-rw-r--r--gcc/ada/errout.adb942
-rw-r--r--gcc/ada/errout.ads64
-rw-r--r--gcc/ada/erroutc.adb68
-rw-r--r--gcc/ada/erroutc.ads69
-rw-r--r--gcc/ada/errutil.adb6
-rw-r--r--gcc/ada/errutil.ads2
-rw-r--r--gcc/ada/eval_fat.adb41
-rw-r--r--gcc/ada/eval_fat.ads6
-rw-r--r--gcc/ada/exit.c2
-rw-r--r--gcc/ada/exp_aggr.adb943
-rw-r--r--gcc/ada/exp_aggr.ads2
-rw-r--r--gcc/ada/exp_atag.adb37
-rw-r--r--gcc/ada/exp_atag.ads2
-rw-r--r--gcc/ada/exp_attr.adb301
-rw-r--r--gcc/ada/exp_attr.ads2
-rw-r--r--gcc/ada/exp_cg.adb61
-rw-r--r--gcc/ada/exp_cg.ads2
-rw-r--r--gcc/ada/exp_ch10.ads2
-rw-r--r--gcc/ada/exp_ch11.adb178
-rw-r--r--gcc/ada/exp_ch11.ads3
-rw-r--r--gcc/ada/exp_ch12.adb23
-rw-r--r--gcc/ada/exp_ch12.ads2
-rw-r--r--gcc/ada/exp_ch13.adb58
-rw-r--r--gcc/ada/exp_ch13.ads2
-rw-r--r--gcc/ada/exp_ch2.adb48
-rw-r--r--gcc/ada/exp_ch2.ads2
-rw-r--r--gcc/ada/exp_ch3.adb306
-rw-r--r--gcc/ada/exp_ch3.ads2
-rw-r--r--gcc/ada/exp_ch4.adb727
-rw-r--r--gcc/ada/exp_ch4.ads2
-rw-r--r--gcc/ada/exp_ch5.adb991
-rw-r--r--gcc/ada/exp_ch5.ads3
-rw-r--r--gcc/ada/exp_ch6.adb565
-rw-r--r--gcc/ada/exp_ch6.ads10
-rw-r--r--gcc/ada/exp_ch7.adb843
-rw-r--r--gcc/ada/exp_ch7.ads13
-rw-r--r--gcc/ada/exp_ch8.adb48
-rw-r--r--gcc/ada/exp_ch8.ads2
-rw-r--r--gcc/ada/exp_ch9.adb229
-rw-r--r--gcc/ada/exp_ch9.ads2
-rw-r--r--gcc/ada/exp_code.adb38
-rw-r--r--gcc/ada/exp_code.ads3
-rw-r--r--gcc/ada/exp_dbug.adb71
-rw-r--r--gcc/ada/exp_dbug.ads411
-rw-r--r--gcc/ada/exp_disp.adb429
-rw-r--r--gcc/ada/exp_disp.ads2
-rw-r--r--gcc/ada/exp_dist.adb133
-rw-r--r--gcc/ada/exp_dist.ads2
-rw-r--r--gcc/ada/exp_fixd.adb43
-rw-r--r--gcc/ada/exp_fixd.ads2
-rw-r--r--gcc/ada/exp_imgv.adb1062
-rw-r--r--gcc/ada/exp_imgv.ads58
-rw-r--r--gcc/ada/exp_intr.adb129
-rw-r--r--gcc/ada/exp_intr.ads2
-rw-r--r--gcc/ada/exp_pakd.adb77
-rw-r--r--gcc/ada/exp_pakd.ads2
-rw-r--r--gcc/ada/exp_prag.adb145
-rw-r--r--gcc/ada/exp_prag.ads2
-rw-r--r--gcc/ada/exp_put_image.adb446
-rw-r--r--gcc/ada/exp_put_image.ads15
-rw-r--r--gcc/ada/exp_sel.adb22
-rw-r--r--gcc/ada/exp_sel.ads2
-rw-r--r--gcc/ada/exp_smem.adb44
-rw-r--r--gcc/ada/exp_smem.ads2
-rw-r--r--gcc/ada/exp_spark.adb46
-rw-r--r--gcc/ada/exp_spark.ads2
-rw-r--r--gcc/ada/exp_strm.adb38
-rw-r--r--gcc/ada/exp_strm.ads2
-rw-r--r--gcc/ada/exp_tss.adb29
-rw-r--r--gcc/ada/exp_tss.ads2
-rw-r--r--gcc/ada/exp_unst.adb72
-rw-r--r--gcc/ada/exp_unst.ads2
-rw-r--r--gcc/ada/exp_util.adb487
-rw-r--r--gcc/ada/exp_util.ads37
-rw-r--r--gcc/ada/expander.adb62
-rw-r--r--gcc/ada/expander.ads2
-rw-r--r--gcc/ada/expect.c2
-rw-r--r--gcc/ada/fe.h393
-rw-r--r--gcc/ada/final.c2
-rw-r--r--gcc/ada/fmap.adb2
-rw-r--r--gcc/ada/fmap.ads7
-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.adb2
-rw-r--r--gcc/ada/fname.ads2
-rw-r--r--gcc/ada/freeze.adb735
-rw-r--r--gcc/ada/freeze.ads2
-rw-r--r--gcc/ada/frontend.adb48
-rw-r--r--gcc/ada/frontend.ads2
-rw-r--r--gcc/ada/gcc-interface/Make-lang.in398
-rw-r--r--gcc/ada/gcc-interface/Makefile.in25
-rw-r--r--gcc/ada/gcc-interface/a-assert.adb (renamed from gcc/ada/libgnat/a-stobbu.adb)37
-rw-r--r--gcc/ada/gcc-interface/a-assert.ads50
-rw-r--r--gcc/ada/gcc-interface/ada-tree.h8
-rw-r--r--gcc/ada/gcc-interface/ada.h2
-rw-r--r--gcc/ada/gcc-interface/cuintp.c15
-rw-r--r--gcc/ada/gcc-interface/decl.c444
-rw-r--r--gcc/ada/gcc-interface/gadaint.h2
-rw-r--r--gcc/ada/gcc-interface/gigi.h39
-rw-r--r--gcc/ada/gcc-interface/lang-specs.h2
-rw-r--r--gcc/ada/gcc-interface/misc.c20
-rw-r--r--gcc/ada/gcc-interface/system.ads18
-rw-r--r--gcc/ada/gcc-interface/targtyps.c2
-rw-r--r--gcc/ada/gcc-interface/trans.c489
-rw-r--r--gcc/ada/gcc-interface/utils.c52
-rw-r--r--gcc/ada/gcc-interface/utils2.c68
-rw-r--r--gcc/ada/gen_il-fields.ads948
-rw-r--r--gcc/ada/gen_il-gen-gen_entities.adb1412
-rw-r--r--gcc/ada/gen_il-gen-gen_nodes.adb1652
-rw-r--r--gcc/ada/gen_il-gen.adb3278
-rw-r--r--gcc/ada/gen_il-gen.ads256
-rw-r--r--gcc/ada/gen_il-internals.adb480
-rw-r--r--gcc/ada/gen_il-internals.ads282
-rw-r--r--gcc/ada/gen_il-main.adb34
-rw-r--r--gcc/ada/gen_il-types.ads582
-rw-r--r--gcc/ada/gen_il.adb148
-rw-r--r--gcc/ada/gen_il.ads96
-rw-r--r--gcc/ada/get_scos.adb2
-rw-r--r--gcc/ada/get_scos.ads2
-rw-r--r--gcc/ada/get_targ.adb4
-rw-r--r--gcc/ada/get_targ.ads3
-rw-r--r--gcc/ada/ghost.adb108
-rw-r--r--gcc/ada/ghost.ads2
-rw-r--r--gcc/ada/gnat-style.texi1691
-rw-r--r--gcc/ada/gnat1drv.adb130
-rw-r--r--gcc/ada/gnat1drv.ads2
-rw-r--r--gcc/ada/gnat_cuda.adb71
-rw-r--r--gcc/ada/gnat_cuda.ads2
-rw-r--r--gcc/ada/gnat_rm.texi3543
-rw-r--r--gcc/ada/gnat_ugn.texi999
-rw-r--r--gcc/ada/gnatbind.adb2
-rw-r--r--gcc/ada/gnatbind.ads2
-rw-r--r--gcc/ada/gnatchop.adb7
-rw-r--r--gcc/ada/gnatclean.adb2
-rw-r--r--gcc/ada/gnatcmd.adb33
-rw-r--r--gcc/ada/gnatcmd.ads2
-rw-r--r--gcc/ada/gnatdll.adb9
-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.adb597
-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.adb2
-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.adb17
-rw-r--r--gcc/ada/gnatvsn.ads4
-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.h3
-rw-r--r--gcc/ada/hostparm.ads7
-rw-r--r--gcc/ada/impunit.adb52
-rw-r--r--gcc/ada/impunit.ads4
-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.c34
-rw-r--r--gcc/ada/initialize.c72
-rw-r--r--gcc/ada/inline.adb118
-rw-r--r--gcc/ada/inline.ads2
-rw-r--r--gcc/ada/itypes.adb16
-rw-r--r--gcc/ada/itypes.ads9
-rw-r--r--gcc/ada/krunch.adb19
-rw-r--r--gcc/ada/krunch.ads2
-rw-r--r--gcc/ada/layout.adb129
-rw-r--r--gcc/ada/layout.ads9
-rw-r--r--gcc/ada/lib-list.adb2
-rw-r--r--gcc/ada/lib-load.adb86
-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.adb85
-rw-r--r--gcc/ada/lib-writ.ads5
-rw-r--r--gcc/ada/lib-xref-spark_specific.adb14
-rw-r--r--gcc/ada/lib-xref.adb89
-rw-r--r--gcc/ada/lib-xref.ads4
-rw-r--r--gcc/ada/lib.adb63
-rw-r--r--gcc/ada/lib.ads18
-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.adb2
-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.adb2
-rw-r--r--gcc/ada/libgnarl/a-synbar.ads2
-rw-r--r--gcc/ada/libgnarl/a-synbar__posix.adb2
-rw-r--r--gcc/ada/libgnarl/a-synbar__posix.ads2
-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.adb2
-rw-r--r--gcc/ada/libgnarl/a-taside.ads2
-rw-r--r--gcc/ada/libgnarl/a-tasini.adb2
-rw-r--r--gcc/ada/libgnarl/a-tasini.ads2
-rw-r--r--gcc/ada/libgnarl/a-taster.adb2
-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/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.adb8
-rw-r--r--gcc/ada/libgnarl/s-interr.ads4
-rw-r--r--gcc/ada/libgnarl/s-interr__dummy.adb4
-rw-r--r--gcc/ada/libgnarl/s-interr__hwint.adb6
-rw-r--r--gcc/ada/libgnarl/s-interr__sigaction.adb4
-rw-r--r--gcc/ada/libgnarl/s-interr__vxworks.adb6
-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.ads6
-rw-r--r--gcc/ada/libgnarl/s-linux__alpha.ads6
-rw-r--r--gcc/ada/libgnarl/s-linux__android.ads6
-rw-r--r--gcc/ada/libgnarl/s-linux__hppa.ads6
-rw-r--r--gcc/ada/libgnarl/s-linux__mips.ads6
-rw-r--r--gcc/ada/libgnarl/s-linux__riscv.ads6
-rw-r--r--gcc/ada/libgnarl/s-linux__sparc.ads6
-rw-r--r--gcc/ada/libgnarl/s-linux__x32.ads9
-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.ads7
-rw-r--r--gcc/ada/libgnarl/s-osinte__android.adb2
-rw-r--r--gcc/ada/libgnarl/s-osinte__android.ads6
-rw-r--r--gcc/ada/libgnarl/s-osinte__darwin.adb2
-rw-r--r--gcc/ada/libgnarl/s-osinte__darwin.ads6
-rw-r--r--gcc/ada/libgnarl/s-osinte__dragonfly.adb2
-rw-r--r--gcc/ada/libgnarl/s-osinte__dragonfly.ads7
-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.ads7
-rw-r--r--gcc/ada/libgnarl/s-osinte__gnu.adb2
-rw-r--r--gcc/ada/libgnarl/s-osinte__gnu.ads6
-rw-r--r--gcc/ada/libgnarl/s-osinte__hpux-dce.adb2
-rw-r--r--gcc/ada/libgnarl/s-osinte__hpux-dce.ads7
-rw-r--r--gcc/ada/libgnarl/s-osinte__hpux.ads7
-rw-r--r--gcc/ada/libgnarl/s-osinte__kfreebsd-gnu.ads6
-rw-r--r--gcc/ada/libgnarl/s-osinte__linux.ads4
-rw-r--r--gcc/ada/libgnarl/s-osinte__lynxos178.adb2
-rw-r--r--gcc/ada/libgnarl/s-osinte__lynxos178e.ads6
-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.ads6
-rw-r--r--gcc/ada/libgnarl/s-osinte__rtems.adb2
-rw-r--r--gcc/ada/libgnarl/s-osinte__rtems.ads6
-rw-r--r--gcc/ada/libgnarl/s-osinte__solaris.adb2
-rw-r--r--gcc/ada/libgnarl/s-osinte__solaris.ads7
-rw-r--r--gcc/ada/libgnarl/s-osinte__vxworks.adb2
-rw-r--r--gcc/ada/libgnarl/s-osinte__vxworks.ads9
-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-putaim.adb (renamed from gcc/ada/libgnat/s-putaim.adb)9
-rw-r--r--gcc/ada/libgnarl/s-putaim.ads (renamed from gcc/ada/libgnat/s-putaim.ads)6
-rw-r--r--gcc/ada/libgnarl/s-qnx.ads7
-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.adb2
-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.adb2
-rw-r--r--gcc/ada/libgnarl/s-taenca.ads2
-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.ads2
-rw-r--r--gcc/ada/libgnarl/s-taprop__dummy.adb2
-rw-r--r--gcc/ada/libgnarl/s-taprop__hpux-dce.adb2
-rw-r--r--gcc/ada/libgnarl/s-taprop__linux.adb2
-rw-r--r--gcc/ada/libgnarl/s-taprop__mingw.adb2
-rw-r--r--gcc/ada/libgnarl/s-taprop__posix.adb2
-rw-r--r--gcc/ada/libgnarl/s-taprop__qnx.adb2
-rw-r--r--gcc/ada/libgnarl/s-taprop__solaris.adb2
-rw-r--r--gcc/ada/libgnarl/s-taprop__vxworks.adb2
-rw-r--r--gcc/ada/libgnarl/s-tarest.adb2
-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.ads8
-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.adb6
-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.ads5
-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.adb2
-rw-r--r--gcc/ada/libgnarl/s-tasque.ads2
-rw-r--r--gcc/ada/libgnarl/s-tasren.adb12
-rw-r--r--gcc/ada/libgnarl/s-tasren.ads2
-rw-r--r--gcc/ada/libgnarl/s-tasres.ads2
-rw-r--r--gcc/ada/libgnarl/s-tassta.adb9
-rw-r--r--gcc/ada/libgnarl/s-tassta.ads2
-rw-r--r--gcc/ada/libgnarl/s-tasuti.adb2
-rw-r--r--gcc/ada/libgnarl/s-tasuti.ads2
-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.adb2
-rw-r--r--gcc/ada/libgnarl/s-tpoben.ads2
-rw-r--r--gcc/ada/libgnarl/s-tpobmu.adb6
-rw-r--r--gcc/ada/libgnarl/s-tpobmu.ads2
-rw-r--r--gcc/ada/libgnarl/s-tpobop.adb4
-rw-r--r--gcc/ada/libgnarl/s-tpobop.ads2
-rw-r--r--gcc/ada/libgnarl/s-tpopmo.adb6
-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.adb2
-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.ads19
-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.adb2
-rw-r--r--gcc/ada/libgnat/a-calcon.ads2
-rw-r--r--gcc/ada/libgnat/a-caldel.adb2
-rw-r--r--gcc/ada/libgnat/a-caldel.ads2
-rw-r--r--gcc/ada/libgnat/a-calend.adb2
-rw-r--r--gcc/ada/libgnat/a-calend.ads2
-rw-r--r--gcc/ada/libgnat/a-calfor.adb2
-rw-r--r--gcc/ada/libgnat/a-calfor.ads2
-rw-r--r--gcc/ada/libgnat/a-catizo.adb2
-rw-r--r--gcc/ada/libgnat/a-cbdlli.adb8
-rw-r--r--gcc/ada/libgnat/a-cbdlli.ads6
-rw-r--r--gcc/ada/libgnat/a-cbhama.adb12
-rw-r--r--gcc/ada/libgnat/a-cbhama.ads6
-rw-r--r--gcc/ada/libgnat/a-cbhase.adb8
-rw-r--r--gcc/ada/libgnat/a-cbhase.ads6
-rw-r--r--gcc/ada/libgnat/a-cbmutr.adb8
-rw-r--r--gcc/ada/libgnat/a-cbmutr.ads6
-rw-r--r--gcc/ada/libgnat/a-cborma.adb12
-rw-r--r--gcc/ada/libgnat/a-cborma.ads6
-rw-r--r--gcc/ada/libgnat/a-cborse.adb12
-rw-r--r--gcc/ada/libgnat/a-cborse.ads6
-rw-r--r--gcc/ada/libgnat/a-cbprqu.adb2
-rw-r--r--gcc/ada/libgnat/a-cbprqu.ads2
-rw-r--r--gcc/ada/libgnat/a-cbsyqu.adb2
-rw-r--r--gcc/ada/libgnat/a-cbsyqu.ads2
-rw-r--r--gcc/ada/libgnat/a-cdlili.adb230
-rw-r--r--gcc/ada/libgnat/a-cdlili.ads8
-rw-r--r--gcc/ada/libgnat/a-cfdlli.adb34
-rw-r--r--gcc/ada/libgnat/a-cfdlli.ads56
-rw-r--r--gcc/ada/libgnat/a-cfhama.adb183
-rw-r--r--gcc/ada/libgnat/a-cfhama.ads103
-rw-r--r--gcc/ada/libgnat/a-cfhase.adb214
-rw-r--r--gcc/ada/libgnat/a-cfhase.ads24
-rw-r--r--gcc/ada/libgnat/a-cfinve.adb50
-rw-r--r--gcc/ada/libgnat/a-cfinve.ads51
-rw-r--r--gcc/ada/libgnat/a-cforma.adb238
-rw-r--r--gcc/ada/libgnat/a-cforma.ads103
-rw-r--r--gcc/ada/libgnat/a-cforse.adb271
-rw-r--r--gcc/ada/libgnat/a-cforse.ads32
-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.adb2
-rw-r--r--gcc/ada/libgnat/a-chahan.ads2
-rw-r--r--gcc/ada/libgnat/a-chlat9.ads2
-rw-r--r--gcc/ada/libgnat/a-chtgbk.adb2
-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.adb2
-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.adb4
-rw-r--r--gcc/ada/libgnat/a-cidlli.ads8
-rw-r--r--gcc/ada/libgnat/a-cihama.adb8
-rw-r--r--gcc/ada/libgnat/a-cihama.ads20
-rw-r--r--gcc/ada/libgnat/a-cihase.adb4
-rw-r--r--gcc/ada/libgnat/a-cihase.ads6
-rw-r--r--gcc/ada/libgnat/a-cimutr.adb4
-rw-r--r--gcc/ada/libgnat/a-cimutr.ads6
-rw-r--r--gcc/ada/libgnat/a-ciorma.adb4
-rw-r--r--gcc/ada/libgnat/a-ciorma.ads7
-rw-r--r--gcc/ada/libgnat/a-ciormu.adb4
-rw-r--r--gcc/ada/libgnat/a-ciormu.ads6
-rw-r--r--gcc/ada/libgnat/a-ciorse.adb4
-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.adb38
-rw-r--r--gcc/ada/libgnat/a-coboho.ads12
-rw-r--r--gcc/ada/libgnat/a-cobove.adb12
-rw-r--r--gcc/ada/libgnat/a-cobove.ads15
-rw-r--r--gcc/ada/libgnat/a-cofove.adb38
-rw-r--r--gcc/ada/libgnat/a-cofove.ads51
-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.ads10
-rw-r--r--gcc/ada/libgnat/a-cofuse.adb2
-rw-r--r--gcc/ada/libgnat/a-cofuse.ads9
-rw-r--r--gcc/ada/libgnat/a-cofuve.adb2
-rw-r--r--gcc/ada/libgnat/a-cofuve.ads9
-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.adb19
-rw-r--r--gcc/ada/libgnat/a-cohama.ads24
-rw-r--r--gcc/ada/libgnat/a-cohase.adb22
-rw-r--r--gcc/ada/libgnat/a-cohase.ads29
-rw-r--r--gcc/ada/libgnat/a-cohata.ads2
-rw-r--r--gcc/ada/libgnat/a-coinho.adb4
-rw-r--r--gcc/ada/libgnat/a-coinho.ads6
-rw-r--r--gcc/ada/libgnat/a-coinho__shared.adb4
-rw-r--r--gcc/ada/libgnat/a-coinho__shared.ads6
-rw-r--r--gcc/ada/libgnat/a-coinve.adb4
-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.adb4
-rw-r--r--gcc/ada/libgnat/a-comutr.ads6
-rw-r--r--gcc/ada/libgnat/a-conhel.adb38
-rw-r--r--gcc/ada/libgnat/a-conhel.ads2
-rw-r--r--gcc/ada/libgnat/a-convec.adb4
-rw-r--r--gcc/ada/libgnat/a-convec.ads8
-rw-r--r--gcc/ada/libgnat/a-coorma.adb4
-rw-r--r--gcc/ada/libgnat/a-coorma.ads9
-rw-r--r--gcc/ada/libgnat/a-coormu.adb4
-rw-r--r--gcc/ada/libgnat/a-coormu.ads6
-rw-r--r--gcc/ada/libgnat/a-coorse.adb4
-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.adb2
-rw-r--r--gcc/ada/libgnat/a-crbtgk.ads2
-rw-r--r--gcc/ada/libgnat/a-crbtgo.adb2
-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-decima__128.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.adb19
-rw-r--r--gcc/ada/libgnat/a-except.ads23
-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.adb18
-rw-r--r--gcc/ada/libgnat/a-exextr.adb2
-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-iteint.ads5
-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-nagefl.ads2
-rw-r--r--gcc/ada/libgnat/a-naliop.ads2
-rw-r--r--gcc/ada/libgnat/a-naliop__nolibm.ads2
-rw-r--r--gcc/ada/libgnat/a-nallfl.ads2
-rw-r--r--gcc/ada/libgnat/a-nallfl__wraplf.ads2
-rw-r--r--gcc/ada/libgnat/a-nalofl.ads2
-rw-r--r--gcc/ada/libgnat/a-nashfl.ads2
-rw-r--r--gcc/ada/libgnat/a-nashfl__wraplf.ads2
-rw-r--r--gcc/ada/libgnat/a-nbnbin.adb7
-rw-r--r--gcc/ada/libgnat/a-nbnbin.ads9
-rw-r--r--gcc/ada/libgnat/a-nbnbin__gmp.adb7
-rw-r--r--gcc/ada/libgnat/a-nbnbre.adb20
-rw-r--r--gcc/ada/libgnat/a-nbnbre.ads15
-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.adb2
-rw-r--r--gcc/ada/libgnat/a-ngcoty.ads2
-rw-r--r--gcc/ada/libgnat/a-ngelfu.adb2
-rw-r--r--gcc/ada/libgnat/a-ngelfu.ads4
-rw-r--r--gcc/ada/libgnat/a-ngrear.adb2
-rw-r--r--gcc/ada/libgnat/a-ngrear.ads2
-rw-r--r--gcc/ada/libgnat/a-nuauco.ads2
-rw-r--r--gcc/ada/libgnat/a-nuauco__x86.ads2
-rw-r--r--gcc/ada/libgnat/a-nuaufl.ads2
-rw-r--r--gcc/ada/libgnat/a-nuaufl__wraplf.ads2
-rw-r--r--gcc/ada/libgnat/a-nudira.adb2
-rw-r--r--gcc/ada/libgnat/a-nudira.ads2
-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-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.adb2
-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.adb2
-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-stbubo.adb147
-rw-r--r--gcc/ada/libgnat/a-stbubo.ads73
-rw-r--r--gcc/ada/libgnat/a-stbufi.adb82
-rw-r--r--gcc/ada/libgnat/a-stbufi.ads (renamed from gcc/ada/libgnat/a-stoufi.ads)63
-rw-r--r--gcc/ada/libgnat/a-stbufo.adb (renamed from gcc/ada/libgnat/a-stoufo.adb)63
-rw-r--r--gcc/ada/libgnat/a-stbufo.ads (renamed from gcc/ada/libgnat/a-stoufo.ads)27
-rw-r--r--gcc/ada/libgnat/a-stbuun.adb193
-rw-r--r--gcc/ada/libgnat/a-stbuun.ads87
-rw-r--r--gcc/ada/libgnat/a-stbuut.adb (renamed from gcc/ada/libgnat/a-stobfi.ads)75
-rw-r--r--gcc/ada/libgnat/a-stbuut.ads (renamed from gcc/ada/libgnat/a-stoubu.ads)79
-rw-r--r--gcc/ada/libgnat/a-stmaco.ads2
-rw-r--r--gcc/ada/libgnat/a-stobfi.adb118
-rw-r--r--gcc/ada/libgnat/a-storio.adb2
-rw-r--r--gcc/ada/libgnat/a-stoubu.adb148
-rw-r--r--gcc/ada/libgnat/a-stoufi.adb123
-rw-r--r--gcc/ada/libgnat/a-stouut.adb272
-rw-r--r--gcc/ada/libgnat/a-stouut.ads107
-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.adb140
-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.ads2
-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.adb5
-rw-r--r--gcc/ada/libgnat/a-strunb.ads36
-rw-r--r--gcc/ada/libgnat/a-strunb__shared.adb63
-rw-r--r--gcc/ada/libgnat/a-strunb__shared.ads28
-rw-r--r--gcc/ada/libgnat/a-ststbo.adb2
-rw-r--r--gcc/ada/libgnat/a-ststbo.ads2
-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.adb2
-rw-r--r--gcc/ada/libgnat/a-ststun.ads2
-rw-r--r--gcc/ada/libgnat/a-sttebu.adb121
-rw-r--r--gcc/ada/libgnat/a-sttebu.ads136
-rw-r--r--gcc/ada/libgnat/a-stteou.ads193
-rw-r--r--gcc/ada/libgnat/a-stunau.adb16
-rw-r--r--gcc/ada/libgnat/a-stunau.ads24
-rw-r--r--gcc/ada/libgnat/a-stunau__shared.adb30
-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.adb4
-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.adb4
-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.adb2
-rw-r--r--gcc/ada/libgnat/a-tags.ads2
-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.adb15
-rw-r--r--gcc/ada/libgnat/a-textio.ads7
-rw-r--r--gcc/ada/libgnat/a-tiboio.adb2
-rw-r--r--gcc/ada/libgnat/a-ticoau.adb8
-rw-r--r--gcc/ada/libgnat/a-ticoau.ads4
-rw-r--r--gcc/ada/libgnat/a-ticoio.adb19
-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-tideio__128.adb2
-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-tifiau.adb2
-rw-r--r--gcc/ada/libgnat/a-tifiau.ads2
-rw-r--r--gcc/ada/libgnat/a-tifiio.adb20
-rw-r--r--gcc/ada/libgnat/a-tifiio__128.adb20
-rw-r--r--gcc/ada/libgnat/a-tiflau.adb9
-rw-r--r--gcc/ada/libgnat/a-tiflau.ads10
-rw-r--r--gcc/ada/libgnat/a-tiflio.adb13
-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-tiinio__128.adb2
-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-timoio__128.adb2
-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-uncdea.ads5
-rw-r--r--gcc/ada/libgnat/a-undesu.adb2
-rw-r--r--gcc/ada/libgnat/a-wichha.adb2
-rw-r--r--gcc/ada/libgnat/a-wichun.adb2
-rw-r--r--gcc/ada/libgnat/a-wichun.ads2
-rw-r--r--gcc/ada/libgnat/a-witeio.adb15
-rw-r--r--gcc/ada/libgnat/a-witeio.ads5
-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.adb8
-rw-r--r--gcc/ada/libgnat/a-wtcoau.ads4
-rw-r--r--gcc/ada/libgnat/a-wtcoio.adb19
-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-wtdeio__128.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-wtfiau.adb2
-rw-r--r--gcc/ada/libgnat/a-wtfiau.ads2
-rw-r--r--gcc/ada/libgnat/a-wtfiio.adb21
-rw-r--r--gcc/ada/libgnat/a-wtfiio__128.adb21
-rw-r--r--gcc/ada/libgnat/a-wtflau.adb9
-rw-r--r--gcc/ada/libgnat/a-wtflau.ads10
-rw-r--r--gcc/ada/libgnat/a-wtflio.adb13
-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-wtinio__128.adb2
-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-wtmoio__128.adb2
-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.adb2
-rw-r--r--gcc/ada/libgnat/a-zchuni.adb2
-rw-r--r--gcc/ada/libgnat/a-zchuni.ads2
-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.adb8
-rw-r--r--gcc/ada/libgnat/a-ztcoau.ads2
-rw-r--r--gcc/ada/libgnat/a-ztcoio.adb23
-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-ztdeio__128.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.adb15
-rw-r--r--gcc/ada/libgnat/a-ztexio.ads5
-rw-r--r--gcc/ada/libgnat/a-ztfiau.adb2
-rw-r--r--gcc/ada/libgnat/a-ztfiau.ads2
-rw-r--r--gcc/ada/libgnat/a-ztfiio.adb21
-rw-r--r--gcc/ada/libgnat/a-ztfiio__128.adb21
-rw-r--r--gcc/ada/libgnat/a-ztflau.adb9
-rw-r--r--gcc/ada/libgnat/a-ztflau.ads10
-rw-r--r--gcc/ada/libgnat/a-ztflio.adb13
-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-ztinio__128.adb2
-rw-r--r--gcc/ada/libgnat/a-ztmoio.adb2
-rw-r--r--gcc/ada/libgnat/a-ztmoio__128.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.adb4
-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.adb2
-rw-r--r--gcc/ada/libgnat/g-bytswa.ads2
-rw-r--r--gcc/ada/libgnat/g-calend.adb2
-rw-r--r--gcc/ada/libgnat/g-calend.ads2
-rw-r--r--gcc/ada/libgnat/g-casuti.adb12
-rw-r--r--gcc/ada/libgnat/g-casuti.ads38
-rw-r--r--gcc/ada/libgnat/g-catiio.adb2
-rw-r--r--gcc/ada/libgnat/g-catiio.ads2
-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.adb2
-rw-r--r--gcc/ada/libgnat/g-comlin.ads2
-rw-r--r--gcc/ada/libgnat/g-comver.adb13
-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.adb4
-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.adb2
-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.adb2
-rw-r--r--gcc/ada/libgnat/g-excact.ads2
-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.adb2
-rw-r--r--gcc/ada/libgnat/g-exptty.ads2
-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.ads4
-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.adb2
-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.adb2
-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.ads8
-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.adb2000
-rw-r--r--gcc/ada/libgnat/g-pehage.ads117
-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.adb6
-rw-r--r--gcc/ada/libgnat/g-rewdat.ads2
-rw-r--r--gcc/ada/libgnat/g-sechas.adb4
-rw-r--r--gcc/ada/libgnat/g-sechas.ads2
-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.adb2
-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.adb48
-rw-r--r--gcc/ada/libgnat/g-socket.ads48
-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-socpol.adb2
-rw-r--r--gcc/ada/libgnat/g-socpol.ads2
-rw-r--r--gcc/ada/libgnat/g-socpol__dummy.adb2
-rw-r--r--gcc/ada/libgnat/g-socpol__dummy.ads2
-rw-r--r--gcc/ada/libgnat/g-socthi.adb2
-rw-r--r--gcc/ada/libgnat/g-socthi.ads2
-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.adb2
-rw-r--r--gcc/ada/libgnat/g-socthi__vxworks.ads2
-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-sopowa.adb2
-rw-r--r--gcc/ada/libgnat/g-sopowa__mingw.adb2
-rw-r--r--gcc/ada/libgnat/g-sopowa__posix.adb2
-rw-r--r--gcc/ada/libgnat/g-sothco.adb2
-rw-r--r--gcc/ada/libgnat/g-sothco.ads9
-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.ads2
-rw-r--r--gcc/ada/libgnat/g-spogwa.adb2
-rw-r--r--gcc/ada/libgnat/g-spogwa.ads2
-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.ads4
-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.ads5
-rw-r--r--gcc/ada/libgnat/i-cexten.ads5
-rw-r--r--gcc/ada/libgnat/i-cexten__128.ads5
-rw-r--r--gcc/ada/libgnat/i-cobol.adb4
-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/interfac__2020.ads2
-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.adb2
-rw-r--r--gcc/ada/libgnat/s-aoinar.ads2
-rw-r--r--gcc/ada/libgnat/s-aomoar.adb2
-rw-r--r--gcc/ada/libgnat/s-aomoar.ads2
-rw-r--r--gcc/ada/libgnat/s-aotase.adb2
-rw-r--r--gcc/ada/libgnat/s-aotase.ads2
-rw-r--r--gcc/ada/libgnat/s-aridou.adb2
-rw-r--r--gcc/ada/libgnat/s-aridou.ads2
-rw-r--r--gcc/ada/libgnat/s-arit128.adb2
-rw-r--r--gcc/ada/libgnat/s-arit128.ads2
-rw-r--r--gcc/ada/libgnat/s-arit32.adb2
-rw-r--r--gcc/ada/libgnat/s-arit32.ads2
-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.ads6
-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.ads3
-rw-r--r--gcc/ada/libgnat/s-atocou__builtin.adb22
-rw-r--r--gcc/ada/libgnat/s-atocou__x86.adb2
-rw-r--r--gcc/ada/libgnat/s-atoope.ads2
-rw-r--r--gcc/ada/libgnat/s-atopex.adb2
-rw-r--r--gcc/ada/libgnat/s-atopex.ads2
-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.ads2
-rw-r--r--gcc/ada/libgnat/s-bignum.adb2
-rw-r--r--gcc/ada/libgnat/s-bignum.ads2
-rw-r--r--gcc/ada/libgnat/s-bitfie.ads17
-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.adb41
-rw-r--r--gcc/ada/libgnat/s-bituti.ads22
-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-casi128.adb2
-rw-r--r--gcc/ada/libgnat/s-casi128.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-caun128.adb2
-rw-r--r--gcc/ada/libgnat/s-caun128.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-dorepr.adb172
-rw-r--r--gcc/ada/libgnat/s-dorepr__fma.adb97
-rw-r--r--gcc/ada/libgnat/s-dourea.adb258
-rw-r--r--gcc/ada/libgnat/s-dourea.ads123
-rw-r--r--gcc/ada/libgnat/s-dsaser.ads2
-rw-r--r--gcc/ada/libgnat/s-dwalin.adb846
-rw-r--r--gcc/ada/libgnat/s-dwalin.ads126
-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.adb17
-rw-r--r--gcc/ada/libgnat/s-except.ads24
-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-exnflt.ads41
-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-exnlfl.ads41
-rw-r--r--gcc/ada/libgnat/s-exnllf.adb156
-rw-r--r--gcc/ada/libgnat/s-exnllf.ads20
-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-exnllli.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-expllli.ads2
-rw-r--r--gcc/ada/libgnat/s-explllu.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-exponn.adb2
-rw-r--r--gcc/ada/libgnat/s-exponn.ads2
-rw-r--r--gcc/ada/libgnat/s-exponr.adb125
-rw-r--r--gcc/ada/libgnat/s-exponr.ads (renamed from gcc/ada/libgnat/a-stobbu.ads)14
-rw-r--r--gcc/ada/libgnat/s-expont.adb2
-rw-r--r--gcc/ada/libgnat/s-expont.ads2
-rw-r--r--gcc/ada/libgnat/s-exponu.adb2
-rw-r--r--gcc/ada/libgnat/s-exponu.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.adb397
-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-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.ads4
-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-fode128.ads2
-rw-r--r--gcc/ada/libgnat/s-fode32.ads2
-rw-r--r--gcc/ada/libgnat/s-fode64.ads2
-rw-r--r--gcc/ada/libgnat/s-fofi128.ads2
-rw-r--r--gcc/ada/libgnat/s-fofi32.ads2
-rw-r--r--gcc/ada/libgnat/s-fofi64.ads2
-rw-r--r--gcc/ada/libgnat/s-fore_d.adb2
-rw-r--r--gcc/ada/libgnat/s-fore_d.ads2
-rw-r--r--gcc/ada/libgnat/s-fore_f.adb2
-rw-r--r--gcc/ada/libgnat/s-fore_f.ads2
-rw-r--r--gcc/ada/libgnat/s-forrea.adb14
-rw-r--r--gcc/ada/libgnat/s-forrea.ads10
-rw-r--r--gcc/ada/libgnat/s-gearop.adb2
-rw-r--r--gcc/ada/libgnat/s-gearop.ads2
-rw-r--r--gcc/ada/libgnat/s-genbig.adb2
-rw-r--r--gcc/ada/libgnat/s-genbig.ads2
-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-imageb.adb2
-rw-r--r--gcc/ada/libgnat/s-imageb.ads2
-rw-r--r--gcc/ada/libgnat/s-imaged.adb2
-rw-r--r--gcc/ada/libgnat/s-imaged.ads2
-rw-r--r--gcc/ada/libgnat/s-imagef.adb2
-rw-r--r--gcc/ada/libgnat/s-imagef.ads4
-rw-r--r--gcc/ada/libgnat/s-imagei.adb2
-rw-r--r--gcc/ada/libgnat/s-imagei.ads2
-rw-r--r--gcc/ada/libgnat/s-imagen.adb79
-rw-r--r--gcc/ada/libgnat/s-imagen.ads (renamed from gcc/ada/libgnat/s-imgenu.ads)49
-rw-r--r--gcc/ada/libgnat/s-imager.adb464
-rw-r--r--gcc/ada/libgnat/s-imager.ads92
-rw-r--r--gcc/ada/libgnat/s-imageu.adb2
-rw-r--r--gcc/ada/libgnat/s-imageu.ads2
-rw-r--r--gcc/ada/libgnat/s-imagew.adb2
-rw-r--r--gcc/ada/libgnat/s-imagew.ads2
-rw-r--r--gcc/ada/libgnat/s-imde128.ads2
-rw-r--r--gcc/ada/libgnat/s-imde32.ads2
-rw-r--r--gcc/ada/libgnat/s-imde64.ads2
-rw-r--r--gcc/ada/libgnat/s-imen16.ads51
-rw-r--r--gcc/ada/libgnat/s-imen32.ads51
-rw-r--r--gcc/ada/libgnat/s-imenne.adb2
-rw-r--r--gcc/ada/libgnat/s-imenne.ads12
-rw-r--r--gcc/ada/libgnat/s-imenu8.ads51
-rw-r--r--gcc/ada/libgnat/s-imfi128.ads2
-rw-r--r--gcc/ada/libgnat/s-imfi32.ads2
-rw-r--r--gcc/ada/libgnat/s-imfi64.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-imgenu.adb128
-rw-r--r--gcc/ada/libgnat/s-imgflt.ads66
-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-imglfl.ads80
-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-imgllf.ads73
-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-imglllb.ads2
-rw-r--r--gcc/ada/libgnat/s-imgllli.ads2
-rw-r--r--gcc/ada/libgnat/s-imglllu.ads2
-rw-r--r--gcc/ada/libgnat/s-imglllw.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.adb691
-rw-r--r--gcc/ada/libgnat/s-imgrea.ads50
-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-imguti.adb83
-rw-r--r--gcc/ada/libgnat/s-imguti.ads22
-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.adb2
-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.ads2
-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.adb13
-rw-r--r--gcc/ada/libgnat/s-objrea.ads7
-rw-r--r--gcc/ada/libgnat/s-optide.adb2
-rw-r--r--gcc/ada/libgnat/s-os_lib.adb100
-rw-r--r--gcc/ada/libgnat/s-os_lib.ads35
-rw-r--r--gcc/ada/libgnat/s-osprim.ads2
-rw-r--r--gcc/ada/libgnat/s-osprim__darwin.adb6
-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.adb6
-rw-r--r--gcc/ada/libgnat/s-osprim__posix2008.adb6
-rw-r--r--gcc/ada/libgnat/s-osprim__rtems.adb6
-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.adb7
-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-pack100.adb2
-rw-r--r--gcc/ada/libgnat/s-pack100.ads2
-rw-r--r--gcc/ada/libgnat/s-pack101.adb2
-rw-r--r--gcc/ada/libgnat/s-pack101.ads2
-rw-r--r--gcc/ada/libgnat/s-pack102.adb2
-rw-r--r--gcc/ada/libgnat/s-pack102.ads2
-rw-r--r--gcc/ada/libgnat/s-pack103.adb2
-rw-r--r--gcc/ada/libgnat/s-pack103.ads2
-rw-r--r--gcc/ada/libgnat/s-pack104.adb2
-rw-r--r--gcc/ada/libgnat/s-pack104.ads2
-rw-r--r--gcc/ada/libgnat/s-pack105.adb2
-rw-r--r--gcc/ada/libgnat/s-pack105.ads2
-rw-r--r--gcc/ada/libgnat/s-pack106.adb2
-rw-r--r--gcc/ada/libgnat/s-pack106.ads2
-rw-r--r--gcc/ada/libgnat/s-pack107.adb2
-rw-r--r--gcc/ada/libgnat/s-pack107.ads2
-rw-r--r--gcc/ada/libgnat/s-pack108.adb2
-rw-r--r--gcc/ada/libgnat/s-pack108.ads2
-rw-r--r--gcc/ada/libgnat/s-pack109.adb2
-rw-r--r--gcc/ada/libgnat/s-pack109.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-pack110.adb2
-rw-r--r--gcc/ada/libgnat/s-pack110.ads2
-rw-r--r--gcc/ada/libgnat/s-pack111.adb2
-rw-r--r--gcc/ada/libgnat/s-pack111.ads2
-rw-r--r--gcc/ada/libgnat/s-pack112.adb2
-rw-r--r--gcc/ada/libgnat/s-pack112.ads2
-rw-r--r--gcc/ada/libgnat/s-pack113.adb2
-rw-r--r--gcc/ada/libgnat/s-pack113.ads2
-rw-r--r--gcc/ada/libgnat/s-pack114.adb2
-rw-r--r--gcc/ada/libgnat/s-pack114.ads2
-rw-r--r--gcc/ada/libgnat/s-pack115.adb2
-rw-r--r--gcc/ada/libgnat/s-pack115.ads2
-rw-r--r--gcc/ada/libgnat/s-pack116.adb2
-rw-r--r--gcc/ada/libgnat/s-pack116.ads2
-rw-r--r--gcc/ada/libgnat/s-pack117.adb2
-rw-r--r--gcc/ada/libgnat/s-pack117.ads2
-rw-r--r--gcc/ada/libgnat/s-pack118.adb2
-rw-r--r--gcc/ada/libgnat/s-pack118.ads2
-rw-r--r--gcc/ada/libgnat/s-pack119.adb2
-rw-r--r--gcc/ada/libgnat/s-pack119.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-pack120.adb2
-rw-r--r--gcc/ada/libgnat/s-pack120.ads2
-rw-r--r--gcc/ada/libgnat/s-pack121.adb2
-rw-r--r--gcc/ada/libgnat/s-pack121.ads2
-rw-r--r--gcc/ada/libgnat/s-pack122.adb2
-rw-r--r--gcc/ada/libgnat/s-pack122.ads2
-rw-r--r--gcc/ada/libgnat/s-pack123.adb2
-rw-r--r--gcc/ada/libgnat/s-pack123.ads2
-rw-r--r--gcc/ada/libgnat/s-pack124.adb2
-rw-r--r--gcc/ada/libgnat/s-pack124.ads2
-rw-r--r--gcc/ada/libgnat/s-pack125.adb2
-rw-r--r--gcc/ada/libgnat/s-pack125.ads2
-rw-r--r--gcc/ada/libgnat/s-pack126.adb2
-rw-r--r--gcc/ada/libgnat/s-pack126.ads2
-rw-r--r--gcc/ada/libgnat/s-pack127.adb2
-rw-r--r--gcc/ada/libgnat/s-pack127.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-pack65.adb2
-rw-r--r--gcc/ada/libgnat/s-pack65.ads2
-rw-r--r--gcc/ada/libgnat/s-pack66.adb2
-rw-r--r--gcc/ada/libgnat/s-pack66.ads2
-rw-r--r--gcc/ada/libgnat/s-pack67.adb2
-rw-r--r--gcc/ada/libgnat/s-pack67.ads2
-rw-r--r--gcc/ada/libgnat/s-pack68.adb2
-rw-r--r--gcc/ada/libgnat/s-pack68.ads2
-rw-r--r--gcc/ada/libgnat/s-pack69.adb2
-rw-r--r--gcc/ada/libgnat/s-pack69.ads2
-rw-r--r--gcc/ada/libgnat/s-pack70.adb2
-rw-r--r--gcc/ada/libgnat/s-pack70.ads2
-rw-r--r--gcc/ada/libgnat/s-pack71.adb2
-rw-r--r--gcc/ada/libgnat/s-pack71.ads2
-rw-r--r--gcc/ada/libgnat/s-pack72.adb2
-rw-r--r--gcc/ada/libgnat/s-pack72.ads2
-rw-r--r--gcc/ada/libgnat/s-pack73.adb2
-rw-r--r--gcc/ada/libgnat/s-pack73.ads2
-rw-r--r--gcc/ada/libgnat/s-pack74.adb2
-rw-r--r--gcc/ada/libgnat/s-pack74.ads2
-rw-r--r--gcc/ada/libgnat/s-pack75.adb2
-rw-r--r--gcc/ada/libgnat/s-pack75.ads2
-rw-r--r--gcc/ada/libgnat/s-pack76.adb2
-rw-r--r--gcc/ada/libgnat/s-pack76.ads2
-rw-r--r--gcc/ada/libgnat/s-pack77.adb2
-rw-r--r--gcc/ada/libgnat/s-pack77.ads2
-rw-r--r--gcc/ada/libgnat/s-pack78.adb2
-rw-r--r--gcc/ada/libgnat/s-pack78.ads2
-rw-r--r--gcc/ada/libgnat/s-pack79.adb2
-rw-r--r--gcc/ada/libgnat/s-pack79.ads2
-rw-r--r--gcc/ada/libgnat/s-pack80.adb2
-rw-r--r--gcc/ada/libgnat/s-pack80.ads2
-rw-r--r--gcc/ada/libgnat/s-pack81.adb2
-rw-r--r--gcc/ada/libgnat/s-pack81.ads2
-rw-r--r--gcc/ada/libgnat/s-pack82.adb2
-rw-r--r--gcc/ada/libgnat/s-pack82.ads2
-rw-r--r--gcc/ada/libgnat/s-pack83.adb2
-rw-r--r--gcc/ada/libgnat/s-pack83.ads2
-rw-r--r--gcc/ada/libgnat/s-pack84.adb2
-rw-r--r--gcc/ada/libgnat/s-pack84.ads2
-rw-r--r--gcc/ada/libgnat/s-pack85.adb2
-rw-r--r--gcc/ada/libgnat/s-pack85.ads2
-rw-r--r--gcc/ada/libgnat/s-pack86.adb2
-rw-r--r--gcc/ada/libgnat/s-pack86.ads2
-rw-r--r--gcc/ada/libgnat/s-pack87.adb2
-rw-r--r--gcc/ada/libgnat/s-pack87.ads2
-rw-r--r--gcc/ada/libgnat/s-pack88.adb2
-rw-r--r--gcc/ada/libgnat/s-pack88.ads2
-rw-r--r--gcc/ada/libgnat/s-pack89.adb2
-rw-r--r--gcc/ada/libgnat/s-pack89.ads2
-rw-r--r--gcc/ada/libgnat/s-pack90.adb2
-rw-r--r--gcc/ada/libgnat/s-pack90.ads2
-rw-r--r--gcc/ada/libgnat/s-pack91.adb2
-rw-r--r--gcc/ada/libgnat/s-pack91.ads2
-rw-r--r--gcc/ada/libgnat/s-pack92.adb2
-rw-r--r--gcc/ada/libgnat/s-pack92.ads2
-rw-r--r--gcc/ada/libgnat/s-pack93.adb2
-rw-r--r--gcc/ada/libgnat/s-pack93.ads2
-rw-r--r--gcc/ada/libgnat/s-pack94.adb2
-rw-r--r--gcc/ada/libgnat/s-pack94.ads2
-rw-r--r--gcc/ada/libgnat/s-pack95.adb2
-rw-r--r--gcc/ada/libgnat/s-pack95.ads2
-rw-r--r--gcc/ada/libgnat/s-pack96.adb2
-rw-r--r--gcc/ada/libgnat/s-pack96.ads2
-rw-r--r--gcc/ada/libgnat/s-pack97.adb2
-rw-r--r--gcc/ada/libgnat/s-pack97.ads2
-rw-r--r--gcc/ada/libgnat/s-pack98.adb2
-rw-r--r--gcc/ada/libgnat/s-pack98.ads2
-rw-r--r--gcc/ada/libgnat/s-pack99.adb2
-rw-r--r--gcc/ada/libgnat/s-pack99.ads2
-rw-r--r--gcc/ada/libgnat/s-parame.adb2
-rw-r--r--gcc/ada/libgnat/s-parame.ads9
-rw-r--r--gcc/ada/libgnat/s-parame__ae653.ads9
-rw-r--r--gcc/ada/libgnat/s-parame__hpux.ads9
-rw-r--r--gcc/ada/libgnat/s-parame__posix2008.ads193
-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.ads17
-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-pehage.adb2235
-rw-r--r--gcc/ada/libgnat/s-pehage.ads212
-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-powflt.ads70
-rw-r--r--gcc/ada/libgnat/s-powlfl.ads364
-rw-r--r--gcc/ada/libgnat/s-powllf.ads97
-rw-r--r--gcc/ada/libgnat/s-purexc.ads2
-rw-r--r--gcc/ada/libgnat/s-putima.adb18
-rw-r--r--gcc/ada/libgnat/s-putima.ads6
-rw-r--r--gcc/ada/libgnat/s-rannum.adb12
-rw-r--r--gcc/ada/libgnat/s-rannum.ads10
-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.ads2
-rw-r--r--gcc/ada/libgnat/s-regpat.adb2
-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.ads3
-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.adb68
-rw-r--r--gcc/ada/libgnat/s-scaval.ads2
-rw-r--r--gcc/ada/libgnat/s-scaval__128.adb67
-rw-r--r--gcc/ada/libgnat/s-scaval__128.ads2
-rw-r--r--gcc/ada/libgnat/s-secsta.adb2
-rw-r--r--gcc/ada/libgnat/s-secsta.ads2
-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.ads2
-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.ads28
-rw-r--r--gcc/ada/libgnat/s-statxd.adb2
-rw-r--r--gcc/ada/libgnat/s-statxd.ads2
-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.ads5
-rw-r--r--gcc/ada/libgnat/s-stopoo.adb2
-rw-r--r--gcc/ada/libgnat/s-stopoo.ads2
-rw-r--r--gcc/ada/libgnat/s-stposu.adb2
-rw-r--r--gcc/ada/libgnat/s-stposu.ads2
-rw-r--r--gcc/ada/libgnat/s-stratt.adb2
-rw-r--r--gcc/ada/libgnat/s-stratt.ads2
-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.adb2
-rw-r--r--gcc/ada/libgnat/s-ststop.ads2
-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.adb2
-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.adb2
-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.ads5
-rw-r--r--gcc/ada/libgnat/s-utf_32.adb2
-rw-r--r--gcc/ada/libgnat/s-utf_32.ads2
-rw-r--r--gcc/ada/libgnat/s-vade128.ads2
-rw-r--r--gcc/ada/libgnat/s-vade32.ads2
-rw-r--r--gcc/ada/libgnat/s-vade64.ads2
-rw-r--r--gcc/ada/libgnat/s-vaen16.ads61
-rw-r--r--gcc/ada/libgnat/s-vaen32.ads61
-rw-r--r--gcc/ada/libgnat/s-vaenu8.ads61
-rw-r--r--gcc/ada/libgnat/s-vafi128.ads2
-rw-r--r--gcc/ada/libgnat/s-vafi32.ads2
-rw-r--r--gcc/ada/libgnat/s-vafi64.ads2
-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-valflt.ads8
-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-vallfl.ads8
-rw-r--r--gcc/ada/libgnat/s-valllf.ads8
-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-valllli.ads2
-rw-r--r--gcc/ada/libgnat/s-vallllu.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.adb198
-rw-r--r--gcc/ada/libgnat/s-valrea.ads6
-rw-r--r--gcc/ada/libgnat/s-valued.adb2
-rw-r--r--gcc/ada/libgnat/s-valued.ads2
-rw-r--r--gcc/ada/libgnat/s-valuef.adb2
-rw-r--r--gcc/ada/libgnat/s-valuef.ads2
-rw-r--r--gcc/ada/libgnat/s-valuei.adb2
-rw-r--r--gcc/ada/libgnat/s-valuei.ads2
-rw-r--r--gcc/ada/libgnat/s-valuen.adb (renamed from gcc/ada/libgnat/s-valenu.adb)166
-rw-r--r--gcc/ada/libgnat/s-valuen.ads (renamed from gcc/ada/libgnat/s-valenu.ads)42
-rw-r--r--gcc/ada/libgnat/s-valuer.adb15
-rw-r--r--gcc/ada/libgnat/s-valuer.ads2
-rw-r--r--gcc/ada/libgnat/s-valueu.adb2
-rw-r--r--gcc/ada/libgnat/s-valueu.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.adb6
-rw-r--r--gcc/ada/libgnat/s-valuti.ads6
-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-widint.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-widllli.ads2
-rw-r--r--gcc/ada/libgnat/s-widlllu.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-widthi.adb2
-rw-r--r--gcc/ada/libgnat/s-widthi.ads2
-rw-r--r--gcc/ada/libgnat/s-widthu.adb2
-rw-r--r--gcc/ada/libgnat/s-widthu.ads2
-rw-r--r--gcc/ada/libgnat/s-widuns.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.ads2
-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/link.c2
-rw-r--r--gcc/ada/live.adb25
-rw-r--r--gcc/ada/live.ads2
-rw-r--r--gcc/ada/locales.c2
-rw-r--r--gcc/ada/make.adb39
-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.ads3
-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.adb17
-rw-r--r--gcc/ada/namet.ads36
-rw-r--r--gcc/ada/namet.h35
-rw-r--r--gcc/ada/nlists.adb46
-rw-r--r--gcc/ada/nlists.ads8
-rw-r--r--gcc/ada/nlists.h23
-rw-r--r--gcc/ada/nmake.adt80
-rw-r--r--gcc/ada/opt.adb7
-rw-r--r--gcc/ada/opt.ads55
-rw-r--r--gcc/ada/osint-b.adb2
-rw-r--r--gcc/ada/osint-b.ads2
-rw-r--r--gcc/ada/osint-c.adb2
-rw-r--r--gcc/ada/osint-c.ads2
-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.adb32
-rw-r--r--gcc/ada/osint.ads24
-rw-r--r--gcc/ada/output.adb2
-rw-r--r--gcc/ada/output.ads2
-rw-r--r--gcc/ada/par-ch10.adb30
-rw-r--r--gcc/ada/par-ch11.adb22
-rw-r--r--gcc/ada/par-ch12.adb27
-rw-r--r--gcc/ada/par-ch13.adb2
-rw-r--r--gcc/ada/par-ch2.adb2
-rw-r--r--gcc/ada/par-ch3.adb217
-rw-r--r--gcc/ada/par-ch4.adb101
-rw-r--r--gcc/ada/par-ch5.adb82
-rw-r--r--gcc/ada/par-ch6.adb104
-rw-r--r--gcc/ada/par-ch7.adb2
-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.adb40
-rw-r--r--gcc/ada/par-prag.adb57
-rw-r--r--gcc/ada/par-sync.adb2
-rw-r--r--gcc/ada/par-tchk.adb2
-rw-r--r--gcc/ada/par-util.adb37
-rw-r--r--gcc/ada/par.adb74
-rw-r--r--gcc/ada/par.ads2
-rw-r--r--gcc/ada/par_sco.adb63
-rw-r--r--gcc/ada/par_sco.ads2
-rw-r--r--gcc/ada/pprint.adb104
-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.c76
-rw-r--r--gcc/ada/raise.c64
-rw-r--r--gcc/ada/raise.h10
-rw-r--r--gcc/ada/repinfo-input.adb8
-rw-r--r--gcc/ada/repinfo-input.ads2
-rw-r--r--gcc/ada/repinfo.adb131
-rw-r--r--gcc/ada/repinfo.ads9
-rw-r--r--gcc/ada/repinfo.h2
-rw-r--r--gcc/ada/restrict.adb56
-rw-r--r--gcc/ada/restrict.ads12
-rw-r--r--gcc/ada/rident.ads2
-rw-r--r--gcc/ada/rtfinal.c2
-rw-r--r--gcc/ada/rtinit.c20
-rw-r--r--gcc/ada/rtsfind.adb85
-rw-r--r--gcc/ada/rtsfind.ads176
-rw-r--r--gcc/ada/runtime.h6
-rw-r--r--gcc/ada/s-oscons-tmplt.c47
-rw-r--r--gcc/ada/sa_messages.adb2
-rw-r--r--gcc/ada/sa_messages.ads4
-rw-r--r--gcc/ada/scans.adb2
-rw-r--r--gcc/ada/scans.ads10
-rw-r--r--gcc/ada/scil_ll.adb11
-rw-r--r--gcc/ada/scil_ll.ads2
-rw-r--r--gcc/ada/scn.adb32
-rw-r--r--gcc/ada/scn.ads2
-rw-r--r--gcc/ada/scng.adb30
-rw-r--r--gcc/ada/scng.ads2
-rw-r--r--gcc/ada/scos.adb2
-rw-r--r--gcc/ada/scos.ads2
-rw-r--r--gcc/ada/scos.h2
-rw-r--r--gcc/ada/sdefault.ads2
-rw-r--r--gcc/ada/seh_init.c6
-rw-r--r--gcc/ada/sem.adb80
-rw-r--r--gcc/ada/sem.ads5
-rw-r--r--gcc/ada/sem_aggr.adb236
-rw-r--r--gcc/ada/sem_aggr.ads2
-rw-r--r--gcc/ada/sem_attr.adb430
-rw-r--r--gcc/ada/sem_attr.ads2
-rw-r--r--gcc/ada/sem_aux.adb34
-rw-r--r--gcc/ada/sem_aux.ads2
-rw-r--r--gcc/ada/sem_case.adb1751
-rw-r--r--gcc/ada/sem_case.ads20
-rw-r--r--gcc/ada/sem_cat.adb161
-rw-r--r--gcc/ada/sem_cat.ads4
-rw-r--r--gcc/ada/sem_ch10.adb147
-rw-r--r--gcc/ada/sem_ch10.ads2
-rw-r--r--gcc/ada/sem_ch11.adb72
-rw-r--r--gcc/ada/sem_ch11.ads3
-rw-r--r--gcc/ada/sem_ch12.adb875
-rw-r--r--gcc/ada/sem_ch12.ads2
-rw-r--r--gcc/ada/sem_ch13.adb818
-rw-r--r--gcc/ada/sem_ch13.ads25
-rw-r--r--gcc/ada/sem_ch2.adb26
-rw-r--r--gcc/ada/sem_ch2.ads2
-rw-r--r--gcc/ada/sem_ch3.adb1281
-rw-r--r--gcc/ada/sem_ch3.ads20
-rw-r--r--gcc/ada/sem_ch4.adb214
-rw-r--r--gcc/ada/sem_ch4.ads2
-rw-r--r--gcc/ada/sem_ch5.adb457
-rw-r--r--gcc/ada/sem_ch5.ads3
-rw-r--r--gcc/ada/sem_ch6.adb635
-rw-r--r--gcc/ada/sem_ch6.ads6
-rw-r--r--gcc/ada/sem_ch7.adb123
-rw-r--r--gcc/ada/sem_ch7.ads2
-rw-r--r--gcc/ada/sem_ch8.adb430
-rw-r--r--gcc/ada/sem_ch8.ads2
-rw-r--r--gcc/ada/sem_ch9.adb138
-rw-r--r--gcc/ada/sem_ch9.ads2
-rw-r--r--gcc/ada/sem_dim.adb72
-rw-r--r--gcc/ada/sem_dim.ads2
-rw-r--r--gcc/ada/sem_disp.adb207
-rw-r--r--gcc/ada/sem_disp.ads34
-rw-r--r--gcc/ada/sem_dist.adb52
-rw-r--r--gcc/ada/sem_dist.ads2
-rw-r--r--gcc/ada/sem_elab.adb96
-rw-r--r--gcc/ada/sem_elab.ads2
-rw-r--r--gcc/ada/sem_elim.adb41
-rw-r--r--gcc/ada/sem_elim.ads2
-rw-r--r--gcc/ada/sem_eval.adb429
-rw-r--r--gcc/ada/sem_eval.ads5
-rw-r--r--gcc/ada/sem_intr.adb36
-rw-r--r--gcc/ada/sem_intr.ads2
-rw-r--r--gcc/ada/sem_mech.adb21
-rw-r--r--gcc/ada/sem_mech.ads2
-rw-r--r--gcc/ada/sem_prag.adb578
-rw-r--r--gcc/ada/sem_prag.ads10
-rw-r--r--gcc/ada/sem_res.adb540
-rw-r--r--gcc/ada/sem_res.ads4
-rw-r--r--gcc/ada/sem_scil.adb39
-rw-r--r--gcc/ada/sem_scil.ads2
-rw-r--r--gcc/ada/sem_smem.adb19
-rw-r--r--gcc/ada/sem_smem.ads2
-rw-r--r--gcc/ada/sem_type.adb298
-rw-r--r--gcc/ada/sem_type.ads16
-rw-r--r--gcc/ada/sem_util.adb2131
-rw-r--r--gcc/ada/sem_util.ads311
-rw-r--r--gcc/ada/sem_warn.adb343
-rw-r--r--gcc/ada/sem_warn.ads2
-rw-r--r--gcc/ada/set_targ.adb9
-rw-r--r--gcc/ada/set_targ.ads17
-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-target.h (renamed from gcc/ada/sigtramp-vxworks-target.inc)12
-rw-r--r--gcc/ada/sigtramp-vxworks.c4
-rw-r--r--gcc/ada/sigtramp.h2
-rw-r--r--gcc/ada/sinfo-cn.adb42
-rw-r--r--gcc/ada/sinfo-cn.ads11
-rw-r--r--gcc/ada/sinfo-utils.adb349
-rw-r--r--gcc/ada/sinfo-utils.ads162
-rw-r--r--gcc/ada/sinfo.adb7166
-rw-r--r--gcc/ada/sinfo.ads7881
-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.adb69
-rw-r--r--gcc/ada/sinput-l.ads2
-rw-r--r--gcc/ada/sinput.adb37
-rw-r--r--gcc/ada/sinput.ads2
-rw-r--r--gcc/ada/snames.adb-tmpl2
-rw-r--r--gcc/ada/snames.ads-tmpl26
-rw-r--r--gcc/ada/socket.c2
-rw-r--r--gcc/ada/spark_xrefs.adb2
-rw-r--r--gcc/ada/spark_xrefs.ads2
-rw-r--r--gcc/ada/sprint.adb108
-rw-r--r--gcc/ada/sprint.ads2
-rw-r--r--gcc/ada/stand.ads10
-rw-r--r--gcc/ada/stringt.adb2
-rw-r--r--gcc/ada/stringt.ads4
-rw-r--r--gcc/ada/stringt.h2
-rw-r--r--gcc/ada/style.adb84
-rw-r--r--gcc/ada/style.ads2
-rw-r--r--gcc/ada/styleg.adb32
-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.adb10
-rw-r--r--gcc/ada/switch-b.ads2
-rw-r--r--gcc/ada/switch-c.adb31
-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.adb2
-rw-r--r--gcc/ada/switch.ads4
-rw-r--r--gcc/ada/sysdep.c2
-rw-r--r--gcc/ada/table.adb2
-rw-r--r--gcc/ada/table.ads2
-rw-r--r--gcc/ada/targext.c2
-rw-r--r--gcc/ada/targparm.adb2
-rw-r--r--gcc/ada/targparm.ads36
-rw-r--r--gcc/ada/tbuild.adb148
-rw-r--r--gcc/ada/tbuild.ads47
-rw-r--r--gcc/ada/tempdir.adb2
-rw-r--r--gcc/ada/tempdir.ads2
-rw-r--r--gcc/ada/terminals.c2
-rw-r--r--gcc/ada/tracebak.c2
-rw-r--r--gcc/ada/treepr.adb1278
-rw-r--r--gcc/ada/treepr.ads5
-rw-r--r--gcc/ada/treeprs.adt107
-rw-r--r--gcc/ada/ttypes.ads4
-rw-r--r--gcc/ada/types.adb2
-rw-r--r--gcc/ada/types.ads81
-rw-r--r--gcc/ada/types.h123
-rw-r--r--gcc/ada/uintp.adb46
-rw-r--r--gcc/ada/uintp.ads16
-rw-r--r--gcc/ada/uintp.h11
-rw-r--r--gcc/ada/uname.adb154
-rw-r--r--gcc/ada/uname.ads2
-rw-r--r--gcc/ada/urealp.adb148
-rw-r--r--gcc/ada/urealp.ads6
-rw-r--r--gcc/ada/urealp.h2
-rw-r--r--gcc/ada/usage.adb32
-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.adb2
-rw-r--r--gcc/ada/vast.ads2
-rw-r--r--gcc/ada/version.c34
-rw-r--r--gcc/ada/warnsw.adb2
-rw-r--r--gcc/ada/warnsw.ads2
-rw-r--r--gcc/ada/widechar.adb2
-rw-r--r--gcc/ada/widechar.ads2
-rw-r--r--gcc/ada/xeinfo.adb551
-rw-r--r--gcc/ada/xnmake.adb467
-rw-r--r--gcc/ada/xoscons.adb2
-rw-r--r--gcc/ada/xr_tabls.adb27
-rw-r--r--gcc/ada/xr_tabls.ads4
-rw-r--r--gcc/ada/xref_lib.adb4
-rw-r--r--gcc/ada/xref_lib.ads2
-rw-r--r--gcc/ada/xsinfo.adb262
-rw-r--r--gcc/ada/xsnamest.adb2
-rw-r--r--gcc/ada/xtreeprs.adb357
-rw-r--r--gcc/ada/xutil.adb2
-rw-r--r--gcc/ada/xutil.ads2
2286 files changed, 65019 insertions, 69725 deletions
diff --git a/gcc/ada/.gitignore b/gcc/ada/.gitignore
new file mode 100644
index 0000000..36a0db0
--- /dev/null
+++ b/gcc/ada/.gitignore
@@ -0,0 +1,2 @@
+# Sphinx build artifacts
+doc/build
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index 2f39282..ff5fc4e 100644
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,7871 @@
+2021-09-08 liuhongt <hongtao.liu@intel.com>
+
+ * gcc-interface/misc.c (gnat_post_options): Issue an error for
+ -fexcess-precision=16.
+
+2021-08-19 Arnaud Charlet <charlet@adacore.com>
+
+ PR ada/101924
+ * gcc-interface/Make-lang.in (STAGE1_LIBS): Define on hpux.
+
+2021-08-18 Eric Botcazou <ebotcazou@gcc.gnu.org>
+
+ * gcc-interface/decl.c (gnat_to_gnu_entity) <discrete_type>: Fix
+ thinko in latest change.
+
+2021-08-11 Bernd Edlinger <bernd.edlinger@hotmail.de>
+
+ PR debug/101598
+ * gcc-interface/trans.c (Subprogram_Body_to_gnu): Set the
+ DECL_SOURCE_LOCATION of DECL_IGNORED_P gnu_subprog_decl to
+ UNKNOWN_LOCATION.
+
+2021-07-25 Arnaud Charlet <charlet@adacore.com>
+
+ * libgnat/s-osprim__x32.adb: Add missing with clause.
+
+2021-07-12 Pierre-Marie de Rodat <derodat@adacore.com>
+
+ * adaint.c (__gnat_number_of_cpus): Replace "#ifdef" by "#if
+ defined".
+
+2021-07-12 Eric Botcazou <ebotcazou@adacore.com>
+
+ * gcc-interface/decl.c (gnat_to_gnu_entity) <discrete_type>: Add a
+ parallel type only when -fgnat-encodings=all is specified.
+ <E_Array_Type>: Use the PAT name and special suffixes only when
+ -fgnat-encodings=all is specified.
+ <E_Array_Subtype>: Build a special type for debugging purposes only
+ when -fgnat-encodings=all is specified. Add a parallel type or use
+ the PAT name only when -fgnat-encodings=all is specified.
+ <E_Record_Type>: Generate debug info for the inner record types only
+ when -fgnat-encodings=all is specified.
+ <E_Record_Subtype>: Use a debug type for an artificial subtype only
+ except when -fgnat-encodings=all is specified.
+ (elaborate_expression_1): Reset need_for_debug when possible only
+ except when -fgnat-encodings=all is specified.
+ (components_to_record): Use XV encodings for variable size only
+ when -fgnat-encodings=all is specified.
+ (associate_original_type_to_packed_array): Add a parallel type only
+ when -fgnat-encodings=all is specified.
+ * gcc-interface/misc.c (gnat_get_array_descr_info): Do not return
+ full information only when -fgnat-encodings=all is specified.
+ * gcc-interface/utils.c (make_packable_type): Add a parallel type
+ only when -fgnat-encodings=all is specified.
+ (maybe_pad_type): Make the inner type a debug type only except when
+ -fgnat-encodings=all is specified. Create an XVS type for variable
+ size only when -fgnat-encodings=all is specified.
+ (rest_of_record_type_compilation): Add a parallel type only when
+ -fgnat-encodings=all is specified.
+
+2021-07-12 Eric Botcazou <ebotcazou@adacore.com>
+
+ * gcc-interface/decl.c (gnat_to_gnu_entity) <E_Array_Type>: Use a
+ fixed lower bound if the index subtype is marked so, as well as a
+ more efficient formula for the upper bound if the array cannot be
+ superflat.
+ (flb_cannot_be_superflat): New predicate.
+ (cannot_be_superflat): Rename into...
+ (range_cannot_be_superfla): ...this. Minor tweak.
+
+2021-07-12 Bob Duff <duff@adacore.com>
+
+ * uintp.ads, types.h: New subtypes of Uint: Valid_Uint, Unat,
+ Upos, Nonzero_Uint with predicates. These correspond to new
+ field types in Gen_IL.
+ * gen_il-types.ads (Valid_Uint, Unat, Upos, Nonzero_Uint): New
+ field types.
+ * einfo-utils.ads, einfo-utils.adb, fe.h (Known_Alignment,
+ Init_Alignment): Use the initial zero value to represent
+ "unknown". This will ensure that if Alignment is called before
+ Set_Alignment, the compiler will blow up (if assertions are
+ enabled).
+ * atree.ads, atree.adb, atree.h, gen_il-gen.adb
+ (Get_Valid_32_Bit_Field): New generic low-level getter for
+ subtypes of Uint.
+ (Copy_Alignment): New procedure to copy Alignment field even
+ when Unknown.
+ (Init_Object_Size_Align, Init_Size_Align): Do not bypass the
+ Init_ procedures.
+ * exp_pakd.adb, freeze.adb, layout.adb, repinfo.adb,
+ sem_util.adb: Protect calls to Alignment with Known_Alignment.
+ Use Copy_Alignment when it might be unknown.
+ * gen_il-gen-gen_entities.adb (Alignment,
+ String_Literal_Length): Use type Unat instead of Uint, to ensure
+ that the field is always Set_ before we get it, and that it is
+ set to a nonnegative value.
+ (Enumeration_Pos): Unat.
+ (Enumeration_Rep): Valid_Uint. Can be negative, but must be
+ valid before fetching.
+ (Discriminant_Number): Upos.
+ (Renaming_Map): Remove.
+ * gen_il-gen-gen_nodes.adb (Char_Literal_Value, Reason): Unat.
+ (Intval, Corresponding_Integer_Value): Valid_Uint.
+ * gen_il-internals.ads: New functions for dealing with special
+ defaults and new subtypes of Uint.
+ * scans.ads: Correct comments.
+ * scn.adb (Post_Scan): Do not set Intval to No_Uint; that is no
+ longer allowed.
+ * sem_ch13.adb (Analyze_Enumeration_Representation_Clause): Do
+ not set Enumeration_Rep to No_Uint; that is no longer allowed.
+ (Offset_Value): Protect calls to Alignment with Known_Alignment.
+ * sem_prag.adb (Set_Atomic_VFA): Do not use Uint_0 to mean
+ "unknown"; call Init_Alignment instead.
+ * sinfo.ads: Minor comment fix.
+ * treepr.adb: Deal with printing of new field types.
+ * einfo.ads, gen_il-fields.ads (Renaming_Map): Remove.
+ * gcc-interface/decl.c (gnat_to_gnu_entity): Use Known_Alignment
+ before calling Alignment. This preserve some probably buggy
+ behavior: if the alignment is not set, it previously defaulted
+ to Uint_0; we now make that explicit. Use Copy_Alignment,
+ because "Set_Alignment (Y, Alignment (X));" no longer works when
+ the Alignment of X has not yet been set.
+ * gcc-interface/trans.c (process_freeze_entity): Use
+ Copy_Alignment.
+
+2021-07-12 Eric Botcazou <ebotcazou@adacore.com>
+
+ * libgnat/s-dwalin.ads: Adjust a few comments left and right.
+ (Line_Info_Register): Comment out unused components.
+ (Line_Info_Header): Add DWARF 5 support.
+ (Dwarf_Context): Likewise. Rename "prologue" into "header".
+ * libgnat/s-dwalin.adb: Alphabetize "with" clauses.
+ (DWARF constants): Add DWARF 5 support and reorder.
+ (For_Each_Row): Adjust.
+ (Initialize_Pass): Likewise.
+ (Initialize_State_Machine): Likewise and fix typo.
+ (Open): Add DWARF 5 support.
+ (Parse_Prologue): Rename into...
+ (Parse_Header): ...this and add DWARF 5 support.
+ (Read_And_Execute_Isn): Rename into...
+ (Read_And_Execute_Insn): ...this and adjust.
+ (To_File_Name): Change parameter name and add DWARF 5 support.
+ (Read_Entry_Format_Array): New procedure.
+ (Skip_Form): Add DWARF 5 support and reorder.
+ (Seek_Abbrev): Do not count entries and add DWARF 5 support.
+ (Debug_Info_Lookup): Add DWARF 5 support.
+ (Symbolic_Address.Set_Result): Likewise.
+ (Symbolic_Address): Adjust.
+
+2021-07-12 Bob Duff <duff@adacore.com>
+
+ * sem_ch13.adb (Duplicate_Clause): Add a helper routine
+ Check_One_Attr, with a parameter for the attribute_designator we
+ are looking for, and one for the attribute_designator of the
+ current node (which are usually the same). For Size and
+ Value_Size, call it twice, once for each.
+ * errout.ads: Fix a typo.
+
+2021-07-12 Piotr Trojanek <trojanek@adacore.com>
+
+ * exp_imgv.adb (Expand_Image_Attribute): Move rewriting to
+ attribute Put_Image to the beginning of expansion of attribute
+ Image.
+
+2021-07-09 Eric Botcazou <ebotcazou@adacore.com>
+
+ * gcc-interface/utils.c (finish_subprog_decl): Remove obsolete line.
+
+2021-07-09 Piotr Trojanek <trojanek@adacore.com>
+
+ * exp_put_image.adb (Make_Put_Image_Name): Fix style.
+ (Image_Should_Call_Put_Image): Likewise.
+ (Build_Image_Call): Likewise.
+
+2021-07-09 Ghjuvan Lacambre <lacambre@adacore.com>
+
+ * par-ch6.adb (Contains_Import_Aspect): New function.
+ (P_Subprogram): Acknowledge `Import` aspects.
+
+2021-07-09 Bob Duff <duff@adacore.com>
+
+ * exp_put_image.adb (Make_Component_Attributes): Use
+ Implementation_Base_Type to get the parent type. Otherwise,
+ Parent_Type_Decl is actually an internally generated subtype
+ declaration, so we blow up on
+ Type_Definition (Parent_Type_Decl).
+
+2021-07-09 Dmitriy Anisimkov <anisimko@adacore.com>
+
+ * gsocket.h: Include net/if.h to get IF_NAMESIZE constant.
+ * s-oscons-tmplt.c: Define IPV6_FLOWINFO for Linux.
+
+2021-07-09 Steve Baird <baird@adacore.com>
+
+ * libgnat/a-cdlili.adb: Reimplement
+ Ada.Containers.Doubly_Linked_Lists.Generic_Sorting.Sort using
+ Mergesort instead of the previous Quicksort variant.
+
+2021-07-09 Justin Squirek <squirek@adacore.com>
+
+ * exp_ch6.adb (Is_Build_In_Place_Function_Call): Add check to
+ verify the Selector_Name of Exp_Node has been analyzed before
+ obtaining its entity.
+
+2021-07-09 Gary Dismukes <dismukes@adacore.com>
+
+ * libgnarl/s-osinte__vxworks.ads: Fix typo ("release" =>
+ "releases") plus comment reformatting.
+ * libgnat/s-os_lib.ads: In a comment, fix typo ("indended" =>
+ "intended"), add a hyphen and semicolon, plus reformatting. In
+ comment for subtype time_t, fix typo ("effect" => "affect"), add
+ hyphens, plus reformatting.
+ * libgnat/s-parame.ads, libgnat/s-parame__ae653.ads,
+ libgnat/s-parame__hpux.ads: Remove period from one-line comment.
+
+2021-07-09 Steve Baird <baird@adacore.com>
+
+ * exp_ch5.adb (Expand_General_Case_Statement): Add new function
+ Else_Statements to handle the case of invalid data analogously
+ to how it is handled when casing on a discrete value.
+ * sem_case.adb (Has_Static_Discriminant_Constraint): A new
+ Boolean-valued function.
+ (Composite_Case_Ops.Scalar_Part_Count): Include discriminants
+ when traversing components.
+ (Composite_Case_Ops.Choice_Analysis.Traverse_Discrete_Parts):
+ Include discriminants when traversing components; the component
+ range for a constrained discriminant is a single value.
+ (Composite_Case_Ops.Choice_Analysis.Parse_Choice): Eliminate
+ Done variable and modify how Next_Part is computed so that it is
+ always correct (as opposed to being incorrect when Done is
+ True). This includes changes in Update_Result (a local
+ procedure). Add new local procedure
+ Update_Result_For_Box_Component and call it not just for box
+ components but also for "missing" components (components
+ associated with an inactive variant).
+ (Check_Choices.Check_Composite_Case_Selector.Check_Component_Subtype):
+ Instead of disallowing all discriminated component types, allow
+ those that are unconstrained or statically constrained. Check
+ discriminant subtypes along with other component subtypes.
+ * doc/gnat_rm/implementation_defined_pragmas.rst: Update
+ documentation to reflect current implementation status.
+ * gnat_rm.texi: Regenerate.
+
+2021-07-09 Justin Squirek <squirek@adacore.com>
+
+ * sem_ch6.adb (Check_Pragma_Inline): Correctly use
+ Corresponding_Spec_Of_Stub when dealing subprogram body stubs.
+
+2021-07-09 Doug Rupp <rupp@adacore.com>
+
+ * Makefile.rtl: Add translations for s-parame__posix2008.ads
+ * libgnarl/s-linux.ads: Import System.Parameters.
+ (time_t): Declare using System.Parameters.time_t_bits.
+ * 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-qnx.ads: Likewise.
+ * libgnarl/s-osinte__aix.ads: Likewise.
+ * libgnarl/s-osinte__android.ads: Likewise.
+ * libgnarl/s-osinte__darwin.ads: Likewise.
+ * libgnarl/s-osinte__dragonfly.ads: Likewise.
+ * libgnarl/s-osinte__freebsd.ads: Likewise.
+ * libgnarl/s-osinte__gnu.ads: Likewise.
+ * libgnarl/s-osinte__hpux-dce.ads: Likewise.
+ * libgnarl/s-osinte__hpux.ads: Likewise.
+ * libgnarl/s-osinte__kfreebsd-gnu.ads: Likewise.
+ * libgnarl/s-osinte__lynxos178e.ads: Likewise.
+ * libgnarl/s-osinte__qnx.ads: Likewise.
+ * libgnarl/s-osinte__rtems.ads: Likewise.
+ * libgnarl/s-osinte__solaris.ads: Likewise.
+ * libgnarl/s-osinte__vxworks.ads: Likewise.
+ * libgnat/g-sothco.ads: Likewise.
+ * libgnat/s-osprim__darwin.adb: Likewise.
+ * libgnat/s-osprim__posix.adb: Likewise.
+ * libgnat/s-osprim__posix2008.adb: Likewise.
+ * libgnat/s-osprim__rtems.adb: Likewise.
+ * libgnat/s-osprim__x32.adb: Likewise.
+ * libgnarl/s-osinte__linux.ads: use type System.Linux.time_t.
+ * libgnat/s-os_lib.ads (time_t): Declare as subtype of
+ Long_Long_Integer.
+ * libgnat/s-parame.ads (time_t_bits): New constant.
+ * libgnat/s-parame__ae653.ads (time_t_bits): Likewise.
+ * libgnat/s-parame__hpux.ads (time_t_bits): Likewise.
+ * libgnat/s-parame__vxworks.ads (time_t_bits): Likewise.
+ * libgnat/s-parame__posix2008.ads: New file for 64 bit time_t.
+
+2021-07-09 Bob Duff <duff@adacore.com>
+
+ * comperr.adb (Compiler_Abort): Print source file name.
+
+2021-07-09 Joffrey Huguet <huguet@adacore.com>
+
+ * libgnat/a-strunb.ads, libgnat/a-strunb__shared.ads: Fix layout
+ in contracts.
+
+2021-07-09 Eric Botcazou <ebotcazou@adacore.com>
+
+ * repinfo.ads (JSON output format): Document adjusted key name.
+ * repinfo.adb (List_Record_Layout): Use Original_Record_Component
+ if the normalized position of the component is not known.
+ (List_Structural_Record_Layout): Rename Outer_Ent parameter into
+ Ext_End and add Ext_Level parameter. In an extension, if the parent
+ subtype has static discriminants, call List_Record_Layout on it.
+ Output "parent_" prefixes before "variant" according to Ext_Level.
+ Adjust recursive calls throughout the procedure.
+
+2021-07-09 Piotr Trojanek <trojanek@adacore.com>
+
+ * exp_util.ads (Map_Types): Fix typo.
+
+2021-07-09 Fedor Rybin <frybin@adacore.com>
+
+ * krunch.adb: Add safeguards against index range violations.
+
+2021-07-09 Arnaud Charlet <charlet@adacore.com>
+
+ * libgnat/a-strfix.adb: Take advantage of extended returns.
+
+2021-07-09 Eric Botcazou <ebotcazou@adacore.com>
+
+ * doc/gnat_rm/implementation_defined_attributes.rst
+ (Scalar_Storage_Order): Add paragraph about representation
+ changes.
+ * gnat_rm.texi: Regenerate.
+
+2021-07-09 Frederic Konrad <konrad@adacore.com>
+
+ * Makefile.rtl (LIBGNAT_TARGET_PAIRS) <aarch64*-*-rtems*>: Use
+ the wraplf variant of Aux_Long_Long_Float.
+
+2021-07-09 Piotr Trojanek <trojanek@adacore.com>
+
+ * sem_ch6.adb (Analyze_Expression_Function): Initialize Orig_N
+ and Typ variables.
+
+2021-07-09 Arnaud Charlet <charlet@adacore.com>
+
+ * sem_ch13.adb (Resolve_Aspect_Expressions): Use the same
+ processing for Predicate, Static_Predicate and
+ Dynamic_Predicate. Do not build the predicate function spec.
+ Update comments.
+ (Resolve_Name): Only reset Entity when necessary to avoid
+ spurious visibility errors.
+ (Check_Aspect_At_End_Of_Declarations): Handle consistently all
+ Predicate aspects.
+ * sem_ch3.adb (Analyze_Subtype_Declaration): Fix handling of
+ private types with predicates.
+
+2021-07-09 Justin Squirek <squirek@adacore.com>
+
+ * sem_util.ads (Type_Access_Level): Add new optional parameter
+ Assoc_Ent.
+ * sem_util.adb (Accessibility_Level): Treat access discriminants
+ the same as components when the restriction
+ No_Dynamic_Accessibility_Checks is enabled.
+ (Deepest_Type_Access_Level): Remove exception for
+ Debug_Flag_Underscore_B when returning the result of
+ Type_Access_Level in the case where
+ No_Dynamic_Accessibility_Checks is active.
+ (Function_Call_Or_Allocator_Level): Correctly calculate the
+ level of Expr based on its containing subprogram instead of
+ using Current_Subprogram.
+ * sem_res.adb (Valid_Conversion): Add actual for new parameter
+ Assoc_Ent in call to Type_Access_Level, and add test of
+ No_Dynamic_Accessibility_Checks_Enabled to ensure that static
+ accessibility checks are performed for all anonymous access type
+ conversions.
+
+2021-07-09 Eric Botcazou <ebotcazou@adacore.com>
+
+ * exp_dbug.ads: Update documentation of various items.
+
+2021-07-09 Piotr Trojanek <trojanek@adacore.com>
+
+ * sem_ch6.adb (Analyze_Expression_Function): Reorder code.
+
+2021-07-09 Piotr Trojanek <trojanek@adacore.com>
+
+ * sem_ch6.adb (Analyze_Expression_Function): Reorder code.
+
+2021-07-09 Piotr Trojanek <trojanek@adacore.com>
+
+ * sem_ch6.adb (Analyze_Expression_Function): Add variable to
+ avoid repeated calls to Etype.
+
+2021-07-09 Piotr Trojanek <trojanek@adacore.com>
+
+ * sem_ch6.adb (Analyze_Expression_Function): Fix comment.
+
+2021-07-09 Piotr Trojanek <trojanek@adacore.com>
+
+ * sem_ch6.adb (Analyze_Expression_Function): Use Orig_N variable
+ instead of repeated calls to Original_Node.
+
+2021-07-09 Piotr Trojanek <trojanek@adacore.com>
+
+ * sem_ch6.adb (Analyze_Expression_Function): Change types local
+ variables from Entity_Id to Node_Id.
+
+2021-07-09 Piotr Trojanek <trojanek@adacore.com>
+
+ * sem_ch6.adb (Analyze_Expression_Function): A local Expr
+ constant was shadowing a global constant with the same name and
+ the same value.
+
+2021-07-09 Piotr Trojanek <trojanek@adacore.com>
+
+ * sem_res.adb (Preanalyze_And_Resolve): Only call
+ Set_Must_Not_Freeze when it is necessary to restore the previous
+ value.
+
+2021-07-08 Piotr Trojanek <trojanek@adacore.com>
+
+ * sem_ch5.adb (Analyze_Assignment): Clear Current_Assignment at
+ exit.
+ (Analyze_Target_Name): Prevent AST climbing from going too far.
+
+2021-07-08 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_ch5.adb (Analyze_Target_Name): Properly reject a
+ Target_Name when it appears outside of an assignment statement,
+ or within the left-hand side of one.
+
+2021-07-08 Bob Duff <duff@adacore.com>
+
+ * einfo-utils.ads, einfo-utils.adb (Unknown_Alignment,
+ Unknown_Component_Bit_Offset, Unknown_Component_Size,
+ Unknown_Esize, Unknown_Normalized_First_Bit,
+ Unknown_Normalized_Position, Unknown_Normalized_Position_Max,
+ Unknown_RM_Size): Remove these functions.
+ * exp_pakd.adb, exp_util.adb, fe.h, freeze.adb, layout.adb,
+ repinfo.adb, sem_ch13.adb, sem_ch3.adb, sem_util.adb: Remove
+ calls to these functions; do "not Known_..." instead.
+ * gcc-interface/decl.c, gcc-interface/trans.c
+ (Unknown_Alignment, Unknown_Component_Size, Unknown_Esize,
+ Unknown_RM_Size): Remove calls to these functions; do
+ "!Known_..." instead.
+
+2021-07-08 Eric Botcazou <ebotcazou@adacore.com>
+
+ * exp_dbug.adb (Get_Encoded_Name): Do not encode names of discrete
+ types with custom bounds, except with -fgnat-encodings=all.
+ * exp_pakd.adb (Create_Packed_Array_Impl_Type): Adjust comment.
+
+2021-07-08 Bob Duff <duff@adacore.com>
+
+ * comperr.adb (Compiler_Abort): Call Sinput.Unlock, because if
+ this is called late, then Source_Dump would crash otherwise.
+ * debug.adb: Correct documentation of the -gnatd.9 switch.
+ * exp_ch4.adb (Expand_Allocator_Expression): Add a comment.
+ * exp_ch6.adb: Minor comment fixes. Add assertion.
+ * exp_ch6.ads (Is_Build_In_Place_Result_Type): Correct comment.
+ * exp_ch7.adb, checks.ads: Minor comment fixes.
+
+2021-07-08 Doug Rupp <rupp@adacore.com>
+
+ * sigtramp-vxworks-target.inc: Rename to...
+ * sigtramp-vxworks-target.h: ... this.
+ * sigtramp-vxworks.c, Makefile.rtl: Likewise.
+
+2021-07-08 Ghjuvan Lacambre <lacambre@adacore.com>
+
+ * lib-writ.ads: Mention SCOs dependency as reason for duplicates.
+ * lib.ads (Units): Update documentation to mention duplicated
+ units.
+
+2021-07-08 Ed Schonberg <schonberg@adacore.com>
+
+ * style.adb (Missing_Overriding): Do not emit message when
+ parent of subprogram is a full type declaration.
+
+2021-07-08 Arnaud Charlet <charlet@adacore.com>
+
+ * par-ch5.adb (P_Iterator_Specification): Add support for access
+ definition in loop parameter.
+ * sem_ch5.adb (Check_Subtype_Indication): Renamed...
+ (Check_Subtype_Definition): ... into this and check for conformance
+ on access definitions, and improve error messages.
+ (Analyze_Iterator_Specification): Add support for access definition
+ in loop parameter.
+
+2021-07-08 Arnaud Charlet <charlet@adacore.com>
+
+ * sem_util.ads, sem_util.adb
+ (Apply_Compile_Time_Constraint_Error): New parameter
+ Emit_Message.
+ * sem_ch4.adb (Analyze_Selected_Component): Disable warning
+ within an instance.
+
+2021-07-08 Eric Botcazou <ebotcazou@adacore.com>
+
+ * exp_imgv.adb: Add with and use clause for Restrict and Rident.
+ (Build_Enumeration_Image_Tables): Do not generate the hash function
+ if the No_Implicit_Loops restriction is active.
+
+2021-07-08 Piotr Trojanek <trojanek@adacore.com>
+
+ * sem_ch12.adb, sem_ch6.adb, sem_ch9.adb, sprint.adb: Simplify
+ checks for non-empty lists.
+
+2021-07-08 Piotr Trojanek <trojanek@adacore.com>
+
+ * par-ch10.adb (Unit_Display): Remove redundant condition; fix
+ whitespace.
+
+2021-07-08 Piotr Trojanek <trojanek@adacore.com>
+
+ * lib-load.adb (Load): Replace early return with goto to properly
+ restore context on failure.
+
+2021-07-08 Piotr Trojanek <trojanek@adacore.com>
+
+ * lib-writ.adb (Ensure_System_Dependency): Simplify condition.
+
+2021-07-08 Piotr Trojanek <trojanek@adacore.com>
+
+ * lib-load.adb (Load_Unit): Fix style in comment.
+ * par-load.adb (Load): Likewise.
+ * scng.adb (Initialize_Scanner): Fix whitespace.
+
+2021-07-08 Piotr Trojanek <trojanek@adacore.com>
+
+ * par-load.adb (Load): Don't remove unit, but flag it as
+ erroneous and return.
+
+2021-07-08 Ghjuvan Lacambre <lacambre@adacore.com>
+
+ * exp_prag.adb (Expand_Pragma_Inspection_Point): Fix error
+ message.
+
+2021-07-08 Yannick Moy <moy@adacore.com>
+
+ * layout.adb (Layout_Type): Do not call Number_Dimensions if the
+ type does not have First_Index set.
+
+2021-07-08 Ghjuvan Lacambre <lacambre@adacore.com>
+
+ * exp_prag.adb (Expand_Pragma_Inspection_Point): After expansion
+ of the Inspection_Point pragma, check if referenced entities
+ that have a freeze node are already frozen. If they aren't, emit
+ a warning and turn the pragma into a no-op.
+
+2021-07-08 Yannick Moy <moy@adacore.com>
+
+ * layout.adb (Layout_Type): Add guard before calling Expr_Value.
+
+2021-07-08 Yannick Moy <moy@adacore.com>
+
+ * layout.adb (Layout_Type): Special case when RM_Size and Esize
+ can be computed for packed arrays.
+
+2021-07-08 Steve Baird <baird@adacore.com>
+
+ * rtsfind.ads, rtsfind.adb: Add support for finding the packages
+ System.Atomic_Operations and
+ System.Atomic_Operations.Test_And_Set and the declarations
+ within that latter package of the type Test_And_Set_Flag and the
+ function Atomic_Test_And_Set.
+ * exp_ch11.adb (Expand_N_Exception_Declaration): If an exception
+ is declared other than at library level, then we need to call
+ Register_Exception the first time (and only the first time) the
+ declaration is elaborated. In order to decide whether to
+ perform this call for a given elaboration of the declaration, we
+ used to unconditionally use a (library-level) Boolean variable.
+ Now we instead use a variable of type
+ System.Atomic_Operations.Test_And_Set.Test_And_Set_Flag unless
+ either that type is unavailable or a No_Tasking restriction is
+ in effect (in which case we use a Boolean variable as before).
+
+2021-07-08 Arnaud Charlet <charlet@adacore.com>
+
+ * gcc-interface/system.ads: Add No_Tasking restriction.
+
+2021-07-08 Ed Schonberg <schonberg@adacore.com>
+
+ * libgnat/a-cohama.ads: Introduce an equality operator over
+ cursors.
+ * libgnat/a-cohase.ads: Ditto.
+ * libgnat/a-cohama.adb: Add body for "=" over cursors.
+ (Insert): Do not set the Position component of the cursor that
+ denotes the inserted element.
+ * libgnat/a-cohase.adb: Ditto.
+
+2021-07-08 Arnaud Charlet <charlet@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-cobove.adb, libgnat/a-textio.adb,
+ libgnat/a-witeio.adb, libgnat/a-ztexio.adb: Make code compatible
+ with No_Dynamic_Accessibility_Checks restriction.
+
+2021-07-08 Arnaud Charlet <charlet@adacore.com>
+
+ * debug.adb, sem_util.adb: Revert meaning of -gnatd_b.
+ * sem_res.adb: Minor reformatting.
+
+2021-07-08 Arnaud Charlet <charlet@adacore.com>
+
+ * make.adb, osint.adb: Make code compatible with
+ No_Dynamic_Accessibility_Checks restriction.
+
+2021-07-08 Piotr Trojanek <trojanek@adacore.com>
+
+ * lib-writ.adb (Ensure_System_Dependency): Replace search in
+ Lib.Units with a search in Lib.Unit_Names.
+
+2021-07-08 Piotr Trojanek <trojanek@adacore.com>
+
+ * sinput-l.adb (Load_File): Simplify foreword manipulation with
+ concatenation; similar for filename with preprocessed output.
+
+2021-07-07 Dmitriy Anisimkov <anisimko@adacore.com>
+
+ * s-oscons-tmplt.c (MSG_WAITALL): Remove wrong #ifdef
+ __MINWGW32__.
+
+2021-07-07 Gary Dismukes <dismukes@adacore.com>
+
+ * einfo-utils.adb (Primitive_Operations): Default to returning
+ Direct_Primitive_Operations in the case of concurrent types
+ (when Corresponding_Record_Type not present).
+ * sem_ch9.adb (Analyze_Protected_Type_Declaration): Initialize
+ Direct_Primitive_Operations to an empty element list.
+ (Analyze_Task_Type_Declaration): Initialize
+ Direct_Primitive_Operations to an empty element list.
+
+2021-07-07 Piotr Trojanek <trojanek@adacore.com>
+
+ * sem_eval.adb (Set_Checking_Potentially_Static_Expression):
+ Stronger assertion.
+
+2021-07-07 Arnaud Charlet <charlet@adacore.com>
+
+ * sem_ch12.adb (Analyze_Subprogram_Instantiation): Mark Anon_Id
+ intrinsic before calling Analyze_Instance_And_Renamings because
+ this flag may be propagated to other nodes.
+
+2021-07-07 Dmitriy Anisimkov <anisimko@adacore.com>
+
+ * s-oscons-tmplt.c (TCP_KEEPCNT TCP_KEEPIDLE, TCP_KEEPINTVL):
+ Hardcode on Windows if undefined.
+
+2021-07-07 Bob Duff <duff@adacore.com>
+
+ * checks.adb (Install_Primitive_Elaboration_Check): Do not
+ generate elaboration checks for primitives if pragma Pure or
+ Preelaborate is present. Misc comment fixes, including
+ referring to the correct kind of check (elaboration, not
+ accessibility).
+ * checks.ads, restrict.adb, sem_cat.ads, sinfo.ads: Minor
+ reformatting and comment fixes.
+
+2021-07-07 Piotr Trojanek <trojanek@adacore.com>
+
+ * sem_prag.adb (Analyze_Pragma): Simplify processing of pragma
+ CPP_Constructor.
+
+2021-07-07 Arnaud Charlet <charlet@adacore.com>
+
+ * libgnat/g-debpoo.adb (Code_Address_For_Allocate_End): Default
+ Initialize.
+
+2021-07-07 Arnaud Charlet <charlet@adacore.com>
+
+ * libgnat/s-atocou.ads, libgnat/s-atocou__builtin.adb: Code
+ cleanups.
+
+2021-07-07 Gary Dismukes <dismukes@adacore.com>
+
+ * freeze.adb (Check_Inherited_Conditions): Setting of Ekind,
+ LSP_Subprogram, and Is_Wrapper needs to happen for null
+ procedures as well as other wrapper cases, so the code is moved
+ from the else part in front of the if statement. (Fixes a
+ latent bug encountered while working on this set of changes.)
+ * sem_attr.adb (Resolve_Attribute): Report an error for the case
+ of an Access attribute applied to a primitive of an abstract
+ type when the primitive has any nonstatic Pre'Class or
+ Post'Class expressions.
+ * sem_ch8.adb (Analyze_Subprogram_Renaming): Report an error for
+ the case of a actual subprogram associated with a nonabstract
+ formal subprogram when the actual is a primitive of an abstract
+ type and the primitive has any nonstatic Pre'Class or Post'Class
+ expressions.
+ * sem_disp.adb (Check_Dispatching_Context): Remove special
+ testing for null procedures, and replace it with a relaxed test
+ that avoids getting an error about illegal calls to abstract
+ subprograms in cases where RM 6.1.1(7/5) applies in
+ Pre/Post'Class aspects. Also, remove special test for
+ Postcondition, which seems to be unnecessary, update associated
+ comments, and fix a typo in one comment.
+ (Check_Dispatching_Call): Remove an unneeded return statement,
+ and report an error for the case of a nondispatching call to a
+ nonabstract subprogram of an abstract type where the subprogram
+ has nonstatic Pre/Post'Class aspects.
+ * sem_util.ads
+ (Is_Prim_Of_Abst_Type_With_Nonstatic_CW_Pre_Post): New function.
+ (In_Pre_Post_Condition): Add a flag formal Class_Wide_Only,
+ defaulted to False, for indicating whether the function should
+ only test for the node being within class-wide pre- and
+ postconditions.
+ * sem_util.adb
+ (Is_Prim_Of_Abst_Type_With_Nonstatic_CW_Pre_Post): New function
+ to determine whether a subprogram is a primitive of an abstract
+ type where the primitive has class-wide Pre/Post'Class aspects
+ specified with nonstatic expressions.
+ (In_Pre_Post_Condition): Extend testing to account for the new
+ formal Class_Wide_Only.
+
+2021-07-07 Piotr Trojanek <trojanek@adacore.com>
+
+ * sem_ch12.adb (Check_Shared_Variable_Control_Aspects): Errors
+ emitted via Check_Volatility_Compatibility are now emitted at
+ Actual, just like other errors emitted by
+ Check_Shared_Variable_Control_Aspects.
+
+2021-07-07 Piotr Trojanek <trojanek@adacore.com>
+
+ * uname.adb (Get_Unit_Name): Simplify with a bounded string
+ buffer; also, this addresses a ??? comment about the max length
+ being exceeded.
+
+2021-07-07 Piotr Trojanek <trojanek@adacore.com>
+
+ * uname.adb (Get_Body_Name, Get_Parent_Body_Name,
+ Get_Parent_Spec_Name, Get_Spec_Name, Is_Child_Name,
+ Is_Body_Name, Is_Spec_Name, Name_To_Unit_Name): Use a local
+ instead of the global buffer.
+
+2021-07-07 Bob Duff <duff@adacore.com>
+
+ * sem_ch13.adb (Analyze_Attribute_Definition_Clause): Combine
+ processing of Size and Value_Size clauses. Ensure that
+ Value_Size is treated the same as Size, in the cases where both
+ are allowed (i.e. the prefix denotes a first subtype). Misc
+ cleanup.
+ * einfo-utils.adb (Init_Size): Add assertions.
+ (Size_Clause): Return a Value_Size clause if present, instead of
+ just looking for a Size clause.
+ * einfo.ads (Has_Size_Clause, Size_Clause): Change documentation
+ to include Value_Size.
+ * sem_ch13.ads, layout.ads, layout.adb: Comment modifications.
+
+2021-07-07 Steve Baird <baird@adacore.com>
+
+ * exp_dist.adb (Add_RACW_Primitive_Declarations_And_Bodies): Add
+ TSS_Put_Image to list of predefined primitives that need special
+ treatment.
+ (Build_General_Calling_Stubs, Build_Subprogram_Receiving_Stubs):
+ Remove previous hack for dealing with TSS_Put_Image procedures.
+
+2021-07-07 Dmitriy Anisimkov <anisimko@adacore.com>
+
+ * libgnat/g-socket.adb (Get_Socket_Option): Add 500ms only when
+ Minus_500ms_Windows_Timeout is True.
+ (Set_Socket_Option): Use "* 1000" instead of "/ 0.001" to
+ convert to milliseconds.
+
+2021-07-07 Bob Duff <duff@adacore.com>
+
+ * tbuild.adb (Unchecked_Convert_To): Set the Parent of the new
+ node to the Parent of the old node.
+ * tbuild.ads (Unchecked_Convert_To): Document differences
+ between Convert_To and Unchecked_Convert_To. The previous
+ documentation claimed they are identical except for the
+ uncheckedness of the conversion.
+
+2021-07-07 Yannick Moy <moy@adacore.com>
+
+ * checks.adb (Apply_Scalar_Range_Check): Remove special case for
+ GNATprove mode.
+ * sem_res.adb (Resolve_Arithmetic_Op): Same.
+ * sem_util.adb (Apply_Compile_Time_Constraint_Error): Same.
+
+2021-07-07 Piotr Trojanek <trojanek@adacore.com>
+
+ * sem_ch6.adb (Check_For_Primitive_Subprogram): Move
+ declarations of local variables after nested subprogram bodies.
+
+2021-07-07 Piotr Trojanek <trojanek@adacore.com>
+
+ * exp_disp.adb (CPP_Num_Prims): Reuse List_Length.
+
+2021-07-07 Piotr Trojanek <trojanek@adacore.com>
+
+ * exp_ch3.adb, exp_ch6.adb, sem_ch6.adb: Replace Ekind
+ membership test in Private_Kind with a call to Is_Private_Type.
+
+2021-07-07 Bob Duff <duff@adacore.com>
+
+ * gen_il-gen-gen_entities.adb: Remove Linker_Section_Pragma
+ field from Record_Field_Kind. Minor comment improvement.
+
+2021-07-07 Yannick Moy <moy@adacore.com>
+
+ * libgnat/a-ngelfu.ads (Cot): Fix precondition.
+
+2021-07-07 Piotr Trojanek <trojanek@adacore.com>
+
+ * par.adb (Par): A local Name variable is now a renaming of a
+ constant slice.
+
+2021-07-07 Piotr Trojanek <trojanek@adacore.com>
+
+ * gnat1drv.adb (Gnat1drv): Remove flagging of main unit and its
+ corresponding spec as requiring code generation; now the flags
+ are set much earlier.
+ * lib-load.adb (Load_Main_Source): Set Generate_Code flag on the
+ main unit source.
+ (Make_Instance_Unit): Copy Generate_Code flag from the main unit
+ to instance units.
+ * lib-writ.adb (Write_ALI): Remove redundant condition;
+ Generate_Code flag is always set for the main unit.
+ * par-load.adb (Load): Set Generate_Code flag on the main unit's
+ corresponding spec, if any.
+
+2021-07-07 Dmitriy Anisimkov <anisimko@adacore.com>
+
+ * libgnat/g-socket.ads (Option_Name): Add Keep_Alive_Count,
+ Keep_Alive_Idle, and Keep_Alive_Interval items to enumeration.
+ (Option_Type): Add Keep_Alive_Count, Keep_Alive_Idle, and
+ Keep_Alive_Interval alternatives to the case of discriminated
+ record.
+ * libgnat/g-socket.adb (Options): Add Keep_Alive_Count,
+ Keep_Alive_Idle, and Keep_Alive_Interval to items enumerator to
+ OS constant converter.
+ (Set_Socket_Option): Process Keep_Alive_Count, Keep_Alive_Idle,
+ and Keep_Alive_Interval socket options.
+ (Get_Socket_Option): Idem.
+
+2021-07-07 Piotr Trojanek <trojanek@adacore.com>
+
+ * lib-writ.adb (Write_ALI): Exit from loop after seeing first
+ unit that violates No_Elaboration_Code restriction.
+
+2021-07-07 Piotr Trojanek <trojanek@adacore.com>
+
+ * inline.adb (Instantiate_Bodies): Fix white in declaration.
+ (Remove_Dead_Instance): Change iteration from WHILE to FOR.
+
+2021-07-07 Bob Duff <duff@adacore.com>
+
+ * checks.adb, exp_attr.adb, exp_ch4.adb, exp_ch6.adb,
+ exp_ch9.adb, exp_disp.adb, exp_util.adb, inline.adb,
+ sem_res.adb: Change all calls to Make_Unchecked_Type_Conversion
+ to call Unchecked_Convert_To instead. This involves removing
+ New_Occurrence_Of on the first parameter, because
+ Unchecked_Convert_To expects a type entity, rather than the name
+ of one. Also, removed calls to Relocate_Node, because
+ Unchecked_Convert_To takes care of that.
+ * sinfo.ads: Change comment to be worded more firmly.
+
+2021-07-07 Steve Baird <baird@adacore.com>
+
+ * libgnarl/s-tassta.adb (Free_Task): Acquire the Task_Lock
+ before, rather than after, querying the task's Terminated flag.
+ Add a corresponding Task_Unlock call.
+
+2021-07-06 Bob Duff <duff@adacore.com>
+
+ * atree.ads (Current_Error_Node): Initialize to Empty.
+
+2021-07-06 Steve Baird <baird@adacore.com>
+
+ * exp_put_image.adb: Eliminate references to
+ Debug_Flag_Underscore_Z. Change the meaning of the function
+ Enable_Put_Image. Previously, a result of False for a tagged
+ type would mean that the type does not get a Put_Image (PI)
+ routine at all. Now, it means that the type gets a PI routine
+ with very abbreviated functionality (just a call to
+ Unknown_Put_Image). This resolves problems in mixing code
+ compiled with and without the -gnat2022 switch.
+ * exp_ch3.adb: Enable_Put_Image no longer participates in
+ determining whether a tagged type gets a Put_Image procedure. A
+ tagged type does not get a Put_Image procedure if the type
+ Root_Buffer_Type is unavailable. This is needed to support cross
+ targets where tagged types are supported but the type
+ Root_Buffer_Type is not available.
+ * exp_dist.adb: Add workarounds for some problems that arise
+ when using the (obsolete?) Garlic implementation of the
+ distributed systems annex with Ada 2022 constructs.
+ * libgnat/a-sttebu.ads: Workaround a bootstrapping problem.
+ Older compilers do not support raise expressions, so revise the
+ the Pre'Class condition to meet this requirement without
+ changing the condition's behavior at run time.
+
+2021-07-06 Eric Botcazou <ebotcazou@adacore.com>
+
+ * repinfo-input.adb (JSON_Entity_Kind, Read_Variant_Part): Fix
+ typo in comment.
+
+2021-07-06 Steve Baird <baird@adacore.com>
+
+ * sem_ch5.adb (Analyze_Assignment): Add new nested function,
+ Omit_Range_Check_For_Streaming, and make call to
+ Apply_Scalar_Range_Check conditional on the result of this new
+ function.
+ * exp_attr.adb (Compile_Stream_Body_In_Scope): Eliminate Check
+ parameter, update callers. The new
+ Omit_Range_Check_For_Streaming parameter takes the place of the
+ old use of calling Insert_Action with Suppress => All_Checks,
+ which was insufficiently precise (it did not allow suppressing
+ checks for one component but not for another).
+ (Expand_N_Attribute_Reference): Eliminate another "Suppress =>
+ All_Checks" from an Insert_Action call, this one in generating
+ the expansion of a T'Read attribute reference for a composite
+ type T.
+
+2021-07-06 Ghjuvan Lacambre <lacambre@adacore.com>
+
+ * sem_ch5.adb (Analyze_Loop_Parameter_Specification): Check for
+ empty loops caused by constraints.
+
+2021-07-06 Nicolas Roche <roche@adacore.com>
+
+ * rtinit.c (skip_quoted_string): Handle malformed command line
+ with no closing double quote.
+ (skip_argument): Handle case in which a null character is
+ encountered by skip_quote_string.
+
+2021-07-06 Piotr Trojanek <trojanek@adacore.com>
+
+ * uname.adb (Add_Node_Name): Replace local constant whose
+ initial expression was evaluated even when unnecessary with just
+ that expression that is evaluated at most once and only when
+ needed.
+
+2021-07-06 Piotr Trojanek <trojanek@adacore.com>
+
+ * lib.adb (Remove_Unit): Replace defensive code with an
+ assertion.
+ * par-load.adb (Load): Address a question mark in the comment.
+
+2021-07-06 Piotr Trojanek <trojanek@adacore.com>
+
+ * sem_util.adb (Enclosing_Comp_Unit_Node): When the loop exits
+ the Current_Node is either an N_Compilation_Unit node or Empty,
+ so simply return it without redundant checks.
+
+2021-07-06 Piotr Trojanek <trojanek@adacore.com>
+
+ * lib-load.adb (Load_Unit): Remove excessive whitespace.
+ * lib.adb (Is_Internal_Unit, Is_Predefined_Unit): Likewise.
+ * par-ch10.adb (P_Compilation_Unit): Simplify with membership
+ test.
+ * par-load.adb (Load): Likewise.
+ * uname.adb (Get_Unit_Name): Likewise.
+
+2021-07-06 Piotr Trojanek <trojanek@adacore.com>
+
+ * lib-writ.adb (Ensure_System_Dependency): Simplify by reusing a
+ constant name.
+
+2021-07-06 Steve Baird <baird@adacore.com>
+
+ * exp_ch5.adb
+ (Expand_N_Case_Statement.Expand_General_Case_Statement.Pattern_Match):
+ When generating an equality test for a statically known discrete
+ value, only generate the numeric value if the discrete type is
+ not an enumeration type. If it is an enumeration type, then
+ call Get_Enum_Lit_From_Pos instead.
+
+2021-07-06 Justin Squirek <squirek@adacore.com>
+
+ * par-ch6.adb (Get_Return_Kind): Removed.
+ (Is_Extended): Created to identify simple and "when" return
+ statements from extended return statements.
+ (P_Return_Statement): Merged simple and "when" return statement
+ processing.
+
+2021-07-06 Gary Dismukes <dismukes@adacore.com>
+
+ * sem_ch4.adb (Try_One_Prefix_Interpretation): Augment test of
+ "not Extensions_Allowed" with test for absence of Obj_Type's
+ primitive operations Elist, as an additional condition for early
+ return from this procedure.
+
+2021-07-06 Gary Dismukes <dismukes@adacore.com>
+
+ * exp_ch4.adb (Process_Transient_In_Expression): In one comment,
+ fix two typos and reorder wording of one sentence, plus minor
+ reformatting.
+
+2021-07-06 Justin Squirek <squirek@adacore.com>
+
+ * exp_ch5.adb (Expand_Formal_Container_Element_Loop): Remove
+ legacy expansion of element iterators, and use expansion form
+ used by unconstrained element types in the general case.
+
+2021-07-06 Ed Schonberg <schonberg@adacore.com>
+
+ * exp_ch4.adb (Process_Transient_In_Expression): Ensure that
+ Fin_Context, used to insert finalization code for the
+ expression, is a list member: the value returned by
+ Find_Hook_Context may be an expression node when the transient
+ is part of a larger expression and it has a non-boolean type.
+
+2021-07-06 Yannick Moy <moy@adacore.com>
+
+ * sem_case.adb: Fix error message.
+
+2021-07-06 Bob Duff <duff@adacore.com>
+
+ * tbuild.adb (Convert_To): Add assert, along with a comment.
+ (Make_DT_Access): Remove this function, which is not used. It
+ was incorrect anyway (the call to New_Occurrence_Of should not
+ be there).
+ (Unchecked_Convert_To): Add assert. The previous version's test
+ for unchecked conversion to the same type was redundant and
+ could never be true, because the previous 'if' already checked
+ for ANY expression of the same type. Remove that, and replace
+ with a test for unchecked conversion to a related type.
+ Otherwise, we somethings get things like
+ "finalize(some_type!(some_type!(x)))" in the generated code,
+ where x is already of type some_type, but we're converting it to
+ the private type and then to the full type or vice versa (so the
+ types aren't equal, so the previous 'if' doesn't catch it).
+ Avoid updating the Parent. This is not necessary; the Parent
+ will be updated if/when the node is attached to the tree.
+ * tbuild.ads: Fix comments. No need to say "this is safe" when
+ we just explained that a few lines earlier. Remove
+ Make_DT_Access.
+ * sinfo.ads: Add comments.
+ * exp_ch7.adb (Make_Finalize_Address_Stmts): Minor comment fix.
+ * gen_il-gen.adb, gen_il-gen.ads, gen_il-gen-gen_nodes.adb,
+ gen_il-internals.ads: Implement a feature where you can put:
+ Nmake_Assert => "expr" where expr is a boolean expression in a
+ call to Create_Concrete_Node_Type. It is added in a pragma
+ Assert in the Nmake.Make_... function for that type.
+
+2021-07-06 Gary Dismukes <dismukes@adacore.com>
+
+ * checks.adb: Remove calls of Set_Do_Tag_Check (N, False).
+ * einfo.ads: Remove hanging unneeded ??? comment ("this real description
+ was clobbered").
+ * exp_util.ads (Insert_Actions_After): Remove ??? from spec comment.
+ * gen_il-fields.ads (Opt_Field_Enum): Remove literals
+ Do_Accessibility_Check and Do_Tag_Check.
+ * gen_il-gen-gen_nodes.adb: Remove all calls to Sm for
+ Do_Accessibility_Check and Do_Tag_Check.
+ * sem_type.ads (Is_Subtype_Of): Remove obsolete ???
+ comment (function is not limited to scalar subtypes).
+ * sem_util.ads (Is_Local_Variable_Reference): Revise comment to
+ mention out-mode parameters as well, and remove ???.
+ (Propagate_Concurrent_Flags): Minor reformatting.
+ (Propagate_Invariant_Attributes): Typo fix.
+ (Propagate_Predicate_Attributes): Indicate what is propagated
+ and remove ??? comment.
+ * sem_util.adb (Cannot_Raise_Constraint_Error): Remove unneeded
+ test of Do_Tag_Check.
+ (Is_Local_Variable_Reference): Extend function to testing for
+ formals of mode out as well.
+ * sinfo.ads: Remove ??? comment about flag
+ Convert_To_Return_False indicating that the flag is obsolete (in
+ fact it's used). Remove references to Do_Accessibility_Check and
+ Do_Tag_Check (and the two associated ??? comments), as these
+ flags are unneeded.
+ * sinfo-cn.adb (Change_Conversion_To_Unchecked): Remove call of
+ Set_Do_Tag_Check (N, False).
+ * targparm.ads (Support_Atomic_Primitives_On_Target): Remove ???
+ comment, plus minor reformatting.
+
+2021-07-06 Justin Squirek <squirek@adacore.com>
+
+ * par-ch6.adb (Get_Return_Kind): Properly handle the case of a
+ "return when" statement in the procedure case.
+
+2021-07-06 Bob Duff <duff@adacore.com>
+
+ * sem.ads (Node_To_Be_Wrapped): Minor comment fix.
+ * exp_ch7.adb (Establish_Transient_Scope): Misc cleanups and
+ comment improvements.
+ (Set_Node_To_Be_Wrapped): Remove -- not worth putting this code
+ in a separate procedure, called only once.
+ * sem_util.adb (Requires_Transient_Scope): Assert that our
+ parameter has the right Kind. It probably shouldn't be E_Void,
+ but that is passed in in some cases.
+ (Ensure_Minimum_Decoration): Move the call later, so we know Typ
+ is Present, and remove "if Present (Typ)" from this procedure.
+ * exp_aggr.adb (Convert_To_Assignments): Use membership test,
+ and avoid the "if False" idiom.
+ (Expand_Array_Aggregate): Remove a ??? comment.
+ * sem_ch8.adb (Push_Scope): Take advantage of the full coverage
+ rules for aggregates.
+ * sem_res.adb (Resolve_Declare_Expression): Remove test for
+ Is_Type -- that's all it can be. Use named notation in call to
+ Establish_Transient_Scope.
+ * libgnat/a-cdlili.adb (Adjust): Remove redundant code.
+ (Clear): Remove "pragma Warnings (Off);", which wasn't actually
+ suppressing any warnings.
+
+2021-07-06 Bob Duff <duff@adacore.com>
+
+ * gen_il-gen-gen_nodes.adb: Change the parent of
+ N_Exception_Declaration to be N_Declaration. Minor comment fix.
+
+2021-07-06 Ed Schonberg <schonberg@adacore.com>
+
+ * exp_ch4.adb (Expand_N_Type_Conversion): If the conversion is
+ the name of an assignment operation do not apply predicate check
+ to it prior to the assignment.
+
+2021-07-06 Bob Duff <duff@adacore.com>
+
+ * libgnat/a-conhel.adb: Assert that tampering counts remain
+ between 0 and 2**31-1. This makes debugging of
+ finalization-related bugs easier.
+
+2021-07-06 Doug Rupp <rupp@adacore.com>
+
+ * Makefile.rtl (LIBGNAT_TARGET_PAIRS): Use s-osprim__posix.adb
+ vice s-osprim__vxworks.adb for all vxworks7r2 targets.
+
+2021-07-06 Richard Kenner <kenner@adacore.com>
+
+ * gen_il-types.ads (Void_Or_Type_Kind,
+ Exception_Or_Object_Kind): Declare.
+ * gen_il-gen-gen_entities.adb: Likewise.
+
+2021-07-06 Gary Dismukes <dismukes@adacore.com>
+
+ * doc/gnat_rm/implementation_defined_pragmas.rst: Add a
+ description of the feature of prefixed-view calls for untagged
+ types to the section on pragma Extensions_Allowed.
+ * gnat_rm.texi: Regenerate.
+ * einfo.ads: Update specification for
+ Direct_Primitive_Operations to reflect its use for untagged
+ types when Extensions_Allowed is True.
+ * gen_il-gen-gen_entities.adb: Allow Direct_Primitive_Operations
+ as a field of untagged classes of types by removing the "Pre"
+ test of "Is_Tagged_Type (N)", and making that field generally
+ available for all types and subtypes by defining it for
+ Type_Kind and removing its specification for individual classes
+ of types.
+ * sem_ch3.adb (Analyze_Full_Type_Declaration): Initialize the
+ Direct_Primitive_Operations list when not already set for the
+ new (sub)type and its base type (except when Ekind of the type
+ is E_Void, which can happen due to errors in cases where
+ Derived_Type_Declaration is called and perhaps in other
+ situations).
+ (Analyze_Subtype_Declaration): Inherit
+ Direct_Primitive_Operations list from the base type, for record
+ and private cases.
+ (Build_Derived_Record_Type): Initialize the
+ Direct_Primitive_Operations list for derived record and private
+ types.
+ (Build_Derived_Type): Initialize the Direct_Primitive_Operations
+ list for derived types (and also for their associated base types
+ when needed).
+ (Process_Full_View): For full types that are untagged record and
+ private types, copy the primitive operations of the partial view
+ to the primitives list of the full view.
+ * sem_ch4.adb (Analyze_Selected_Component): Allow prefixed
+ notation for subprogram calls in the case of untagged
+ types (when Extensions_Allowed is True). In the case where
+ Is_Private_Type (Prefix_Type) is True, call Try_Object_Operation
+ when a discriminant selector wasn't found. Also call
+ Try_Object_Operation in other type kind cases (when
+ Extensions_Allowed is True).
+ (Try_Object_Operation.Try_One_Prefixed_Interpretation): Prevent
+ early return in the untagged case (when Extensions_Allowed is
+ True). Condition main call to Try_Primitive_Operation on the
+ type having primitives, and after that, if Prim_Result is False,
+ test for case where the prefix type is a named access type with
+ primitive operations and in that case call
+ Try_Primitive_Operation after temporarily resetting Obj_Type to
+ denote the access type (and restore it to the designated type
+ after the call)
+ (Try_Object_Operation.Valid_First_Argument_Of): Do matching type
+ comparison by testing Base_Type (Obj_Type) against
+ Base_Type (Typ), rather than against just Typ, to properly
+ handle cases where the object prefix has a constrained
+ subtype. (Fixes a bug discovered while working on this
+ feature.)
+ * sem_ch6.adb
+ (New_Overloaded_Entity.Check_For_Primitive_Subprogram): Add a
+ primitive of an untagged type to the type's list of primitive
+ operations, for both explicit and implicit (derived, so
+ Comes_From_Source is False) subprogram declarations. In the case
+ where the new primitive overrides an inherited subprogram,
+ locate the primitives Elist that references the overridden
+ subprogram, and replace that element of the list with the new
+ subprogram (done by calling the new procedure
+ Add_Or_Replace_Untagged_Primitive on the result type and each
+ formal atype).
+ (Check_For_Primitive_Subprogram.Add_Or_Replace_Untagged_Primitive):
+ New nested procedure to either add or replace an untagged
+ primitive subprogram in a given type's list of primitive
+ operations (replacement happens in case where the new subprogram
+ overrides a primitive of the type).
+ * sem_ch7.adb (New_Private_Type): When Extensions_Allowed is
+ True, initialize the Direct_Primitive_Operations list of a
+ private type to New_Elmt_List in the case of untagged types.
+ * sem_ch8.adb (Find_Selected_Component): In the case where the
+ prefix is an entity name, relax condition that tests
+ Has_Components so that Analyze_Selected_Component will also be
+ called when Extensions_Allowed is True and the prefix type is
+ any type.
+
+2021-07-06 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_ch6.adb (Analyze_Subprogram_Body_Helper): Do not perform
+ conformance check when the subprogram body has been created for
+ an expression function that is not a completion of a previous
+ specification, because the profile of the constructed body is
+ copied from the expression function itself.
+
+2021-07-06 Steve Baird <baird@adacore.com>
+
+ * doc/gnat_rm/implementation_of_specific_ada_features.rst: Add a
+ warning indicating that the details of the default (i.e.,
+ selected by the compiler) implementation of T'Put_Image for a
+ nonscalar type T are subject to change.
+ * gnat_rm.texi: Regenerate.
+
+2021-07-05 Pierre-Marie de Rodat <derodat@adacore.com>
+
+ * gnat-style.texi, gnat_rm.texi, gnat_ugn.texi: Regenerate.
+
+2021-07-05 Piotr Trojanek <trojanek@adacore.com>
+
+ * sem_prag.adb (Analyze_Depends_In_Decl_Part): Reject overlays
+ in Depends and Refined_Depends contracts.
+ (Analyze_Global_In_Decl_Part): Likewise for Global and
+ Refined_Global.
+ (Analyze_Initializes_In_Decl_Part): Likewise for Initializes
+ (when appearing both as a single item and as a initialization
+ clause).
+ * sem_util.ads (Ultimate_Overlaid_Entity): New routine.
+ * sem_util.adb (Report_Unused_Body_States): Ignore overlays.
+ (Ultimate_Overlaid_Entity): New routine.
+
+2021-07-05 Claire Dross <dross@adacore.com>
+
+ * libgnat/a-cfdlli.ads, libgnat/a-cfdlli.adb
+ libgnat/a-cfinve.ads, libgnat/a-cfinve.adb,
+ libgnat/a-cofove.ads, libgnat/a-cofove.adb,
+ libgnat/a-coboho.ads, libgnat/a-coboho.adb (Constant_Reference):
+ Get a read-only access to an element of the container.
+ (At_End): Ghost functions used to express pledges in the
+ postcondition of Reference.
+ (Reference): Get a read-write access to an element of the
+ container.
+ * libgnat/a-cfhama.ads, libgnat/a-cfhama.adb,
+ libgnat/a-cforma.ads, libgnat/a-cforma.adb: The full view of the
+ Map type is no longer a tagged type, but a wrapper over this
+ tagged type. This is to avoid issues with dispatching result in
+ At_End functions.
+ (Constant_Reference): Get a read-only access to an element of
+ the container.
+ (At_End): Ghost functions used to express pledges in the
+ postcondition of Reference.
+ (Reference): Get a read-write access to an element of the
+ container.
+ * libgnat/a-cfhase.ads, libgnat/a-cfhase.adb,
+ libgnat/a-cforse.ads, libgnat/a-cforse.adb: The full view of the
+ Map type is no longer a tagged type, but a wrapper over this
+ tagged type.
+ (Constant_Reference): Get a read-only access to an element of
+ the container.
+ * libgnat/a-cofuse.ads, libgnat/a-cofuve.ads (Copy_Element):
+ Expression function used to cause SPARK to make sure
+ Element_Type is copiable.
+ * libgnat/a-cofuma.ads (Copy_Key): Expression function used to
+ cause SPARK to make sure Key_Type is copiable.
+ (Copy_Element): Expression function used to cause SPARK to make
+ sure Element_Type is copiable.
+
+2021-07-05 Yannick Moy <moy@adacore.com>
+
+ * sem_prag.adb (Analyze_Global_Item): Adapt to update SPARK RM
+ rule.
+
+2021-07-05 Arnaud Charlet <charlet@adacore.com>
+
+ * Make-generated.in: Add -f switch to ensure cp will never fail.
+
+2021-07-05 Steve Baird <baird@adacore.com>
+
+ * exp_ch3.adb (Build_Record_Init_Proc.Build_Assignment): When
+ building the assignment statement corresponding to the default
+ expression for a component, we make a copy of the expression.
+ When making that copy (and if we have seen a component that
+ requires late initialization), pass a Map parameter into the
+ call to New_Copy_Tree to redirect references to the type to
+ instead refer to the _Init formal parameter of the init proc.
+ This includes hoisting the declaration of Has_Late_Init_Comp out
+ one level so that it becomes available to Build_Assignment.
+ (Find_Current_Instance): Return True for other kinds of current
+ instance references, instead of just access-valued attribute
+ references such as T'Access.
+ * sem_util.adb (Is_Aliased_View): Return True for the _Init
+ formal parameter of an init procedure. The changes in
+ exp_ch3.adb can have the effect of replacing a "T'Access"
+ attribute reference in an init procedure with an "_Init'Access"
+ attribute reference. We want such an attribute reference to be
+ legal. However, we do not simply mark the formal parameter as
+ being aliased because that might impact callers.
+ (Is_Object_Image): Return True if Is_Current_Instance returns
+ True for the prefix of an Image (or related attribute) attribute
+ reference.
+
+2021-07-05 Piotr Trojanek <trojanek@adacore.com>
+
+ * exp_ch3.adb (Stream_Operation_OK): Reuse
+ Is_Concurrent_Interface.
+ * sem_ch3.adb (Analyze_Interface_Declaration,
+ Build_Derived_Record_Type): Likewise.
+ * sem_ch6.adb (Check_Limited_Return): Likewise.
+ * sem_util.adb (Is_Concurrent_Interface): Don't call
+ Is_Interface because each of the Is_Protected_Interface,
+ Is_Synchronized_Interface and Is_Task_Interface calls it anyway.
+
+2021-07-05 Ghjuvan Lacambre <lacambre@adacore.com>
+
+ * sem_ch6.adb (Check_Limited_Return): Replace Comes_From_Source
+ with Comes_From_Extended_Return_Statement.
+
+2021-07-05 Steve Baird <baird@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: Delete files.
+ * Makefile.rtl, impunit.adb: Remove references to deleted files.
+
+2021-07-05 Piotr Trojanek <trojanek@adacore.com>
+
+ * sem_util.adb (Has_Compatible_Alignment_Internal): If the
+ prefix of the Address expression is an entire object with a
+ known alignment, then skip checks related to its size.
+
+2021-07-05 Doug Rupp <rupp@adacore.com>
+
+ * libgnat/s-os_lib.ads: Import OS_Time comparison ops as
+ intrinsic.
+ * libgnat/s-os_lib.adb: Remove OS_TIme comparison ops
+ implementation.
+
+2021-07-05 Doug Rupp <rupp@adacore.com>
+
+ * libgnat/s-os_lib.ads: Add some comments about time_t.
+ * libgnat/s-os_lib.adb (GM_Split/To_GM_Time): Rename formal to
+ P_OS_Time.
+ (GM_Time_Of/To_OS_Time): Likewise.
+
+2021-07-05 Ghjuvan Lacambre <lacambre@adacore.com>
+
+ * sem_res.adb (Resolve): Insert minus sign if needed.
+
+2021-07-05 Steve Baird <baird@adacore.com>
+
+ * exp_put_image.adb:
+ (Enable_Put_Image, Preload_Root_Buffer_Type): Revert to querying
+ the -gnatd_z switch, as opposed to testing whether Ada_Version >= Ada_2022.
+
+2021-07-05 Justin Squirek <squirek@adacore.com>
+
+ * checks.adb (Accessibility_Checks_Suppressed): Add check
+ against restriction No_Dynamic_Accessibility_Checks.
+ (Apply_Accessibility_Check): Add assertion to check restriction
+ No_Dynamic_Accessibility_Checks is not active.
+ * debug.adb: Add documentation for new debugging switch to
+ control which accessibility model gets employed under
+ restriction No_Dynamic_Accessibility_Checks.
+ * exp_attr.adb (Expand_N_Attribute_Reference): Disable dynamic
+ accessibility check generation when
+ No_Dynamic_Accessibility_Checks is active.
+ * exp_ch4.adb (Apply_Accessibility_Check): Skip check generation
+ when restriction No_Dynamic_Accessibility_Checks is active.
+ (Expand_N_Allocator): Disable dynamic accessibility checks when
+ No_Dynamic_Accessibility_Checks is active.
+ (Expand_N_In): Disable dynamic accessibility checks when
+ No_Dynamic_Accessibility_Checks is active.
+ (Expand_N_Type_Conversion): Disable dynamic accessibility checks
+ when No_Dynamic_Accessibility_Checks is active.
+ * exp_ch5.adb (Expand_N_Assignment_Statement): Disable
+ alternative accessibility model calculations when computing a
+ dynamic level for a SAOAAT.
+ * exp_ch6.adb (Add_Call_By_Copy_Code): Disable dynamic
+ accessibility check generation when
+ No_Dynamic_Accessibility_Checks is active.
+ (Expand_Branch): Disable alternative accessibility model
+ calculations.
+ (Expand_Call_Helper): Disable alternative accessibility model
+ calculations.
+ * restrict.adb, restrict.ads: Add new restriction
+ No_Dynamic_Accessibility_Checks.
+ (No_Dynamic_Accessibility_Checks_Enabled): Created to test when
+ experimental features (which are generally incompatible with
+ standard Ada) can be enabled.
+ * sem_attr.adb (Safe_Value_Conversions): Add handling of new
+ accessibility model under the restriction
+ No_Dynamic_Accessibility_Checks.
+ * sem_prag.adb (Process_Restrictions_Or_Restriction_Warnings):
+ Disallow new restriction No_Dynamic_Accessibility_Checks from
+ being exclusively specified within a body or subunit without
+ being present in a specification.
+ * sem_res.adb (Check_Fully_Declared_Prefix): Minor comment
+ fixup.
+ (Valid_Conversion): Omit implicit conversion checks on anonymous
+ access types and perform static checking instead when
+ No_Dynamic_Accessibility_Checks is active.
+ * sem_util.adb, sem_util.ads (Accessibility_Level): Add special
+ handling of anonymous access objects, formal parameters,
+ anonymous access components, and function return objects.
+ (Deepest_Type_Access_Level): When
+ No_Dynamic_Accessibility_Checks is active employ an alternative
+ model. Add paramter Allow_Alt_Model to override the new behavior
+ in certain cases.
+ (Type_Access_Level): When No_Dynamic_Accessibility_Checks is
+ active employ an alternative model. Add parameter
+ Allow_Alt_Model to override the new behavior in certain cases.
+ (Typ_Access_Level): Created within Accessibility_Level for
+ convenience.
+ * libgnat/s-rident.ads, snames.ads-tmpl: Add handing for
+ No_Dynamic_Accessibility_Checks.
+
+2021-07-05 Doug Rupp <rupp@adacore.com>
+
+ * adaint.h (__gnat_set_file_time_name): Use OS_Time.
+ * adaint.c (__gnat_set_file_time_name): Likewise.
+
+2021-07-05 Doug Rupp <rupp@adacore.com>
+
+ * adaint.h (OS_Time): typedef as long long.
+ * osint.adb (Underlying_OS_Time): Declare as 64-bit signed type.
+ * libgnat/s-os_lib.adb ("<"): Compare OS_Time as
+ Long_Long_Integer.
+ ("<="): Likewise.
+ (">"): Likewise.
+ (">="): Likewise.
+ * libgnat/s-os_lib.ads (OS_Time): Declare as 64-bit signed type.
+
+2021-07-05 Ghjuvan Lacambre <lacambre@adacore.com>
+
+ * sem_ch3.adb (Check_Abstract_Overriding): Post error message on
+ renaming node.
+
+2021-07-05 Yannick Moy <moy@adacore.com>
+
+ * libgnat/a-uncdea.ads: Add Depends/Post to
+ Ada.Unchecked_Deallocation.
+ * sem_ch4.adb (Analyze_Allocator): Remove checking of allocator
+ placement.
+ * sem_res.adb (Flag_Object): Same.
+
+2021-07-05 Ghjuvan Lacambre <lacambre@adacore.com>
+
+ * aspects.ads: Add GNAT_Annotate aspect.
+ * gnat1drv.adb (Adjust_Global_Switches): Stop defining
+ Name_Gnat_Annotate as an alias of Name_Annotate.
+ * snames.ads-tmpl: Define Gnat_Annotate.
+ * par-prag.adb, sem_prag.ads: Add Pragma_Gnat_Annotate to list
+ of pragmas.
+ * lib-writ.adb, sem_ch13.adb, sem_prag.adb: Handle Gnat_Annotate
+ like Aspect_Annotate.
+
+2021-07-05 Piotr Trojanek <trojanek@adacore.com>
+
+ * ttypes.ads (Target_Strict_Alignment): Fix comment.
+
+2021-07-05 Piotr Trojanek <trojanek@adacore.com>
+
+ * sem_util.adb (Has_Compatible_Alignment_Internal): Fix
+ indentation of ELSIF comments; remove explicit calls to
+ UI_To_Int; remove extra parens around the MOD operand.
+
+2021-07-05 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_aggr.adb (Resolve_Record_Aggregate, Step_5): Do not check
+ for the need to use an extension aggregate for a given component
+ when within an instance and the type of the component hss a
+ private ancestor: the instantiation is legal if the generic
+ compiles, and spurious errors may be generated otherwise.
+
+2021-07-05 Ghjuvan Lacambre <lacambre@adacore.com>
+
+ * errout.adb (Output_JSON_Message): Recursively call
+ Output_JSON_Message for continuation messages instead of
+ appending their content to the initial message.
+
+2021-07-05 Steve Baird <baird@adacore.com>
+
+ * debug.adb: Remove comments about -gnatd_z switch.
+ * exp_ch3.adb (Make_Predefined_Primitive_Specs): A one-line fix
+ for a subtle bug that took some effort to debug. Append a new
+ Put_Image procedure for a type extension even if it seems to
+ already have one, just as is done for (for example) the
+ streaming-related Read procedure.
+ * exp_put_image.adb:
+ (Build_Record_Put_Image_Procedure.Make_Component_Attributes): Do
+ not treat _Parent component like just another component, for two
+ reasons. 1. If the _parent component's type has a
+ user-specified Put_Image procedure, then we want to generate a
+ call to that procedure and then generate extension aggregate
+ syntax. 2. Otherwise, we still don't want to see any mention of
+ "_parent" in the generated image text.
+ (Build_Record_Put_Image_Procedure.Make_Component_Name): Add
+ assertion that we are not generating a reference to an "_parent"
+ component.
+ (Build_Record_Put_Image_Procedure): Add special treatment for
+ null records. Add call to Duplicate_Subexpr for image attribute
+ prefix in order to help with expansion needed in the class-wide
+ case (where the prefix is also referenced in the call to
+ Wide_Wide_Expanded_Name) if evaluation of the prefix has side
+ effects. Add new local helper function, Put_String_Exp. Add
+ support for case where prefix type is class-wide.
+ (Enable_Put_Image, Preload_Root_Buffer_Type): Query Ada_Version
+ > Ada_2022 instead of (indirectly) querying -gnatd_z switch.
+ * freeze.adb (In_Expanded_Body): A one-line change to add
+ TSS_Put_Image to the list of subprograms that have
+ expander-created bodies.
+ * rtsfind.ads: Add support for accessing
+ Ada.Tags.Wide_Wide_Expanded_Name.
+ * sem_ch3.ads, sem_ch3.adb: Delete Is_Null_Extension function,
+ as part of moving it to Sem_Util.
+ * sem_ch13.adb
+ (Analyze_Put_Image_TSS_Definition.Has_Good_Profile): Improve
+ diagnostic messages in cases where the result is going to be
+ False and the Report parameter is True. Relax overly-restrictive
+ checks in order to implement mode conformance.
+ (Analyze_Stream_TSS_Definition.Has_Good_Profile): Add similar
+ relaxation of parameter subtype checking for the Stream
+ parameter of user-defined streaming subprograms.
+ * sem_disp.adb (Check_Dispatching_Operation): A one-line
+ change (and an accompanying comment change) to add TSS_Put_Image
+ to the list of compiler-generated dispatching primitive
+ operations.
+ * sem_util.ads, sem_util.adb: Add Ignore_Privacy Boolean
+ parameter to Is_Null_Record_Type function (typically the
+ parameter will be False when the function is being used in the
+ implementation of static semantics and True for dynamic
+ semantics; the parameter might make a difference in the case of,
+ for example, a private type that is implemented as a null record
+ type). Add related new routines Is_Null_Extension (formerly
+ declared in Sem_Ch3), Is_Null_Extension_Of, and
+ Is_Null_Record_Definition.
+
+2021-07-05 Justin Squirek <squirek@adacore.com>
+
+ * freeze.adb (Freeze_Profile): Use N's Sloc, F_type's chars.
+
+2021-07-05 Bob Duff <duff@adacore.com>
+
+ * checks.adb, exp_aggr.adb, exp_ch5.adb, freeze.adb,
+ sem_util.adb, sem_util.ads: Change L and H to be First and Last,
+ to match the attributes in the RM. Change calls from procedure
+ to function where appropriate.
+
+2021-07-05 Bob Duff <duff@adacore.com>
+
+ * sem_util.ads, sem_util.adb (Compute_Returns_By_Ref): New
+ procedure to compute Returns_By_Ref, to avoid some code
+ duplication. This will likely change soon, so it's good to have
+ the code in one place.
+ (CW_Or_Has_Controlled_Part): Move here from Exp_Ch7, because
+ it's called by Compute_Returns_By_Ref, and this is a better
+ place for it anyway.
+ (Needs_Finalization): Fix comment to be vague instead of wrong.
+ * exp_ch6.adb (Expand_N_Subprogram_Body, Freeze_Subprogram):
+ Call Compute_Returns_By_Ref.
+ * sem_ch6.adb (Check_Delayed_Subprogram): Call
+ Compute_Returns_By_Ref.
+ * exp_ch7.ads, exp_ch7.adb (CW_Or_Has_Controlled_Part): Move to
+ Sem_Util.
+ (Has_New_Controlled_Component): Remove unused function.
+
+2021-07-05 Ghjuvan Lacambre <lacambre@adacore.com>
+
+ * sem_ch3.adb (Check_Abstract_Overriding): Check for renamings.
+
+2021-07-05 Boris Yakobowski <yakobowski@adacore.com>
+
+ * exp_ch4.adb (Expand_N_Op_Rem): Remove special case for rem -1
+ in CodePeer_Mode.
+
+2021-07-01 Eric Botcazou <ebotcazou@adacore.com>
+
+ PR ada/101094
+ * exp_attr.adb (Get_Integer_Type): Return an integer type with the
+ same signedness as the input type.
+
+2021-06-29 Richard Kenner <kenner@adacore.com>
+
+ * sem_util.adb (Visit_Node): Add handling for N_Block_Statement
+ with declarations.
+
+2021-06-29 Piotr Trojanek <trojanek@adacore.com>
+
+ * einfo-utils.adb
+ (Unknown_Alignment): Simply negate the Known_ counterpart.
+ (Unknown_Component_Bit_Offset): Likewise.
+ (Unknown_Esize): Likewise.
+ (Unknown_Normalized_First_Bit): Likewise.
+ (Unknown_Normalized_Position): Likewise.
+ (Unknown_Normalized_Position_Max): Likewise.
+ (Unknown_RM_Size): Likewise.
+
+2021-06-29 Boris Yakobowski <yakobowski@adacore.com>
+
+ * exp_ch4.adb (Expand_N_Op_Mod): Remove special case for mod -1
+ in CodePeer_Mode.
+
+2021-06-29 Aleksandra Pasek <pasek@adacore.com>
+
+ * libgnat/s-objrea.adb (EM_AARCH64): New Constant.
+ (Initialize): Handle EM_AARCH64 case.
+ (Read_Address): Handle AARCH64 case.
+ * libgnat/s-objrea.ads (Object_Arch): Add AARCH64 record
+ component.
+
+2021-06-29 Bob Duff <duff@adacore.com>
+
+ * sem_ch13.adb (Analyze_Record_Representation_Clause): Call
+ Set_Entity_With_Checks instead of Set_Entity, so we perform the
+ check for correct casing.
+ * style.adb (Check_Identifier): Minor comment improvement.
+ Cleanup overly complicated code.
+
+2021-06-29 Ed Schonberg <schonberg@adacore.com>
+
+ * exp_aggr.adb (Convert_Aggr_In_Object_Decl): After expansion of
+ the aggregate, the expression can be removed from the
+ declaration, except if the object is class-wide, in which case
+ the aggregate provides the actual type. In other cases the
+ presence of the expression may lead to spurious freezing issue.
+ * exp_ch3.adb (Expand_N_Object_Declaration): If the expression
+ in the declaration is an aggregate with delayed expansion (as is
+ the case for objects of a limited type, or a subsequent address
+ specification) the aggregate must be resolved at this point.
+ This resolution must not include expansion, because the
+ expansion of the enclosing declaration will construct the
+ necessary aggregate expansion.
+
+2021-06-29 Piotr Trojanek <trojanek@adacore.com>
+
+ * errout.ads (Adjust_Name_Case): Remove obsolete and now unused
+ variant.
+ * errout.adb (Adjust_Name_Case): Likewise; fix variant that uses
+ a custom buffer to also use it for names in Standard_Location.
+
+2021-06-29 Eric Botcazou <ebotcazou@adacore.com>
+
+ * sem_ch12.adb (Freeze_Subprogram_Body): Add missing "freeze".
+ (Install_Body): Likewise.
+
+2021-06-29 Piotr Trojanek <trojanek@adacore.com>
+
+ * adaint.c (__gnat_portable_spawn): Revert change that
+ introduced setting of __gnat_in_child_after_fork.
+
+2021-06-29 Patrick Bernardi <bernardi@adacore.com>
+
+ * libgnarl/s-tasdeb.ads (Known_Tasks): Add Atomic_Components
+ aspect.
+
+2021-06-29 Doug Rupp <rupp@adacore.com>
+
+ * Makefile.rtl (x86_64-vx7r2) [EXTRA_GNATRTL_TASKING_OBJS]: Move
+ i-vxinco.o out of RTP runtime.
+
+2021-06-29 Claire Dross <dross@adacore.com>
+
+ * libgnat/a-cfdlli.ads: Use pragma Assertion_Policy to disable
+ pre and postconditions.
+ * libgnat/a-cfhama.ads: Likewise.
+ * libgnat/a-cfhase.ads: Likewise.
+ * libgnat/a-cfinve.ads: Likewise.
+ * libgnat/a-cforma.ads: Likewise.
+ * libgnat/a-cforse.ads: Likewise.
+ * libgnat/a-cofove.ads: Likewise.
+
+2021-06-29 Piotr Trojanek <trojanek@adacore.com>
+
+ * sem_util.ads (Get_Fullest_View): Refill comment; remove extra
+ extra after period.
+ * sem_util.adb (Get_Fullest_View): Fix style.
+
+2021-06-29 Piotr Trojanek <trojanek@adacore.com>
+
+ * sem_ch3.adb (Analyze_Declarations): Remove explicit check for
+ missing, because a subsequent call to Is_Empty_List will detect
+ them anyway.
+
+2021-06-29 Piotr Trojanek <trojanek@adacore.com>
+
+ * freeze.adb (Freeze_All): Simplify by reusing
+ Is_Subprogram_Or_Entry.
+ * sem_ch11.adb (Analyze_Handled_Statement): Likewise.
+
+2021-06-29 Piotr Trojanek <trojanek@adacore.com>
+
+ * sem_warn.adb (Warn_On_Overlapping_Actuals): Prevent cascaded
+ errors once for the subprogram call, not for every pair of
+ actual parameters.
+
+2021-06-29 Piotr Trojanek <trojanek@adacore.com>
+
+ * sem_ch3.adb (Is_Local_Type): Simplify by reusing Scope_Within.
+
+2021-06-29 Gary Dismukes <dismukes@adacore.com>
+
+ * sem_ch6.ads (Can_Override_Operator): Function declaration
+ moved from package body to package spec.
+ * sem_ch6.adb (Check_Overriding_Indicator): Now use test of
+ whether the subprogram's Chars is an operator name, to handle
+ cases of function instances whose entity is
+ N_Defining_Identifier rather than N_Defining_Operator_Symbol.
+ (Can_Override_Operator): Function declaration moved to package
+ spec. Now use test of whether the subprogram's Chars is an
+ operator name, to handle cases of function instances whose
+ entity is N_Defining_Identifier rather than
+ N_Defining_Operator_Symbol.
+ * sem_ch8.adb (Analyze_Renamed_Subprogram): Check for
+ possibility of an overridden predefined operator, and suppress
+ the "not overriding" message in that case.
+
+2021-06-29 Doug Rupp <rupp@adacore.com>
+
+ * Makefile.rtl: Add a new ifeq for vx7r2 shared gnatlib.
+
+2021-06-29 Piotr Trojanek <trojanek@adacore.com>
+
+ * exp_attr.adb (Build_Array_VS_Func): Restore uses of
+ Validated_View.
+ (Build_Record_VS_Func): Likewise.
+ (Expand_N_Attribute_Reference): Likewise.
+ * sem_util.adb (Validated_View): Behave as an identity function
+ for arrays and scalars.
+
+2021-06-29 Bob Duff <duff@adacore.com>
+
+ * atree.adb, atree.ads (Parent, Set_Parent): Assert node is
+ Present.
+ (Copy_Parent, Parent_Kind): New helper routines.
+ * gen_il-gen.adb: Add with clause.
+ * nlists.adb (Parent): Assert Parent of list is Present.
+ * aspects.adb, checks.adb, exp_aggr.adb, exp_ch6.adb,
+ exp_util.adb, lib-xref-spark_specific.adb, osint.ads,
+ sem_ch12.adb, sem_ch13.adb, sem_ch3.adb, sem_ch6.adb,
+ sem_dim.adb, sem_prag.adb, sem_res.adb, sem_util.adb,
+ treepr.adb: Do not call Parent and Set_Parent on the Empty node.
+ * libgnat/a-stwiun__shared.adb, libgnat/a-stzunb__shared.adb:
+ Minor: Fix typos in comments.
+ * einfo.ads: Minor comment update.
+ * sinfo-utils.ads, sinfo-utils.adb (Parent_Kind, Copy_Parent):
+ New functions.
+
+2021-06-29 Eric Botcazou <ebotcazou@adacore.com>
+
+ * repinfo-input.adb (Read_JSON_Stream): Fix typo.
+
+2021-06-29 Eric Botcazou <ebotcazou@adacore.com>
+
+ * rtsfind.ads (RE_Id): Change RE_Valid_Enumeration_Value_NN into
+ RE_Valid_Value_Enumeration_NN.
+ (RE_Unit_Table): Adjust to above renaming.
+ * exp_imgv.adb (Expand_Valid_Value_Attribute): Likewise.
+ * libgnat/s-valuen.ads (Invalid): Remove.
+ (Value_Enumeration_Pos): Move to...
+ * libgnat/s-valuen.adb (Value_Enumeration_Pos): ...here.
+ Return -1 instead of Invalid.
+ (Value_Enumeration): Compare against 0 instead of Invalid.
+ (Valid_Enumeration_Value): Likewise. Rename to...
+ (Valid_Value_Enumeration): ...this.
+ * libgnat/s-vaenu8.ads (Valid_Enumeration_Value_8): Rename into...
+ (Valid_Value_Enumeration_8): ...this.
+ * libgnat/s-vaen16.ads (Valid_Enumeration_Value_16): Rename into...
+ (Valid_Value_Enumeration_16): ...this.
+ * libgnat/s-vaen32.ads (Valid_Enumeration_Value_32): Rename into...
+ (Valid_Value_Enumeration_32): ...this.
+
+2021-06-29 Bob Duff <duff@adacore.com>
+
+ * einfo.ads (Component_Bit_Offset, Component_Size): Update
+ documentation: Repinfo is the package where these negative
+ values are documented.
+ * einfo-utils.adb (Known_Component_Size,
+ Known_Static_Component_Size, Unknown_Component_Size): Remove
+ calls to Implementation_Base_Type, because Component_Size is an
+ Impl_Base_Type_Only field (see Gen_Entities).
+ * sem_ch13.ads, sem_ch13.adb (Check_Size): Do not set Esize and
+ RM_Size. This is unnecessary in the case of Size. For
+ Component_Size, it is wrong, because we would be setting the
+ Esize and RM_Size of the component type.
+
+2021-06-29 Pascal Obry <obry@adacore.com>
+
+ * s-oscons-tmplt.c: Add some OS constants.
+
+2021-06-29 Piotr Trojanek <trojanek@adacore.com>
+
+ * sem_util.ads (Validated_View): Fix style in comment.
+ * sem_util.adb (Validated_View): Rewrite in recursive style.
+
+2021-06-29 Eric Botcazou <ebotcazou@adacore.com>
+
+ * Make-generated.in (ada/stamp-gen_il): Ignore errors from
+ running gen_il-main.
+
+2021-06-29 Richard Kenner <kenner@adacore.com>
+
+ * gen_il-gen-gen_entities.adb (Record_Field_Kind,
+ Allocatable_Kind): Add new abstract kinds.
+ (Constant_Or_Variable_Kind): Likewise.
+ (E_Constant, E_Variable, E_Loop_Parameter): Use them.
+ (E_Discriminant, E_Component): Likewise.
+ * gen_il-types.ads (type Opt_Type_Enum): Add them.
+
+2021-06-29 Bob Duff <duff@adacore.com>
+
+ * gen_il-gen.adb (Put_C_Type_And_Subtypes): Put the correct
+ numbers.
+ * gen_il-internals.ads, gen_il-internals.adb: (Pos): Remove this
+ function. It was assuming that the order of the enumeration
+ literals in Type_Enum is the same as the order of the generated
+ types Node_Kind and Entity_Kind, which is not true.
+
+2021-06-29 Piotr Trojanek <trojanek@adacore.com>
+
+ * exp_attr.adb (Expand_N_Attribute_Reference): Explicitly use
+ Validated_View for record objects.
+
+2021-06-28 Martin Sebor <msebor@redhat.com>
+
+ * gcc-interface/trans.c (Handled_Sequence_Of_Statements_to_gnu):
+ Replace TREE_NO_WARNING with suppress_warning.
+ (gnat_gimplify_expr): Same.
+ * gcc-interface/utils.c (gnat_pushdecl): Same.
+
+2021-06-21 Gary Dismukes <dismukes@adacore.com>
+
+ * checks.adb (Selected_Range_Checks): In the case of a
+ qualified_expression where the qualifying subtype is an
+ unconstrained array subtype with fixed lower bounds for some of
+ its indexes, generate tests to check that those bounds are equal
+ to the corresponding lower bounds of the qualified array object.
+
+2021-06-21 Bob Duff <duff@adacore.com>
+
+ * libgnat/s-valuen.ads (Value_Enumeration,
+ Valid_Enumeration_Value): Inline.
+ (Value_Enumeration_Pos): Add Pure_Function.
+
+2021-06-21 Justin Squirek <squirek@adacore.com>
+
+ * doc/gnat_rm/implementation_defined_pragmas.rst: Document new
+ feature under pragma Extensions_Allowed.
+ * gnat_rm.texi: Regenerate.
+ * errout.adb, errout.ads (Error_Msg_GNAT_Extension): Created to
+ issue errors when parsing extension only constructs.
+ * exp_ch11.adb, exp_ch11.ads (Expand_N_Raise_When_Statement):
+ Created to expand raise ... when constucts.
+ * exp_ch5.adb, exp_ch5.ads (Expand_N_Goto_When_Statement):
+ Created to expand goto ... when constructs.
+ * exp_ch6.adb, exp_ch6.ads (Expand_N_Return_When_Statement):
+ Created to expand return ... when constructs.
+ * expander.adb (Expand): Add case entries for "when" constructs.
+ * gen_il-gen-gen_nodes.adb, gen_il-types.ads: Add entries for
+ "when" constructs.
+ * par-ch11.adb (P_Raise_Statement): Add processing for raise ...
+ when.
+ * par-ch5.adb (Missing_Semicolon_On_Exit): Renamed to
+ Missing_Semicolon_On_When and moved to par-util.adb.
+ * par-ch6.adb (Get_Return_Kind): Renamed from Is_Simple and
+ processing added for "return ... when" return kind.
+ (Is_Simple): Renamed to Get_Return_Kind.
+ (P_Return_Statement): Add case for return ... when variant of
+ return statement.
+ * par-util.adb, par.adb (Missing_Semicolon_On_When): Added to
+ centeralize parsing of "when" keywords in the context of "when"
+ constructs.
+ * sem.adb (Analyze): Add case for "when" constructs.
+ * sem_ch11.adb, sem_ch11.ads (Analyze_Raise_When_Statement):
+ Created to analyze raise ... when constructs.
+ * sem_ch5.adb, sem_ch5.ads (Analyzed_Goto_When_Statement):
+ Created to analyze goto ... when constructs.
+ * sem_ch6.adb, sem_ch6.ads (Analyze_Return_When_Statement):
+ Created to analyze return ... when constructs.
+ * sprint.adb (Sprint_Node_Actual): Add entries for new "when"
+ nodes.
+
+2021-06-21 Steve Baird <baird@adacore.com>
+
+ * Make-generated.in (GEN_IL_FLAGS): Keep only GNAT flags.
+ (ada/stamp-gen_il): Remove dependencies on libgnat/ sources. Do not
+ copy libgnat/ sources locally and tidy up.
+ * Makefile.rtl: Include object files for new Text_Buffer units
+ in the GNATRTL_NONTASKING_OBJS list.
+ * exp_put_image.ads, exp_put_image.adb: Update Rtsfind calls to
+ match new specs. For example, calls to RE_Sink are replaced with
+ calls to RE_Root_Buffer_Type. Update comments and change
+ subprogram names accordingly (e.g., Preload_Sink is changed to
+ Preload_Root_Buffer_Type).
+ * impunit.adb: Add 6 new predefined units (Text_Buffers and 5
+ child units thereof).
+ * rtsfind.ads, rtsfind.adb: Add interfaces for accessing the
+ Ada.Strings.Text_Buffers package and declarations
+ therein (including the Unbounded child unit). Do not (yet)
+ delete interfaces for accessing the old Text_Output package.
+ * sem_attr.adb (Check_Put_Image_Attribute): Replace RE_Sink uses
+ with RE_Root_Buffer_Type and update comments accordingly.
+ * sem_ch10.adb (Analyze_Compilation_Unit): Update call to
+ reflect name change of callee (that is, the former Preload_Sink
+ is now Preload_Root_Buffer_Type).
+ * sem_ch13.adb (Has_Good_Profile): Replace RE_Sink use with
+ RE_Root_Buffer_Type.
+ (Build_Spec): Update comment describing a parameter type.
+ * gen_il.ads: Remove clauses for the old Text_Output package and
+ add them for Ada.Streams.Stream_IO.
+ (Sink): Declare.
+ (Create_File): Likewise.
+ (Increase_Indent): Likewise.
+ (Decrease_Indent): Likewise.
+ (Put): Likewise.
+ (LF): Likewise.
+ * gen_il.adb: Add clauses for Ada.Streams.Stream_IO.
+ (Create_File): New procedure.
+ (Increase_Indent): Likewise.
+ (Decrease_Indent): Likewise.
+ (Put): New procedures.
+ * gen_il-gen.adb: Add clauses for Ada.Text_IO. Replace
+ Sink'Class with Sink throughout. Use string concatenation and
+ LF marker instead of formatted strings and "\n" marker. Update
+ Indent/Outdent calls to use new Increase_Indent/Decrease_Indent
+ names.
+ (Put_Membership_Query_Decl): Remove.
+ * gen_il-internals.ads: Replace Sink'Class with Sink throughout.
+ (Ptypes): Remove.
+ (Pfields): Likewise.
+ * gen_il-internals.adb: Remove clauses for GNAT.OS_Lib and
+ Ada.Strings.Text_Buffers.Files. Replace Sink'Class with Sink
+ throughout. Use string concatenation and LF marker instead of
+ formatted strings and "\n" marker.
+ (Stdout): Remove.
+ (Ptypes): Likewise.
+ (Pfields): Likewise.
+ * libgnarl/s-putaim.ads: Modify context clause, update
+ declaration of subtype Sink to refer to
+ Text_Buffers.Root_Buffer_Type instead of the old
+ Text_Output.Sink type.
+ * libgnarl/s-putaim.adb: Modify context clause and add use
+ clause to refer to Text_Buffers package.
+ * libgnat/a-cbdlli.ads, libgnat/a-cbdlli.adb,
+ libgnat/a-cbhama.ads, libgnat/a-cbhama.adb,
+ libgnat/a-cbhase.ads, libgnat/a-cbhase.adb,
+ libgnat/a-cbmutr.ads, libgnat/a-cbmutr.adb,
+ libgnat/a-cborma.ads, libgnat/a-cborma.adb,
+ libgnat/a-cborse.ads, libgnat/a-cborse.adb,
+ libgnat/a-cdlili.ads, libgnat/a-cdlili.adb,
+ libgnat/a-cidlli.ads, libgnat/a-cidlli.adb,
+ libgnat/a-cihama.ads, libgnat/a-cihama.adb,
+ libgnat/a-cihase.ads, libgnat/a-cihase.adb,
+ libgnat/a-cimutr.ads, libgnat/a-cimutr.adb,
+ libgnat/a-ciorma.ads, libgnat/a-ciorma.adb,
+ libgnat/a-ciormu.ads, libgnat/a-ciormu.adb,
+ libgnat/a-ciorse.ads, libgnat/a-ciorse.adb,
+ libgnat/a-coboho.ads, libgnat/a-coboho.adb,
+ libgnat/a-cobove.ads, libgnat/a-cobove.adb,
+ libgnat/a-cohama.ads, libgnat/a-cohama.adb,
+ libgnat/a-cohase.ads, libgnat/a-cohase.adb,
+ libgnat/a-coinho.ads, libgnat/a-coinho.adb,
+ libgnat/a-coinho__shared.ads, libgnat/a-coinho__shared.adb,
+ libgnat/a-coinve.ads, libgnat/a-coinve.adb,
+ libgnat/a-comutr.ads, libgnat/a-comutr.adb,
+ libgnat/a-convec.ads, libgnat/a-convec.adb,
+ libgnat/a-coorma.ads, libgnat/a-coorma.adb,
+ libgnat/a-coormu.ads, libgnat/a-coormu.adb,
+ libgnat/a-coorse.ads, libgnat/a-coorse.adb,
+ libgnat/a-nbnbin.ads, libgnat/a-nbnbin.adb,
+ libgnat/a-nbnbin__gmp.adb, libgnat/a-nbnbre.ads,
+ libgnat/a-nbnbre.adb, libgnat/a-strunb.ads,
+ libgnat/a-strunb.adb, libgnat/a-strunb__shared.ads,
+ libgnat/a-strunb__shared.adb, libgnat/s-rannum.ads,
+ libgnat/s-rannum.adb: Modify Put_Image procedure used in
+ Put_Image aspect specification to conform to Ada profile
+ rules (in particular, the first parameter shall be of type
+ Ada.Strings.Text_Buffers.Root_Buffer_Type'Class).
+ * libgnat/a-sttebu.ads, libgnat/a-sttebu.adb,
+ libgnat/a-stbubo.ads, libgnat/a-stbubo.adb,
+ libgnat/a-stbufi.ads, libgnat/a-stbufi.adb,
+ libgnat/a-stbufo.ads, libgnat/a-stbufo.adb,
+ libgnat/a-stbuun.ads, libgnat/a-stbuun.adb,
+ libgnat/a-stbuut.ads, libgnat/a-stbuut.adb: A new predefined
+ unit, Ada.Strings.Text_Buffers, and five child units. Two of
+ the five are RM-defined: Bounded and Unbounded. The remaining
+ three are GNAT-defined: Files, Utils, and Formatting. The buffer
+ type corresponding to an output file, type Files.File_Buffer, is
+ simpler (and perhaps therefore slower) than its predecessor.
+ Caching similar to what was being done before could be added
+ later if that seems appropriate.
+ * libgnat/s-putima.ads: Modify context clause, update
+ declaration of subtype Sink to refer to
+ Text_Buffers.Root_Buffer_Type instead of the old
+ Text_Output.Sink type.
+ * libgnat/s-putima.adb: Modify context clause. Update
+ Indent/Outdent calls to use new Increase_Indent/Decrease_Indent
+ names; ditto for "Put_String => Put" name change.
+ * libgnat/a-stteou__bootstrap.ads: Delete.
+
+2021-06-21 Eric Botcazou <ebotcazou@adacore.com>
+
+ * exp_ch5.adb (Expand_Assign_Array_Bitfield_Fast): If big-endian
+ ordering is in effect for the operands and they are small,
+ adjust the unchecked conversions done around them.
+
+2021-06-21 Richard Kenner <kenner@adacore.com>
+
+ * einfo.ads (Return_Statement): Add documentation.
+ * exp_ch6.adb (Expand_N_Extended_Return_Statement): Set it.
+ * gen_il-fields.ads: Add it.
+ * gen_il-gen-gen_entities.adb: Add it.
+
+2021-06-21 Bob Duff <duff@adacore.com>
+
+ * rtsfind.ads, libgnat/s-bitfie.ads, libgnat/s-bituti.adb,
+ libgnat/s-bituti.ads (Fast_Copy_Bitfield): New run-time library
+ function to copy bit fields faster than Copy_Bitfield. Cannot be
+ called with zero-size bit fields. Remove obsolete ??? comments
+ from s-bituti.adb; we already do "avoid calling this if
+ Forwards_OK is False".
+ * exp_ch5.adb (Expand_Assign_Array_Loop_Or_Bitfield,
+ Expand_Assign_Array_Bitfield_Fast): Generate calls to
+ Fast_Copy_Bitfield when appropriate.
+ * sem_util.adb, sem_util.ads (Get_Index_Bounds): Two new
+ functions for getting the index bounds. These are more
+ convenient than the procedure of the same name, because they can
+ be used to initialize constants.
+
+2021-06-21 Ed Schonberg <schonberg@adacore.com>
+
+ * gen_il-fields.ads: Add Default_Subtype_Mark to enumeration
+ type for fields.
+ * gen_il-gen-gen_nodes.adb: Add call to create new field for
+ Formal_Type_Declaration node.
+ * par-ch12.adb (P_Formal_Type_Declaration): in Ada_2022 mode,
+ recognize new syntax for default: "or use subtype_mark".
+ (P_Formal_Type_Definition): Ditto for the case of a formal
+ incomplete type.
+ * sinfo.ads: Add field Default_Subtype_Mark to
+ N_Formal_Type_Declaration.
+ * sem_ch12.adb (Validate_Formal_Type_Default): New procedure, to
+ apply legality rules to default subtypes in formal type
+ declarations. Some legality rules apply to all defaults, such as
+ the requirement that the default for a formal type that depends
+ on previous formal entities must itself be a previously declared
+ formal of the same unit. Other checks are kind- specific.
+ (Analyze_Associations): Use specified default if there is no
+ actual provided for a formal type in an instance.
+ (Analyze_Formal_Type_Declaration): Call
+ Validate_Formal_Type_Default when default subtype is present.
+
+2021-06-21 Bob Duff <duff@adacore.com>
+
+ * libgnat/s-valuen.ads, libgnat/s-valuen.adb
+ (Value_Enumeration_Pos): New function to compute the 'Pos of the
+ enumeration literal for a given String. Return a special value
+ instead of raising an exception on invalid input. Called by both
+ Valid_Enumeration_Image and Value_Enumeration.
+ (Valid_Enumeration_Image): Return a Boolean indicating whether
+ the String is a valid Image for the given enumeration type.
+ (Value_Enumeration): Implement in terms of
+ Value_Enumeration_Pos.
+ * libgnat/s-vaenu8.ads, libgnat/s-vaen16.ads,
+ libgnat/s-vaen32.ads: Rename Valid_Enumeration_Image from the
+ instances.
+ * libgnat/s-valuti.ads: Correct documentation (it was not true
+ for the null string).
+ * libgnat/s-valuti.adb (Normalize_String): Do not raise
+ Constraint_Error for the null string, nor strings containing
+ nothing but blanks, so that Valid_Enumeration_Image can return
+ False in these cases, rather than raising an exception.
+ * rtsfind.ads (RE_Value_Enumeration_8, RE_Value_Enumeration_16,
+ RE_Value_Enumeration_32): New functions.
+ (RTE_Available): Improve comment (E doesn't have to be a
+ subprogram, although that's the usual case).
+ * sem_attr.adb (nalid_Value): Semantic analysis for new
+ attribute.
+ * exp_attr.adb: Call Expand_Valid_Value_Attribute for new
+ attribute.
+ * exp_imgv.ads, exp_imgv.adb (Expand_Valid_Value_Attribute): New
+ procedure to expand Valid_Value into a call to
+ Valid_Enumeration_Image_NN.
+ (Expand_Value_Attribute): Misc code cleanups. Remove two ???
+ mark comments. RTE_Available won't work here. For one thing,
+ RTE_Available (X) shouldn't be called until the compiler has
+ decided to make use of X (see comments on RTE_Available), and in
+ this case we're trying to AVOID calling something.
+ * snames.ads-tmpl: New attribute name.
+ * doc/gnat_rm/implementation_defined_attributes.rst: Document
+ new attribute.
+ * gnat_rm.texi: Regenerate.
+
+2021-06-21 Eric Botcazou <ebotcazou@adacore.com>
+
+ * fe.h (Assume_No_Invalid_Values): Declare.
+ * opt.ads (Assume_No_Invalid_Values): Add warning comment.
+
+2021-06-21 Bob Duff <duff@adacore.com>
+
+ * libgnat/s-bituti.ads (Small_Size): Do not include 0 in this
+ type.
+ * libgnat/s-bituti.adb (Copy_Bitfield): Do nothing for 0-bit
+ bitfields.
+
+2021-06-21 Ghjuvan Lacambre <lacambre@adacore.com>
+
+ * exp_ch9.adb (Build_Simple_Entry_Call): Add comment.
+ * libgnat/s-rannum.adb (Random): Update comment.
+ * libgnat/s-rannum.ads (Generator): Update comment.
+
+2021-06-21 Piotr Trojanek <trojanek@adacore.com>
+
+ * doc/gnat_rm/representation_clauses_and_pragmas.rst (Address
+ Clauses): Fix unbalanced parens.
+ * gnat_rm.texi: Regenerate.
+
+2021-06-21 Ghjuvan Lacambre <lacambre@adacore.com>
+
+ * errout.adb (Handle_Serious_Error): Capitalize comment.
+ * exp_dbug.adb (Set_Entity_Name): Capitalize sentence.
+ * exp_dist.adb (Expand_All_Calls_Remote_Subprogram_Call): Fix
+ typo.
+ * sem_ch3.adb (Modular_Type_Declaration): Add space after comma.
+
+2021-06-21 Ghjuvan Lacambre <lacambre@adacore.com>
+
+ * debug.adb: Document -gnatd_U as taken.
+ * err_vars.ads (Warning_Doc_Switch): Set to True.
+ * errout.ads (Errout): Update documentation.
+ * gnat1drv.adb (Adjust_Global_Switches): React to -gnatd_U.
+ * hostparm.ads (Tag_Errors): Set to True.
+ * opt.ads (Unique_Error_Tag): Document -gnatd_U.
+
+2021-06-21 Eric Botcazou <ebotcazou@adacore.com>
+
+ * urealp.ads (UR_Write_To_JSON): Declare.
+ * urealp.adb (Decimal_Exponent_Hi): Treat numbers in base 10
+ specially and rewrite handling of numbers in other bases.
+ (Decimal_Exponent_Lo): Likewise.
+ (Normalize): Minor tweak.
+ (UR_Write_To_JSON): New wrapper procedure around UR_Write.
+ * repinfo.adb (List_Type_Info): When the output is to JSON, call
+ UR_Write_To_JSON instead of UR_Write.
+
+2021-06-21 Piotr Trojanek <trojanek@adacore.com>
+
+ * sem_util.adb (Indexed_Component_Bit_Offset): Return an unknown
+ offset for components within multidimensional arrays; remove
+ redundant parens.
+
+2021-06-21 Piotr Trojanek <trojanek@adacore.com>
+
+ * sem_util.adb (Find_Overlaid_Entity): Ignore references to
+ components and discriminants.
+
+2021-06-21 Doug Rupp <rupp@adacore.com>
+
+ * Makefile.rtl (aarch64-linux) [LIBGNAT_TARGET_PAIRS]: Add
+ $(TRASYM_DWARF_UNIX_PAIRS).
+ [EXTRA_GNAT_RTL_NONTASKING_OBJS]: Add $(TRASYM_DWARF_UNIX_OBJS)
+
+2021-06-21 Gary Dismukes <dismukes@adacore.com>
+
+ * exp_util.adb (Expand_Sliding_Conversion): Only perform
+ expansion when Expander_Active is True. Add a comment about this
+ and refine existing comment regarding string literals.
+
+2021-06-21 Piotr Trojanek <trojanek@adacore.com>
+
+ * sem_util.adb (Denotes_Same_Object): Simplify handling of
+ slices.
+
+2021-06-21 Piotr Trojanek <trojanek@adacore.com>
+
+ * sem_util.adb (Is_Object_Renaming): Rename from Is_Renaming;
+ simplify; adapt callers.
+
+2021-06-21 Frederic Konrad <konrad@adacore.com>
+
+ * Makefile.rtl: Compiles both static and dynamic libgnat for
+ powerpc64-wrs-vxworks7r2.
+
+2021-06-18 Gary Dismukes <dismukes@adacore.com>
+
+ * sem_ch3.adb (Constrain_Array): Add error checking for
+ fixed-lower-bound and constrained index ranges applied
+ inappropriately on subtypes of unconstrained and
+ fixed-lower-bound array types.
+ (Constrain_Index): Correct and refine comment related to
+ fixed-lower-bound index ranges.
+
+2021-06-18 Bob Duff <duff@adacore.com>
+
+ * gen_il-gen.adb: Improve comments.
+ * snames.ads-tmpl (Convention_Id): Remove "-- Plenty of space
+ for expansion", because that's irrelevant now that we are no
+ longer laying out node fields by hand.
+
+2021-06-18 Piotr Trojanek <trojanek@adacore.com>
+
+ * sem_util.adb (Denotes_Same_Object): Handle character literals
+ just like integer literals.
+
+2021-06-18 Piotr Trojanek <trojanek@adacore.com>
+
+ * sem_util.adb (Denotes_Same_Object): Explicitly test for node
+ kinds being the same; deal with renamings one-by-one; adjust
+ numbers in references to the Ada RM.
+
+2021-06-18 Bob Duff <duff@adacore.com>
+
+ * sprint.adb (Write_Source_Line): Check for EOF in
+ Line_Terminator loop. Note that when a source file is read in,
+ an EOF character is added to the end.
+
+2021-06-18 Piotr Trojanek <trojanek@adacore.com>
+
+ * sem_aux.adb (Package_Specification): Add assertions to confirm
+ the kind of the of parameter and returned node.
+ * sem_ch12.adb (Remove_Parent): Reorder conditions; this change
+ appears to be semantically neutral, but is enough to avoid the
+ problematic call to Package_Specification.
+ * sem_util.adb (Is_Incomplete_Or_Private_Type): Replace loop
+ with a call to Package_Specification.
+
+2021-06-18 Bob Duff <duff@adacore.com>
+
+ * sem_attr.adb (Eval_Attribute): For Enum_Lit'Size, use
+ Enum_Type'Object_Size.
+
+2021-06-18 Olivier Hainque <hainque@adacore.com>
+
+ * sigtramp-vxworks-target.inc (__aarch64__): Sync
+ REGNO_PC_OFFSET with the back-end DWARF_ALT_FRAME_RETURN_COLUMN.
+ In CFI_COMMON_REGS, leave r18 alone, VxWorks private.
+
+2021-06-18 Javier Miranda <miranda@adacore.com>
+
+ * contracts.adb (Process_Spec_Postconditions): Add missing
+ support for aliased subprograms and handle wrappers of
+ class-wide pre/post conditions.
+ (Process_Inherited_Preconditions): Add missing support for
+ aliased subprograms and handle wrappers of class-wide pre/post
+ conditions.
+ * einfo.ads (Class_Wide_Clone): Fix typo.
+ (Is_Class_Wide_Clone): Removed since it is not referenced.
+ (Is_Wrapper): Documenting new flag.
+ (LSP_Subprogram): Documenting new attribute.
+ * exp_ch3.adb (Make_Controlling_Function_Wrappers): Decorate
+ wrapper as Is_Wrapper and adjust call to
+ Override_Dispatching_Operation.
+ * freeze.adb (Build_Inherited_Condition_Pragmas): Fix typo in
+ documentation.
+ (Check_Inherited_Conditions): Handle LSP wrappers; ensure
+ correct decoration of LSP wrappers.
+ * gen_il-fields.ads (Is_Class_Wide_Clone): Removed.
+ (Is_Wrapper): Added.
+ (LSP_Subprogram): Added.
+ * gen_il-gen-gen_entities.adb (Is_Class_Wide_Clone): Removed.
+ (Is_Wrapper): Added.
+ (LSP_Subprogram): Added.
+ * gen_il-internals.adb (Image): Adding uppercase image of
+ LSP_Subprogram.
+ * sem_ch6.adb (New_Overloaded_Entity): Fix decoration of LSP
+ wrappers.
+ * sem_disp.ads (Override_Dispatching_Operation): Remove
+ parameter Is_Wrapper; no longer needed.
+ * sem_disp.adb (Check_Dispatching_Operation): Adjust assertion.
+ (Override_Dispatching_Operation): Remove parameter Is_Wrapper;
+ no longer needed.
+ * treepr.adb (Image): Adding uppercase image of LSP_Subprogram.
+
+2021-06-18 Arnaud Charlet <charlet@adacore.com>
+
+ * exp_ch4.adb (Expand_N_Quantified_Expression): Ensure the type
+ of the name of a "for of" loop is frozen.
+ * exp_disp.adb (Check_Premature_Freezing): Complete condition to
+ take into account a private type completed by another private
+ type now that the freezing rule are better implemented.
+ * freeze.adb (Freeze_Entity.Freeze_Profile): Do not perform an
+ early freeze on types if not in the proper scope. Special case
+ expression functions that requires access to the dispatch table.
+ (Should_Freeze_Type): New.
+ * sem_ch13.adb (Resolve_Aspect_Expressions): Prevent assert
+ failure in case of an invalid tree (previous errors detected).
+ * sem_res.adb (Resolve): Remove kludge related to entities
+ causing incorrect premature freezing.
+ * sem_util.adb (Ensure_Minimum_Decoration): Add protection
+ against non base types.
+
+2021-06-18 Gary Dismukes <dismukes@adacore.com>
+
+ * sem_ch3.adb (Constrain_Index): Set the High_Bound of a
+ fixed-lower-bound subtype's range to T (the subtype of the FLB
+ index being constrained) rather than Base_Type (T).
+
+2021-06-18 Bob Duff <duff@adacore.com>
+
+ * ada_get_targ.adb, aspects.ads, checks.adb, cstand.adb,
+ einfo.ads, exp_attr.adb, freeze.adb, get_targ.adb,
+ libgnat/a-textio.ads, libgnat/g-memdum.ads,
+ libgnat/s-scaval__128.adb, libgnat/s-scaval.adb, make.adb,
+ osint.ads, par-prag.adb, sem_ch13.adb, sem_prag.adb,
+ sem_prag.ads, set_targ.adb, set_targ.ads, snames.ads-tmpl,
+ targparm.ads, types.ads: Remove AAMP-specific code.
+ * switch.ads: Minor reformatting.
+ * gen_il-fields.ads, gen_il-gen.adb,
+ gen_il-gen-gen_entities.adb, gen_il-types.ads, einfo-utils.adb,
+ einfo-utils.ads: Package Types now contains "type Float_Rep_Kind
+ is (IEEE_Binary);", which used to also have an enumeral AAMP.
+ Gen_IL can't handle fields of this type, which would be zero
+ sized. Therefore, we move the Float_Rep field into Einfo.Utils
+ as a synthesized attribute. (We do not delete the field
+ altogether, in case we want new floating-point representations
+ in the future.)
+ * doc/gnat_rm/implementation_defined_pragmas.rst,
+ doc/gnat_rm/implementation_defined_aspects.rst,
+ doc/gnat_ugn/building_executable_programs_with_gnat.rst,
+ doc/gnat_ugn/the_gnat_compilation_model.rst: Remove
+ AAMP-specific documentation.
+ * gnat_rm.texi, gnat_ugn.texi: Regenerate.
+
+2021-06-18 Gary Dismukes <dismukes@adacore.com>
+
+ * exp_util.adb (Expand_Sliding_Conversion): Move test of
+ Is_Fixed_Lower_Bound_Subtype to an assertion. Exclude string
+ literals from sliding expansion.
+
+2021-06-18 Piotr Trojanek <trojanek@adacore.com>
+
+ * sem_warn.adb (Warn_On_Overlapping_Actuals): Cleanup conditions
+ related to Ada_Version.
+
+2021-06-18 Piotr Trojanek <trojanek@adacore.com>
+
+ * sem_util.adb (Address_Value): Simplify.
+
+2021-06-18 Bob Duff <duff@adacore.com>
+
+ * sem_attr.adb (Check_Array_Or_Scalar_Type): Use Expr_Value
+ instead of Intval, because the latter only exists in literals.
+ Remove Set_Etype on E1; setting the type is done elsewhere.
+
+2021-06-18 Piotr Trojanek <trojanek@adacore.com>
+
+ * sem_warn.adb (Warn_On_Overlapping_Actuals): Examine types of
+ both formal parameters; refactor a complex detection of
+ by-reference types.
+
+2021-06-18 Arnaud Charlet <charlet@adacore.com>
+
+ * gnatcmd.adb: Fix handling of check and test commands.
+
+2021-06-18 Gary Dismukes <dismukes@adacore.com>
+
+ * doc/gnat_rm/implementation_defined_pragmas.rst: Add
+ documentation for the array fixed-lower-bound feature.
+ * gnat_rm.texi: Regenerate.
+
+2021-06-18 Bob Duff <duff@adacore.com>
+
+ * debug.adb: Document switch.
+ * exp_aggr.adb: If -gnatd_g was given, then do not bump the
+ limit to 500_000.
+
+2021-06-18 Bob Duff <duff@adacore.com>
+
+ * sem_util.ads, sem_util.adb (Has_Access_Values): Remove
+ Include_Internal parameter that was added in previous change.
+ * sem_warn.adb (Warnings_Off_E1): Back out E_Out_Parameter ==>
+ Formal_Kind change made previously. Check Is_Private_Type to
+ avoid warnings on private types. Misc cleanup.
+ * sem_attr.adb (Attribute_Has_Access_Values): Remove
+ Include_Internal parameter.
+
+2021-06-18 Piotr Trojanek <trojanek@adacore.com>
+
+ * sem_warn.adb (Warn_On_Overlapping_Actuals): Remove dead branch
+ for overlapping actuals in prefix notation.
+
+2021-06-18 Eric Botcazou <ebotcazou@adacore.com>
+
+ * sem_prag.adb (Process_Import_Or_Interface): Do not
+ artificially record a possible modification for a constant.
+
+2021-06-18 Arnaud Charlet <charlet@adacore.com>
+
+ * exp_ch6.adb (Expand_Call_Helper): Code cleanups.
+
+2021-06-18 Arnaud Charlet <charlet@adacore.com>
+
+ * exp_aggr.adb, exp_dist.adb, exp_unst.adb, sa_messages.ads,
+ sem_ch13.adb, sem_ch3.adb, sem_ch5.adb, sem_eval.adb,
+ sem_util.adb, sem_util.ads, sinfo.ads: Update comments.
+
+2021-06-18 Ghjuvan Lacambre <lacambre@adacore.com>
+
+ * back_end.adb (Scan_Back_End_Switches): Set Opt.JSON_Output to
+ True if -fdiagnostics-format=json option is found.
+ * back_end.ads (Scan_Compiler_Arguments): Mention
+ Opt.JSON_Output.
+ * errout.adb (Output_JSON_Message): New procedure.
+ (Output_Messages): If Opt.JSON_Output is True, print messages
+ with new Output_JSON_Message procedure.
+ * opt.ads: Declare JSON_Output variable.
+ * doc/gnat_ugn/building_executable_programs_with_gnat.rst:
+ Mention new -fdiagnostics-format option.
+ * gnat_ugn.texi: Regenerate.
+
+2021-06-18 Arnaud Charlet <charlet@adacore.com>
+
+ * sem_ch6.adb (Null_Exclusions_Match): Relax null exclusion
+ mismatch check when Relaxed_RM_Semantics is set.
+
+2021-06-18 Arnaud Charlet <charlet@adacore.com>
+
+ * fe.h, opt.adb, opt.ads, par-prag.adb, sem_prag.adb,
+ switch-c.adb (Extensions_Allowed): Replace by a function.
+ (Ada_Version_Type): Add new value Ada_With_Extensions, to
+ replace setting of Extensions_Allowed. Update setting of
+ Extensions_Allowed.
+
+2021-06-18 Arnaud Charlet <charlet@adacore.com>
+
+ * bindgen.adb (Gen_Output_File_Ada): Generate a new constant
+ GNAT_Version_Address.
+ * libgnat/g-comver.adb (GNAT_Version_Address): New;
+ (GNAT_Version): Use GNAT_Version_Address to disable LTO warning.
+
+2021-06-18 Javier Miranda <miranda@adacore.com>
+
+ * einfo.ads (Is_Ada_2022_Only): Adding documentation.
+ * gen_il-fields.ads (Is_Ada_2022_Only): New flag.
+ * gen_il-gen-gen_entities.adb (Is_Ada_2022_Only): New flag.
+ * itypes.adb (Create_Null_Excluding_Itype): Inherit
+ Is_Ada_2022_Only.
+ * sem_ch3.adb (Check_Abstract_Overriding): Skip reporting error
+ on Ada 2022 only subprograms that require overriding if we are
+ not in Ada 2022 mode.
+ (Derive_Subprogram): Inherit Is_Ada_2022_Only.
+ * sem_ch6.adb (Check_Overriding_Indicator): Inherit
+ Is_Ada_2022_Only.
+ (New_Overloaded_Entity): Inherit Is_Ada_2022_Only.
+ * sem_ch7.adb (Declare_Inherited_Private_Subprograms): Inherit
+ Is_Ada_2022_Only.
+ (Preserve_Full_Attributes): Inherit Is_Ada_2022_Only.
+ * sem_disp.adb (Find_Hidden_Overridden_Primitive): Inherit
+ Is_Ada_2022_Only.
+ (Override_Dispatching_Operation): Inherit Is_Ada_2022_Only.
+ * sem_prag.adb (Analyze_Pragma): Allow form with argument for
+ Ada 2022.
+ * sem_type.adb: (Disambiguate): Deal with Is_Ada_2022_Only
+ * lib-xref.adb (Generate_Reference): Error on static and
+ dispatching calls to Ada 2022 subprograms that require
+ overriding if we are not in Ada 2022 mode; warn on other
+ references to Ada 2022 entities when not in Ada 2022 mode.
+ * sem_ch13.adb (Inherit_Aspects_At_Freeze_Point): Inherit
+ Ada_2020_Only.
+ * libgnat/a-cdlili.ads (Empty): Adding pragma Ada_2022.
+ * libgnat/a-cidlli.ads (Empty): Adding pragma Ada_2022.
+ * libgnat/a-ciorma.ads (Empty): Adding pragma Ada_2022.
+ * libgnat/a-cobove.ads (Empty): Adding pragma Ada_2022.
+ * libgnat/a-coorma.ads (Empty): Adding pragma Ada_2022.
+ (New_Vector): Adding pragma Ada_2022.
+ (Insert_Vector): Adding pragma Ada_2022.
+ (Prepend_Vector): Adding pragma Ada_2022.
+ (Append_Vector): Adding pragma Ada_2022.
+
+2021-06-17 Arnaud Charlet <charlet@adacore.com>
+
+ * sem_ch3.adb (Check_Ops_From_Incomplete_Type): Protect against
+ no Primitive_Operations.
+
+2021-06-17 Vadim Godunko <godunko@adacore.com>
+
+ * libgnat/a-strunb__shared.ads (Allocate): Additional parameter
+ to provide additional amount of space to be allocated.
+ * libgnat/a-strunb__shared.adb (Aligned_Max_Length): Limit
+ length to Natural'Last when requested length is larger than it.
+ (Allocate): Merge two slightly different implementations into
+ one.
+
+2021-06-17 Gary Dismukes <dismukes@adacore.com>
+
+ * checks.adb (Discrete_Range_Cond): For an index subtype that
+ has a fixed lower bound, require that the range's lower bound
+ match that of the subtype.
+ (Selected_Range_Checks): Warn about the case where a static
+ lower bound does not equal an index subtype's fixed lower bound.
+ * einfo.ads (Is_Fixed_Lower_Bound_Array_Subtype,
+ Is_Fixed_Lower_Bound_Index_Subtype): Document new entity flag.
+ * exp_ch4.adb (Expand_N_Type_Conversion): If the operand is of
+ an unconstrained array subtype with fixed lower bound, then
+ Expand_Sliding_Conversion is applied to the operand.
+ * exp_ch6.adb (Expand_Simple_Function_Return): If the result
+ subtype is an unconstrained array subtype with fixed lower
+ bound, then Expand_Sliding_Conversion is applied to the return
+ object.
+ * exp_util.ads (Expand_Sliding_Conversion): New procedure for
+ applying a sliding subtype conversion to an array object of a
+ fixed-lower-bound subtype when needed.
+ * exp_util.adb: Add with_clause for Freeze.
+ (Expand_Sliding_Conversion): New procedure for applying a
+ sliding subtype conversion to an array object of a
+ fixed-lower-bound subtype when needed. It traverses the indexes
+ of the unconstrained array type/subtype to create a target
+ constrained subtype and rewrites the array object to be a
+ conversion to that subtype, when there's at least one index
+ whose lower bound does not statically match the fixed-lower
+ bound of the target subtype.
+ * gen_il-fields.ads (type Opt_Field_Enum): Add literals
+ Is_Fixed_Lower_Bound_Array_Subtype and
+ Is_Fixed_Lower_Bound_Index_Subtype for new flags on type
+ entities.
+ * gen_il-gen-gen_entities.adb: Add calls to
+ Create_Semantic_Field for the new fixed-lower-bound flags on
+ type entities.
+ * par-ch3.adb (P_Array_Type_Definition): Add handling for
+ parsing of fixed-lower-bound index ranges in unconstrained array
+ types. Report an error if such an index is encountered and GNAT
+ language extensions are not enabled.
+ (P_Index_Subtype_Def_With_Fixed_Lower_Bound): Support procedure
+ for parsing unconstrained index ranges.
+ (P_Index_Or_Discriminant_Constraint): Add handling for parsing
+ of index constraints that specify ranges with fixed lower
+ bounds. Report an error if such an index is encountered and GNAT
+ language extensions are not enabled.
+ * sem_ch3.adb (Analyze_Object_Declaration): If the object's
+ nominal subtype is an array subtype with fixed lower bound, then
+ Expand_Sliding_Conversion is applied to the object.
+ (Array_Type_Declaration): Mark the array type and the subtypes
+ of any indexes that specify a fixed lower bound as being
+ fixed-lower-bound subtypes, and set the High_bound of the range
+ of such an index to the upper bound of the named subtype.
+ (Constrain_Array): For an array subtype with one or more index
+ ranges specifying a fixed lower bound, set Is_Constrained to
+ False and set the array subtype's
+ Is_Fixed_Lower_Bound_Array_Subtype flag to True.
+ (Constrain_Index): Mark the subtypes of an index that specifies
+ a fixed lower bound as being a fixed-lower-bound index subtype,
+ and set the High_bound of the range of such an index to the
+ upper bound of the base type of the array type's corresponding
+ index.
+ * sem_res.adb (Resolve_Actuals): If a formal is of an
+ unconstrained array subtype with fixed lower bound, then
+ Expand_Sliding_Conversion is applied to the actual.
+ * sem_util.adb (Build_Actual_Subtype): If the actual subtype
+ corresponds to an unconstrained array subtype having any indexes
+ with fixed lower bounds, then set the lower bounds of any such
+ indexes of the actual subtype to the appropriate fixed lower
+ bound of the formal subtype (rather than taking it from the
+ formal itself).
+ * sprint.adb (Sprint_Node_Actual, case N_Range): If a range's
+ Etype has a fixed lower bound, then print "<>" rather than the
+ High_Bound of the range.
+
+2021-06-17 Bob Duff <duff@adacore.com>
+
+ * sem_util.adb, sem_util.ads (Has_Access_Values): New formal
+ Include_Internal to indicate whether internal types should be
+ included.
+ * sem_warn.adb (Check_References): Change E_Out_Parameter to
+ Formal_Kind, to match the comment about Spec_Entity. Pass
+ Include_Internal => False to Has_Access_Values, so that we warn
+ on types with access values that happen to be in internal types,
+ such as Unbounded_String.
+ * sem_attr.adb (Attribute_Has_Access_Values): Pass
+ Include_Internal => True to Has_Access_Values, to preserve
+ existing behavior.
+ * libgnat/g-rewdat.adb (Do_Output): Change B from 'in out' to
+ 'in', to avoid warning enabled by the change to sem_warn.adb.
+ * libgnat/s-objrea.adb (Check_Read_Offset): Change S from 'in
+ out' to 'in', to avoid warning enabled by the change to
+ sem_warn.adb.
+
+2021-06-17 Steve Baird <baird@adacore.com>
+
+ * exp_ch5.adb
+ (Expand_N_Case_Statement.Expand_General_Case_Statement): New
+ subprogram.
+ (Expand_N_Case_Statement): If extensions are allowed and the
+ case selector is not of a discrete type, then call
+ Expand_General_Case_Statement to generate expansion instead of
+ flagging the non-discrete selector as an error.
+ * sem_case.ads (Is_Case_Choice_Pattern): New Boolean-valued
+ function for testing whether a given expression occurs as part
+ of a case choice pattern.
+ * sem_case.adb (Composite_Case_Ops): New package providing
+ support routines for the new form of case statements. This
+ includes a nested package, Composite_Case_Ops.Value_Sets, which
+ encapsulates the "representative values" implementation of
+ composite value sets.
+ (Check_Choices.Check_Case_Pattern_Choices): New procedure for
+ semantic checking of non-discrete case choices. This includes
+ the checks pertaining to coverage and overlapping.
+ (Check_Choices.Check_Composite_Case_Selector): New procedure for
+ semantic checking of non-discrete case selectors.
+ (Check_Choices): If extensions are allowed then a non-discrete
+ selector type no longer implies that an error must have been
+ flagged earlier. Instead of simply returning, call
+ Check_Composite_Case_Selector and Check_Case_Pattern_Choices.
+ (Is_Case_Choice_Pattern): Body of new function declared in
+ sem_case.ads .
+ * sem_ch5.adb (Analyze_Case_Statement): If extensions are
+ allowed, then we can't use RM 5.4's "The selecting_expression is
+ expected to be of any discrete type" name resolution rule.
+ Handle the case where the type of the selecting expression is
+ not discrete, as well as the new ambiguous-name-resolution error
+ cases made possible by this change.
+ * sem_res.adb (Resolve_Entity_Name): It is ok to treat the name
+ of a type or subtype as an expression if it is part of a case
+ choice pattern, as in "(Field1 => Positive, Field2 => <>)".
+ * exp_aggr.adb (Expand_Record_Aggregate): Do not expand case
+ choice aggregates.
+ * gen_il-fields.ads: Define two new node attributes,
+ Binding_Chars and Multidefined_Bindings.
+ * gen_il-gen-gen_nodes.adb: The new Multidefined_Bindings
+ attribute is Boolean-valued and may be set on
+ N_Case_Statement_Alternative nodes. The new Binding_Chars
+ attribute is Name_Id-valued and may be set on
+ N_Component_Association nodes.
+ * par-ch4.adb (P_Record_Or_Array_Component_Association): When
+ parsing a component association, check for both new syntax forms
+ used to specify a bound value in a case-choice aggregate. In
+ the case of a box value, an identifier may occur within the box,
+ as in "Foo => <Abc>" instead of "Foo => <>". In the more general
+ case, an expression (or a box) may be followed by "is
+ <identifier>", as in
+ "Foo => Bar is Abc" instead of just "Foo => Bar".
+ * sem_aggr.adb (Resolve_Record_Aggregate): Do not transform box
+ component values in a case-choice aggregate.
+ * sinfo.ads: Provide comments for the new attributes added in
+ gen_il-fields.ads.
+ * doc/gnat_rm/implementation_defined_pragmas.rst: Describe this
+ new feature in documentation for pragma Extensions_Allowed.
+ * gnat_rm.texi: Regenerate.
+
+2021-06-17 Arnaud Charlet <charlet@adacore.com>
+
+ * exp_ch4.adb (Expand_N_Expression_With_Actions.Process_Action):
+ Do not abandon processing on a nested N_Expression_With_Actions
+ or N_Loop_Statement, otherwise we may miss some transient
+ declarations.
+
+2021-06-17 Arnaud Charlet <charlet@adacore.com>
+
+ * exp_util.adb (Find_Hook_Context): Do not stop on an aggregate
+ node.
+
+2021-06-17 Piotr Trojanek <trojanek@adacore.com>
+
+ * sem_util.adb (Is_Valid_Renaming): Check not only indexed
+ components, but slices too.
+
+2021-06-17 Piotr Trojanek <trojanek@adacore.com>
+
+ * sem_ch3.adb (Analyze_Private_Extension_Declaration): Check
+ No_Wide_Characters restriction after rejecting illegal parent
+ types.
+ (Derived_Type_Declaration): Likewise.
+ (Find_Type_Of_Subtype_Indic): Remove check for
+ No_Wide_Characters restriction, which was done too early.
+
+2021-06-17 Piotr Trojanek <trojanek@adacore.com>
+
+ * sem_util.adb (Is_Valid_Renaming): Body moved from its nested
+ routine.
+
+2021-06-17 Gary Dismukes <dismukes@adacore.com>
+
+ * sem_ch12.adb (Instantiate_Type): If the actual type for an
+ incomplete formal type is also incomplete, but has a Full_View,
+ use the Full_View of the actual type rather than the incomplete
+ view.
+
+2021-06-17 Piotr Trojanek <trojanek@adacore.com>
+
+ * doc/gnat_ugn/building_executable_programs_with_gnat.rst
+ (-gnatw.I): Remove double period at the end of sentence.
+ * gnat_ugn.texi: Regenerate.
+
+2021-06-17 Piotr Trojanek <trojanek@adacore.com>
+
+ * sem_util.adb (Denotes_Same_Object): Call Get_Index_Bounds with
+ the range of a slice object, not its type.
+
+2021-06-17 Piotr Trojanek <trojanek@adacore.com>
+
+ * sem_warn.adb (Warn_On_Overlapping_Actuals): Fix style;
+ refactor repeated calls to Nkind; remove early RETURN.
+
+2021-06-17 Piotr Trojanek <trojanek@adacore.com>
+
+ * sem_warn.adb (Warn_On_Overlapping_Actuals): Ignore formal of
+ generic types, but keep examining other parameters.
+
+2021-06-17 Piotr Trojanek <trojanek@adacore.com>
+
+ * sem_warn.adb (Warn_On_Overlapping_Actuals): Remove dead code.
+
+2021-06-17 Piotr Trojanek <trojanek@adacore.com>
+
+ * sem_warn.adb (Warn_On_Overlapping_Actuals): Remove repeated
+ code.
+
+2021-06-17 Piotr Trojanek <trojanek@adacore.com>
+
+ * checks.adb (Overlap_Check): Replace Set_Casing with
+ Adjust_Name_Case and adapt surrounding code as needed.
+
+2021-06-17 Arnaud Charlet <charlet@adacore.com>
+
+ * libgnat/s-putaim.ads, libgnat/s-putaim.adb: Move...
+ * libgnarl/s-putaim.ads, libgnarl/s-putaim.adb: ... here.
+
+2021-06-17 Arnaud Charlet <charlet@adacore.com>
+
+ * uintp.ads, uintp.adb (UI_To_Unsigned_64): New.
+
+2021-06-17 Piotr Trojanek <trojanek@adacore.com>
+
+ * sem_prag.adb (Get_Overflow_Mode): Reword error message.
+ * switch-c.adb (Get_Overflow_Mode): Likewise.
+
+2021-06-17 Richard Kenner <kenner@adacore.com>
+
+ * exp_util.adb (Expand_Static_Predicates_In_Choices): Handle
+ Others_Discrete_Choices in N_Others_Choice.
+
+2021-06-17 Arnaud Charlet <charlet@adacore.com>
+
+ * atree.adb: Remove redundant comment with spec.
+ * sem_warn.adb: Fix typo in comment.
+
+2021-06-17 Arnaud Charlet <charlet@adacore.com>
+
+ * atree.adb: Do not suppress checks.
+
+2021-06-17 Justin Squirek <squirek@adacore.com>
+
+ * exp_ch3.adb (Check_Missing_Others): Add comment.
+ (Build_Initialization_Call): Remove inaccurate accessibility
+ comment.
+ * sem_ch12.adb (Analyze_Generic_Subprogram_Declaration): Remove
+ test for Ada2012.
+ (Analyze_Package_Instantiation): Remove speculative comment.
+ (Inline_Instance_Body): Add comments for loops.
+ (Build_Subprogram_Renaming): Remove comment about fix being
+ partial and "ugly."
+ (Instantiate_Subprogram_Body): Remove comment referencing DEC
+ related internal issue.
+ (Subtypes_Match): Add comment and simplify anonymous access
+ test.
+ (Is_Global): Add test for when E is an expanded name, and
+ calculate the scope accordingly.
+ * sem_ch6.adb (Analyze_Function_Return): Update comment
+ regarding accessibility, and add check for
+ Warn_On_Ada_2012_Compatibility.
+ (Mask_Type_Refs): Add comments.
+ (Analyze_Subprogram_Declaration): Remove mysterious suppression
+ of elaboration checks.
+ * sem_ch7.adb (Preserve_Full_Attributes): Preserve Is_Atomic
+ value.
+ * sem_ch8.adb (Most_Descendant_Use_Clause): Remove comment.
+ (Note_Redundant_Use): Fix calls to Find_First_Use to be
+ Find_Most_Prev.
+ (Get_Object_Name): Modify error message to be more descriptive.
+ (Known_But_Visible): Remove mysterious special case for
+ GNAT_Mode.
+ (Find_First_Use): Removed.
+ (Find_Most_Prev): Renamed from Find_First_Use.
+ * sem_prag.adb (Check_Static_Constraint): Add comments to
+ routine.
+
+2021-06-17 Bob Duff <duff@adacore.com>
+
+ * treepr.adb (Print_Node): Display the Entity or Associated_Node
+ fields if appropriate.
+ * sinfo-utils.ads (F_Associated_Node, F_Entity): Remove. These
+ are no longer needed.
+
+2021-06-17 Piotr Trojanek <trojanek@adacore.com>
+
+ * checks.adb (Apply_Parameter_Aliasing_Checks): Replace calls to
+ Is_Object_Reference with calls to Is_Name_Reference; remove
+ asymmetric condition that only detected an aggregate as the
+ first actual (aggregate objects were just a special case of an
+ object reference that was not a name).
+
+2021-06-17 Bob Duff <duff@adacore.com>
+
+ * gen_il-gen.adb, gen_il-internals.ads: Generate field
+ enumeration literals with "F_" prefix. Update all generated
+ references accordingly.
+ * atree.adb, einfo-utils.adb, sem_ch3.adb, sem_ch5.adb,
+ sem_ch6.adb, sem_ch8.adb, sinfo-cn.adb, sinfo-utils.adb,
+ sinfo-utils.ads, treepr.adb: Add "F_" prefix to all uses of the
+ field enumeration literals.
+
+2021-06-17 Arnaud Charlet <charlet@adacore.com>
+
+ * libgnat/i-c.ads, libgnat/i-cexten.ads,
+ libgnat/i-cexten__128.ads: bool renamed C_bool.
+
+2021-06-17 Piotr Trojanek <trojanek@adacore.com>
+
+ * sem_ch4.adb (Analyze_Allocator): Reject allocators in
+ restricted contexts.
+
+2021-06-17 Arnaud Charlet <charlet@adacore.com>
+
+ * gcc-interface/Make-lang.in: Use libgnat.so if libgnat.a cannot
+ be found.
+
+2021-06-16 Piotr Trojanek <trojanek@adacore.com>
+
+ * sem_util.adb (Is_Volatile_Function): Follow the exact wording
+ of SPARK (regarding volatile functions) and Ada (regarding
+ protected functions).
+
+2021-06-16 Piotr Trojanek <trojanek@adacore.com>
+
+ * sem_util.adb (Is_OK_Volatile_Context): All references to
+ volatile objects are legal in preanalysis.
+ (Within_Volatile_Function): Previously it was wrongly called on
+ Empty entities; now it is only called on E_Return_Statement,
+ which allow the body to be greatly simplified.
+
+2021-06-16 Yannick Moy <moy@adacore.com>
+
+ * sem_res.adb (Set_Slice_Subtype): Revert special-case
+ introduced previously, which is not needed as Itypes created for
+ slices are precisely always used.
+
+2021-06-16 Eric Botcazou <ebotcazou@adacore.com>
+
+ * urealp.adb (Scale): Change first paramter to Uint and adjust.
+ (Equivalent_Decimal_Exponent): Pass U.Den directly to Scale.
+ * libgnat/s-exponr.adb (Negative): Rename to...
+ (Safe_Negative): ...this and change its lower bound.
+ (Exponr): Adjust to above renaming and deal with Integer'First.
+
+2021-06-16 Piotr Trojanek <trojanek@adacore.com>
+
+ * sem_res.adb (Flag_Effectively_Volatile_Objects): Detect also
+ allocators within restricted contexts and not just entity names.
+ (Resolve_Actuals): Remove duplicated code for detecting
+ restricted contexts; it is now exclusively done in
+ Is_OK_Volatile_Context.
+ (Resolve_Entity_Name): Adapt to new parameter of
+ Is_OK_Volatile_Context.
+ * sem_util.ads, sem_util.adb (Is_OK_Volatile_Context): Adapt to
+ handle contexts both inside and outside of subprogram call
+ actual parameters.
+ (Within_Subprogram_Call): Remove; now handled by
+ Is_OK_Volatile_Context itself and its parameter.
+
+2021-06-16 Piotr Trojanek <trojanek@adacore.com>
+
+ * sinput.adb (Sloc_Range): Refactor several repeated calls to
+ Sloc and two comparisons with No_Location.
+
+2021-06-16 Piotr Trojanek <trojanek@adacore.com>
+
+ * checks.adb (Apply_Scalar_Range_Check): Fix handling of check depending
+ on the parameter passing mechanism. Grammar adjustment ("has"
+ => "have").
+ (Parameter_Passing_Mechanism_Specified): Add a hyphen in a comment.
+
+2021-06-16 Piotr Trojanek <trojanek@adacore.com>
+
+ * exp_ch3.adb (Build_Slice_Assignment): Remove unused
+ initialization.
+
+2021-06-16 Piotr Trojanek <trojanek@adacore.com>
+
+ * restrict.adb, sem_attr.adb, types.ads: Fix typos in
+ "occuring"; refill comment as necessary.
+
+2021-06-16 Piotr Trojanek <trojanek@adacore.com>
+
+ * sem_util.ads (Is_Actual_Parameter): Update comment.
+ * sem_util.adb (Is_Actual_Parameter): Also detect entry parameters.
+
+2021-06-16 Arnaud Charlet <charlet@adacore.com>
+
+ * rtsfind.ads, libgnarl/s-taskin.ads, exp_ch3.adb, exp_ch4.adb,
+ exp_ch6.adb, exp_ch9.adb, sem_ch6.adb: Move master related
+ entities to the expander directly.
+
+2021-06-16 Piotr Trojanek <trojanek@adacore.com>
+
+ * sem_res.adb (Is_Assignment_Or_Object_Expression): Whitespace
+ cleanup.
+ (Is_Attribute_Expression): Prevent AST climbing from going to
+ the root of the compilation unit.
+
+2021-06-16 Steve Baird <baird@adacore.com>
+
+ * doc/gnat_rm/implementation_advice.rst: Add a section for RM
+ A.18 .
+ * gnat_rm.texi: Regenerate.
+
+2021-06-16 Justin Squirek <squirek@adacore.com>
+
+ * sem_ch13.adb (Analyze_Enumeration_Representation_Clause): Add
+ check for the mixing of entries.
+
+2021-06-16 Justin Squirek <squirek@adacore.com>
+
+ * sem_ch13.adb (Make_Aitem_Pragma): Check for static expressions
+ in Priority aspect arguments for restriction Static_Priorities.
+
+2021-06-16 Justin Squirek <squirek@adacore.com>
+
+ * sem_util.adb (Accessibility_Level): Take into account
+ renamings of loop parameters.
+
+2021-06-16 Matthieu Eyraud <eyraud@adacore.com>
+
+ * par_sco.adb (Set_Statement_Entry): Change sloc for dominance
+ marker.
+ (Traverse_One): Fix typo.
+ (Output_Header): Fix comment.
+
+2021-06-16 Richard Kenner <kenner@adacore.com>
+
+ * exp_unst.adb (Register_Subprogram): Don't look for aliases for
+ subprograms that are generic. Reorder tests for efficiency.
+
+2021-06-16 Eric Botcazou <ebotcazou@adacore.com>
+
+ * sem_util.adb (Incomplete_Or_Partial_View): Retrieve the scope of
+ the parameter and use it to find its incomplete view, if any.
+
+2021-06-16 Eric Botcazou <ebotcazou@adacore.com>
+
+ * freeze.adb (Check_No_Parts_Violations): Return earlier if the
+ type is elementary or does not come from source.
+
+2021-06-16 Bob Duff <duff@adacore.com>
+
+ * ghost.adb: Add another special case where full analysis is
+ needed. This bug is due to quirks in the way
+ Mark_And_Set_Ghost_Assignment works (it happens very early,
+ before name resolution is done).
+
+2021-06-16 Eric Botcazou <ebotcazou@adacore.com>
+
+ * sem_util.adb (Current_Entity_In_Scope): Reimplement.
+
+2021-06-16 Piotr Trojanek <trojanek@adacore.com>
+
+ * sem_ch8.adb (End_Scope): Remove extra parens.
+
+2021-06-16 Javier Miranda <miranda@adacore.com>
+
+ * exp_disp.adb (Build_Class_Wide_Check): Ensure that evaluation
+ of actuals is side effects free (since the check duplicates
+ actuals).
+
+2021-06-16 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_res.adb (Resolve_Raise_Expression): Apply Ada_2020 rules
+ concerning the need for parentheses around Raise_Expressions in
+ various contexts.
+
+2021-06-16 Piotr Trojanek <trojanek@adacore.com>
+
+ * sem_ch13.adb (Validate_Unchecked_Conversion): Move detection
+ of generic types before switching to their private views; fix
+ style in using AND THEN.
+
+2021-06-16 Arnaud Charlet <charlet@adacore.com>
+
+ * sem_ch3.adb (Analyze_Component_Declaration): Do not special
+ case raise expressions.
+
+2021-06-16 Sergey Rybin <rybin@adacore.com>
+
+ * doc/gnat_ugn/building_executable_programs_with_gnat.rst:
+ Instead of referring to the formatting of the Ada examples in
+ Ada RM add use the list of checks that are actually performed.
+ * gnat_ugn.texi: Regenerate.
+
+2021-06-16 Eric Botcazou <ebotcazou@adacore.com>
+
+ * initialize.c: Do not include vxWorks.h and fcntl.h from here.
+ (__gnat_initialize) [__MINGW32__]: Remove #ifdef and attribute
+ (__gnat_initialize) [init_float]: Delete.
+ (__gnat_initialize) [VxWorks]: Likewise.
+ (__gnat_initialize) [PA-RISC HP-UX 10]: Likewise.
+ * runtime.h: Add comment about vxWorks.h include.
+
+2021-06-16 Eric Botcazou <ebotcazou@adacore.com>
+
+ * libgnat/s-except.ads (ZCX_By_Default): Delete.
+ (Require_Body): Likewise.
+ * libgnat/s-except.adb: Replace body with pragma No_Body.
+
+2021-06-15 Steve Baird <baird@adacore.com>
+
+ * exp_util.adb (Kill_Dead_Code): Generalize the existing
+ handling of if statements to handle case statements similarly.
+
+2021-06-15 Eric Botcazou <ebotcazou@adacore.com>
+
+ * raise.h (_gnat_builtin_longjmp): Delete.
+ (set_gnat_exit_status): Likewise.
+
+2021-06-15 Piotr Trojanek <trojanek@adacore.com>
+
+ * exp_util.adb (Possible_Side_Effect_In_SPARK): Handle component
+ declaration just like full type and subtype declarations.
+
+2021-06-15 Yannick Moy <moy@adacore.com>
+
+ * errout.adb (First_And_Last_Node): Also apply to arbitrary late
+ declarations, not only subprogram specs.
+
+2021-06-15 Bob Duff <duff@adacore.com>
+
+ * sem_ch3.adb (Make_Class_Wide_Type): Make sure all the calls to
+ Reinit_Field_To_Zero are for the correct Ekinds.
+
+2021-06-15 Bob Duff <duff@adacore.com>
+
+ * aspects.ads (No_Task_Parts): New aspect.
+ * snames.ads-tmpl: Add the aspect name.
+ * exp_ch6.adb (Might_Have_Tasks): Return False if this is a
+ class-wide type whose specific type has No_Task_Parts.
+ * freeze.adb (Check_No_Parts_Violations): This is an adaptation
+ of the procedure formerly known as
+ Check_No_Controlled_Parts_Violations, which now supports both
+ No_Controlled_Parts and No_Task_Parts. It takes a parameter
+ indicating which aspect is being checked.
+ (Freeze_Entity): Call Check_No_Parts_Violations for both
+ aspects.
+ * sem_ch13.adb (Analyze_Aspect_Specifications): The code for
+ Aspect_No_Controlled_Parts already works as is with
+ Aspect_No_Task_Parts.
+ * libgnat/a-iteint.ads: Add No_Task_Parts aspect to the two
+ iterator iterfaces.
+ * doc/gnat_rm/implementation_defined_aspects.rst: Add
+ documentation for the No_Task_Parts aspect.
+ * gnat_rm.texi: Regenerate.
+
+2021-06-15 Arnaud Charlet <charlet@adacore.com>
+
+ * exp_unst.adb (Unnest_Subprogram.Build_Table.Visit_Node): Fix
+ handling of scopes for subprogram calls.
+
+2021-06-15 Piotr Trojanek <trojanek@adacore.com>
+
+ * sem_prag.adb: Fix typos in comments related to access types.
+ * sem_util.adb (Is_Access_Variable): Stronger condition.
+
+2021-06-15 Arnaud Charlet <charlet@adacore.com>
+
+ * Make-generated.in: Add rule to copy runtime files needed
+ during stage1.
+ * raise.c: Remove obsolete symbols used during bootstrap.
+ * gcc-interface/Make-lang.in: Do not use libgnat sources during
+ stage1.
+ (GNAT_ADA_OBJS, GNATBIND_OBJS): Split in two parts, the common
+ part and the part only used outside of stage1.
+ (ADA_GENERATED_FILES): Add runtime files needed during bootstrap
+ when recent APIs are needed.
+ (ada/b_gnatb.adb): Remove prerequisite.
+ * gcc-interface/system.ads: Remove obsolete entries.
+
+2021-06-15 Eric Botcazou <ebotcazou@adacore.com>
+
+ * raise-gcc.c (__gnat_personality_seh0): Use PERSONALITY_FUNCTION.
+
+2021-06-15 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_util.adb (Is_Confirming): Separate the handling of
+ Implicit_Dereference, for which no pragma is generated but which
+ is already checked for legality in Sem_Ch13, including renamed
+ discriminants in a derived type.
+ (Is_Confirming, Same_Name): For expanded names, only check
+ matching of selector, because prefix may correspond to original
+ and derived types with different names and/or scopes. Semantic
+ checks on aspect expression have already verified its legality.
+ Add comments regarding possible gaps in RM description of the
+ feature.
+
+2021-06-15 Gary Dismukes <dismukes@adacore.com>
+
+ * freeze.adb (Freeze_Subprogram): Don't propagate conventions
+ Intrinsic or Entry to anonymous access-to-subprogram types
+ associated with subprograms having those conventions. Update
+ related comment.
+ * sem_attr.adb (Resolve_Attribute, Attribute_*Access): Remove
+ special-case warning code for cases where a called subprogram
+ has convention Intrinsic as well as its formal's type (the
+ expected type for the Access attribute), since this case can no
+ longer occur.
+
+2021-06-15 Piotr Trojanek <trojanek@adacore.com>
+
+ * exp_imgv.adb (Expand_User_Defined_Enumeration_Image): Fix
+ typos.
+
+2021-06-15 Bob Duff <duff@adacore.com>
+
+ * einfo-utils.adb (Known_Component_Size,
+ Known_Static_Component_Size, Unknown_Component_Size): Use
+ Implementation_Base_Type instead of Base_Type.
+
+2021-06-15 Bob Duff <duff@adacore.com>
+
+ * gen_il-gen-gen_entities.adb (E_Loop_Parameter): Add
+ Interface_Name field.
+
+2021-06-15 Bob Duff <duff@adacore.com>
+
+ * sem_cat.adb (Check_Non_Static_Default_Expr): Allow nonstatic
+ expression in predefined unit with pragma Preelaborate.
+
+2021-06-15 Yannick Moy <moy@adacore.com>
+
+ * doc/gnat_rm/intrinsic_subprograms.rst: More details on shift
+ operations for signed types. Also add the missing Import and
+ Convention on the example.
+ * gnat_rm.texi: Regenerate.
+
+2021-06-15 Eric Botcazou <ebotcazou@adacore.com>
+
+ * raise-gcc.c: Include <cstdarg> instead of <stdarg.h> in C++.
+ Include <stdbool.h> and unconditionally <stdlib.h> in C.
+
+2021-06-15 Piotr Trojanek <trojanek@adacore.com>
+
+ * sem_util.ads (Find_Overlaid_Entity): Simplify comment for
+ spec.
+ * sem_util.adb (Find_Overlaid_Entity): Remove defensive code
+ from body.
+
+2021-06-15 Eric Botcazou <ebotcazou@adacore.com>
+
+ * argv.c: Add include of <stdlib.h> for the runtime.
+ (gnat_argv): Change type to char ** and initialize to NULL.
+ (gnat_envp): Likewise.
+ * argv-lynxos178-raven-cert.c: Add include of <stdlib.h>.
+ (gnat_argv): Change type to char ** and initialize to NULL.
+ (gnat_envp): Likewise.
+
+2021-06-15 Bob Duff <duff@adacore.com>
+
+ * gen_il-gen.adb (Setter_Needs_Parent): Add missing
+ Then_Actions. Fix self-contradictory comment.
+ * exp_util.adb (Insert_Actions): Minor comment improvments.
+
+2021-06-15 Arnaud Charlet <charlet@adacore.com>
+
+ * sem_eval.adb (Eval_Logical_Op, Test_Expression_Is_Foldable):
+ Add support for folding more "and"/"or" expressions.
+ * exp_util.adb (Side_Effect_Free): Fix handling of membership
+ tests.
+
+2021-06-15 Piotr Trojanek <trojanek@adacore.com>
+
+ * sem_res.adb (Resolve_Actual): Replace repeated calls to
+ "Etype (F)" with references to "F_Typ", which keeps the results
+ of exactly that call.
+
+2021-06-15 Bob Duff <duff@adacore.com>
+
+ * gen_il-gen.adb (To_Bit_Offset): Use 'Base to avoid overflow in
+ computations in Last_Bit when Offset = 'Last.
+ (Choose_Offset): Give a better error message when we run out of
+ fields. In particular, point out that
+ Gen_IL.Internals.Bit_Offset'Last needs to be increased.
+
+2021-06-15 Bob Duff <duff@adacore.com>
+
+ * atree.ads, einfo-utils.ads, einfo-utils.adb, fe.h, gen_il.adb,
+ gen_il.ads, gen_il-gen-gen_entities.adb,
+ gen_il-gen-gen_nodes.adb, sem_ch12.adb, sem_ch3.adb,
+ sem_util.adb, sinfo-utils.ads, treepr.adb, types.ads: Clean up
+ ??? comments and other comments.
+ * atree.adb: Clean up ??? comments and other comments.
+ (Validate_Node): Fix bug: "Off_0 (N) < Off_L (N)"
+ should be "Off_0 (N) <= Off_L (N)".
+ * gen_il-gen.adb, gen_il-gen.ads: Clean up ???
+ comments and other comments. Add support for getter-specific
+ and setter-specific preconditions. Detect the error of putting
+ a field in the wrong subrange. Misc cleanup.
+ (Node_Field vs. Entity_Field): Clean up Nmake. Improve
+ comments.
+ * gen_il-utils.ads: Misc cleanup. Move...
+ * gen_il-internals.ads: ... here.
+ * gen_il-utils.adb: Misc cleanup. Move...
+ * gen_il-internals.adb: ... here.
+ * gen_il-fields.ads: Move Was_Default_Init_Box_Association,
+ which was in the wrong subrange. Add comments. Misc cleanup.
+ * gen_il-types.ads: Add Named_Access_Kind.
+ * sinfo-cn.adb: Clean up ??? comments and other comments.
+ Remove redundant assertions.
+ * einfo.ads, sinfo.ads: Clean up ??? comments and other
+ comments. Remove all the comments indicating field offsets.
+ These are obsolete now that Gen_IL computes the offsets
+ automatically.
+
+2021-06-15 Arnaud Charlet <charlet@adacore.com>
+
+ * einfo.ads, errout.adb, errout.ads, exp_aggr.adb, exp_ch5.adb,
+ exp_ch6.adb, exp_ch8.adb, exp_ch9.adb, exp_imgv.adb,
+ exp_put_image.adb, fe.h, impunit.adb, impunit.ads,
+ libgnat/a-cobove.ads, libgnat/a-convec.ads, opt.ads,
+ par-ch12.adb, par-ch3.adb, par-ch4.adb, par-ch5.adb,
+ par-ch6.adb, par-prag.adb, par-util.adb, scans.ads, scng.adb,
+ sem_aggr.adb, sem_attr.adb, sem_ch10.adb, sem_ch12.adb,
+ sem_ch13.adb, sem_ch3.adb, sem_ch5.adb, sem_ch6.adb,
+ sem_ch8.adb, sem_elab.adb, sem_eval.adb, sem_prag.adb,
+ sem_res.adb, sem_type.adb, sem_util.adb, sem_util.ads,
+ sinfo.ads, snames.ads-tmpl, sprint.adb, switch-c.adb, usage.adb,
+ doc/gnat_ugn/building_executable_programs_with_gnat.rst,
+ doc/gnat_rm/implementation_defined_aspects.rst,
+ gcc-interface/trans.c: Update all references to Ada 2020 to Ada
+ 2022. Rename pragma Ada_2020 to Ada_2022. Update documentation
+ accordingly.
+ * gnat_ugn.texi, gnat_rm.texi: Regenerate.
+
+2021-06-15 Steve Baird <baird@adacore.com>
+
+ * sem_util.adb (Gather_Components): Factor the test that was
+ already being used to govern emitting a pre-Ada_2020 error
+ message into an expression function,
+ OK_Scope_For_Discrim_Value_Error_Messages. Call that new
+ function in two places: the point where the same test was being
+ performed previously, and in governing emission of a newer
+ Ada_2020 error message. In both cases, the out-mode parameter
+ Gather_Components.Report_Errors is set to True even if no error
+ messages are generated within Gather_Components.
+ * sem_util.ads: Correct a comment.
+
+2021-06-15 Richard Kenner <kenner@adacore.com>
+
+ * sem_ch3.adb (Array_Type_Declaration, Build_Derived_Type):
+ Reinitialize Stored_Constraint when needed.
+ (Set_Modular_Size): Likewise.
+ * atree.adb: (Check_Vanishing_Fields): Add node id to debugging
+ information.
+
+2021-06-15 Bob Duff <duff@adacore.com>
+
+ * sem_util.adb (Propagate_Invariant_Attributes): Call
+ Set_Has_Own_Invariants on the base type, because these are
+ Base_Type_Only. The problem is that the base type of a type is
+ indeed a base type when Set_Base_Type is called, but then the
+ type is mutated into a subtype in rare cases.
+ * atree.ads, atree.adb (Is_Entity): Export. Correct subtype of
+ parameter in body.
+ * gen_il-gen.adb: Improve getters so that "Pre => ..." can refer
+ to the value of the field. Put Warnings (Off) on some with
+ clauses that are not currently used, but might be used by such
+ Pre's.
+
+2021-06-15 Piotr Trojanek <trojanek@adacore.com>
+
+ * sem_ch3.adb (Access_Type_Declaration): Add comments to explain
+ the ordering of Mutate_Kind and Set_Directly_Designated_Type;
+ remove temporary setting of Ekind to E_Access_Type for building
+ _master objects, since now the Ekind is already set to its final
+ value. Move repeated code into Setup_Access_Type routine and use
+ it so that Process_Subtype is executed before mutating the kind
+ of the type entity.
+ * gen_il-gen-gen_entities.adb (Gen_Entities): Remove
+ Directly_Designated_Type from E_Void, E_Private_Record,
+ E_Limited_Private_Type and Incomplete_Kind; now it only belongs
+ to Access_Kind entities.
+ * sem_util.adb: Minor reformatting.
+
+2021-06-03 Eric Botcazou <ebotcazou@adacore.com>
+
+ * gcc-interface/decl.c (gnat_to_gnu_entity) <E_Array_Type>: Add PAT
+ local constant and use it throughout. If it is set, use a ref-all
+ pointer type for the pointer-to-array field of the fat pointer type.
+ <E_Array_Subtype>: Add PAT local constant and use it throughout.
+
+2021-05-26 Jakub Jelinek <jakub@redhat.com>
+
+ * init.c (__gnat_error_handler): Remove register keyword.
+
+2021-05-25 Martin Liska <mliska@suse.cz>
+
+ * doc/share/conf.py: Fix Sphinx 4.0.x error.
+
+2021-05-21 Piotr Trojanek <trojanek@adacore.com>
+
+ * gcc-interface/trans.c (Raise_Error_to_gnu): Add an assertion.
+
+2021-05-21 Eric Botcazou <ebotcazou@adacore.com>
+
+ * gcc-interface/utils.c (gnat_pushdecl): Fix typo in comment.
+ * gcc-interface/utils2.c (build_simple_component_ref): Build NULL_EXPR
+ if the offset of the field has overflowed.
+ (build_component_ref): Add gigi checking assertion that the reference
+ has been built and replace the discriminant check by a Program_Error.
+
+2021-05-21 Eric Botcazou <ebotcazou@adacore.com>
+
+ * gcc-interface/decl.c (gnat_to_gnu_entity) <E_Named_Integer>: Do
+ not pass default value in call to create_var_decl.
+ <E_Variable>: Likewise.
+ <E_Record_Subtype>: Both pass true for const_flag and false for
+ const_decl_allowed_p in call to create_var_decl.
+ Small tweaks in the generic record type case.
+ (elaborate_expression): Rename need_debug into need_for_debug and
+ adjust throughout.
+ (elaborate_expression_1): Likewise. Pass Needs_Debug_Info instead
+ of need_for_debug in call to create_var_decl.
+ (elaborate_expression_2): Likewise.
+ * gcc-interface/utils.c (maybe_pad_type): Pass false for
+ const_decl_allowed_p in call to create_var_decl.
+
+2021-05-21 Ghjuvan Lacambre <lacambre@adacore.com>
+
+ * gcc-interface/decl.c (gnat_to_gnu_entity): Replace ? with ??.
+ (gnat_to_gnu_param): Likewise.
+ (gnat_to_gnu_subprog_type): Likewise.
+ (warn_on_field_placement): Likewise.
+ (intrin_arglists_compatible_p): Likewise.
+ * gcc-interface/trans.c (Pragma_to_gnu): Likewise.
+ (gnat_to_gnu): Likewise.
+ (validate_unchecked_conversion): Likewise.
+ * gcc-interface/utils.c (maybe_pad_type): Likewise.
+
+2021-05-21 Eric Botcazou <ebotcazou@adacore.com>
+
+ * gcc-interface/decl.c (gnat_to_gnu_entity) <E_Array_Type>: Process
+ the implementation type of a packed type implemented specially.
+
+2021-05-21 Eric Botcazou <ebotcazou@adacore.com>
+
+ * gcc-interface/decl.c (gnat_to_gnu_subprog_type): Always translate
+ the Is_Pure flag into the "pure" attribute of GNU C.
+
+2021-05-21 Eric Botcazou <ebotcazou@adacore.com>
+
+ * gcc-interface/trans.c (Call_to_gnu): Restrict previous change
+ to bitfields whose size is not equal to the type size.
+ (gnat_to_gnu): Likewise.
+
+2021-05-21 Eric Botcazou <ebotcazou@adacore.com>
+
+ * gcc-interface/trans.c (Call_to_gnu): Minor tweaks.
+ (gnat_to_gnu_external): Likewise.
+ (Raise_Error_to_gnu): Return an empty statement list if there is a
+ condition and it is always false.
+ (gnat_to_gnu): Do not check for elaboration code a priori during the
+ translation but a posteriori instead.
+
+2021-05-21 Eric Botcazou <ebotcazou@adacore.com>
+
+ * gcc-interface/trans.c (gnat_to_gnu) <N_Simple_Return_Statement>:
+ Put a SLOC on the assignment from the return value to the return
+ object in the copy-in/copy-out case.
+
+2021-05-21 Eric Botcazou <ebotcazou@adacore.com>
+
+ * gcc-interface/decl.c (gnat_to_gnu_entity) <E_Variable>: Replace
+ CEIL_DIV_EXPR with EXACT_DIV_EXPR.
+ * gcc-interface/misc.c (gnat_type_max_size): Likewise.
+ * gcc-interface/utils.c (maybe_pad_type): Likewise.
+ (finish_record_type): Likewise. And always compute the unit size.
+
+2021-05-14 Martin Liska <mliska@suse.cz>
+
+ * doc/Makefile: Add gnat-style target.
+ * doc/share/conf.py: Likewise.
+ * doc/gnat-style.rst: New file.
+
+2021-05-12 Bob Duff <duff@adacore.com>
+
+ PR ada/100564
+ * atree.adb (Change_Node): Do not call Zero_Slots on a Node_Id
+ when the Nkind has not yet been set; call the other Zero_Slots
+ that takes a range of slot offsets. Call the new Mutate_Kind
+ that takes an Old_Size, for the same reason -- the size cannot
+ be computed without the Nkind.
+ (Mutate_Nkind): New function that allows specifying the Old_Size.
+ (Size_In_Slots): Assert that the Nkind has proper (nonzero) value.
+ * atree.ads: Minor reformatting.
+
+2021-05-12 Martin Liska <mliska@suse.cz>
+
+ * doc/share/conf.py: Do not use binary mode.
+ Do not use u' literals as Python3 uses unicode by default.
+
+2021-05-11 Martin Liska <mliska@suse.cz>
+
+ * gcc-interface/ada-tree.h (BUILT_IN_LIKELY): Use builtins
+ from COROUTINES.
+ (BUILT_IN_UNLIKELY): Likewise.
+
+2021-05-11 Eric Botcazou <ebotcazou@adacore.com>
+
+ * gnatvsn.adb (Version_String): Rename to...
+ (C_Version_String): ...this.
+ (Gnat_Version_String): Adjust to above renaming.
+ * version.c : Fix formatting glitches.
+
+2021-05-10 Martin Liska <mliska@suse.cz>
+
+ PR bootstrap/100506
+ * Make-generated.in: Replace version.c with ada/version.c.
+ * gcc-interface/Make-lang.in: Add version.o to GNAT1_C_OBJS and
+ GNATBIND_OBJS.
+ * gcc-interface/Makefile.in: Replace version.c with ada/version.c.
+ Add version.o to TOOLS_LIBS.
+ * gnatvsn.adb: Replace version_string with gnat_version_string.
+ * version.c: New file.
+
+2021-05-10 Eric Botcazou <ebotcazou@adacore.com>
+
+ * einfo-utils.ads (Classification Attributes): Add pragma Inline.
+ (Synthesized Attribute Functions): Move pragma Inline around.
+ (Type Representation Attribute Predicates): Likewise.
+ (Field Initialization Routines): Likewise.
+ (Miscellaneous Subprogram): Likewise.
+
+2021-05-10 Eric Botcazou <ebotcazou@adacore.com>
+
+ * atree.ads (Slot): Remove pragma Provide_Shift_Operators.
+ (Shift_Left): New intrinsic function.
+ (Shift_Right): Likewise.
+ * atree.adb (Get_1_Bit_Val): Use Natural instead of Integer.
+ (Get_2_Bit_Val): Likewise.
+ (Get_4_Bit_Val): Likewise.
+ (Get_8_Bit_Val): Likewise.
+ (Set_1_Bit_Val): Likewise.
+ (Set_2_Bit_Val): Likewise.
+ (Set_4_Bit_Val): Likewise.
+ (Set_8_Bit_Val): Likewise.
+
+2021-05-10 Eric Botcazou <ebotcazou@adacore.com>
+
+ * atree.adb (Zero_Slots): Remove obsolete comment and add header.
+
+2021-05-10 Eric Botcazou <ebotcazou@adacore.com>
+
+ * atree.h (Get_32_Bit_Field): Tidy up.
+ (Get_32_Bit_Field_With_Default): Likewise.
+
+2021-05-10 Eric Botcazou <ebotcazou@adacore.com>
+
+ * Make-generated.in (do_gen_il): Replace with...
+ (ada/stamp-gen_il): ...this. Do not copy files into generated/.
+
+2021-05-10 Martin Liska <mliska@suse.cz>
+
+ * gcc-interface/utils.c (def_builtin_1): Use startswith
+ function instead of strncmp.
+
+2021-05-07 Piotr Trojanek <trojanek@adacore.com>
+
+ * einfo-utils.adb (Is_Access_Object_Type): Use
+ Directly_Designated_Type.
+ (Is_Access_Subprogram_Type): Use Directly_Designated_Type.
+ (Set_Convention): Use plain Ekind.
+ * gen_il-gen-gen_entities.adb (Type_Kind): Use plain Ekind.
+ * sem_ch3.adb (Access_Type_Declaration): When seeing an illegal
+ completion with an access type don't attempt to decorate the
+ completion entity; previously the entity had its Ekind set to
+ E_General_Access_Type or E_Access_Type, but its Designated_Type
+ was empty, which caused a crash in freezing. (Actually, the
+ error recovery in the surrounding context is still incomplete,
+ e.g. we will crash when the illegal completion is an access to
+ an unknown identifier).
+
+2021-05-07 Bob Duff <duff@adacore.com>
+
+ * par_sco.adb: Align with/use clauses.
+ (Traverse_Declarations_Or_Statements): Minor comment fix.
+ * aspects.adb, atree.adb, atree.ads, checks.adb, comperr.adb,
+ contracts.adb, cstand.adb, debug_a.adb, einfo-utils.adb,
+ errout.adb, eval_fat.adb, exp_aggr.adb, expander.adb,
+ exp_atag.adb, exp_attr.adb, exp_cg.adb, exp_ch11.adb,
+ exp_ch12.adb, exp_ch13.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_code.adb, exp_dbug.adb, exp_disp.adb,
+ exp_dist.adb, exp_fixd.adb, exp_imgv.adb, exp_intr.adb,
+ exp_pakd.adb, exp_prag.adb, exp_put_image.adb, exp_sel.adb,
+ exp_smem.adb, exp_spark.adb, exp_strm.adb, exp_tss.adb,
+ exp_unst.adb, exp_util.adb, exp_util.ads, freeze.adb,
+ frontend.adb, ghost.adb, gnat1drv.adb, gnat_cuda.adb,
+ impunit.adb, inline.adb, itypes.adb, itypes.ads, layout.adb,
+ lib.adb, lib-load.adb, lib-writ.adb, lib-xref.adb,
+ lib-xref-spark_specific.adb, live.adb, nlists.adb, par.adb,
+ par-ch11.adb, par-ch3.adb, par-ch5.adb, par-ch6.adb, pprint.adb,
+ repinfo.adb, restrict.adb, rtsfind.adb, scil_ll.adb, scn.adb,
+ sem.adb, sem_aggr.adb, sem_attr.adb, sem_aux.adb, sem_case.adb,
+ sem_cat.adb, sem_ch10.adb, sem_ch11.adb, sem_ch12.adb,
+ sem_ch13.adb, sem_ch2.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_smem.adb,
+ sem_type.adb, sem_util.adb, sem_util.ads, sem_warn.adb,
+ sinfo-cn.adb, sinfo-utils.ads, sinput.adb, sinput-l.adb,
+ sprint.adb, style.adb, styleg.adb, tbuild.adb, tbuild.ads,
+ treepr.adb, uname.adb: Align with/use clauses.
+
+2021-05-07 Bob Duff <duff@adacore.com>
+
+ * atree.ads, atree.adb, gen_il-gen.ads: Fix comments and clean
+ up ??? marks. Rename Set_Ekind to be Mutate_Ekind.
+ * einfo.ads, sinfo.ads: Likewise. Change "definitive
+ definition" to "official definition", because the former sounds
+ redundant. Rename Set_Ekind to be Mutate_Ekind.
+ * checks.adb, contracts.adb, cstand.adb, exp_aggr.adb,
+ exp_attr.adb, exp_ch11.adb, exp_ch3.adb, exp_ch5.adb,
+ exp_ch6.adb, exp_ch7.adb, exp_ch9.adb, exp_disp.adb,
+ exp_dist.adb, exp_imgv.adb, exp_intr.adb, exp_prag.adb,
+ exp_unst.adb, exp_util.adb, gen_il-gen.adb, inline.adb,
+ lib-writ.adb, lib-xref-spark_specific.adb, sem_aggr.adb,
+ sem_ch10.adb, sem_ch11.adb, sem_ch12.adb, sem_ch13.adb,
+ sem_ch3.adb, sem_ch5.adb, sem_ch6.adb, sem_ch7.adb, sem_ch8.adb,
+ sem_ch9.adb, sem_dist.adb, sem_elab.adb, sem_prag.adb,
+ sem_util.adb: Rename Set_Ekind to be Mutate_Ekind.
+
+2021-05-07 Bob Duff <duff@adacore.com>
+
+ * atree.adb: Move nnd-related code from here, and leave a
+ comment pointing to sinfo-utils.adb.
+ * sinfo-utils.ads, sinfo-utils.adb: Move nnd-related code to
+ here.
+
+2021-05-07 Piotr Trojanek <trojanek@adacore.com>
+
+ * einfo.ads: Move Corresponding_Protected_Entry...
+ * sinfo.ads: ... here.
+ * exp_ch9.adb (Build_Entry_Body): Link procedure and entry
+ bodies.
+ * gen_il-fields.ads (Opt_Field_Enum): Add
+ Corresponding_Entry_Body field to nodes; remove
+ Corresponding_Protected_Entry field from entities.
+ * gen_il-gen-gen_entities.adb (Gen_Entities): Remove
+ Corresponding_Protected_Entry field from E_Void and
+ E_Subprogram_Body.
+ * gen_il-gen-gen_nodes.adb (Gen_Nodes): Add
+ Corresponding_Entry_Body field to N_Subprogram_Body.
+ * sem_ch6.adb (Analyze_Subprogram_Specification): Remove
+ manipulation of Ekind and Corresponding_Protected_Entry added as
+ part of the support for varsize-nodes.
+
+2021-05-07 Bob Duff <duff@adacore.com>
+
+ * sem_ch3.adb (Process_Incomplete_Dependents): Reset
+ Private_Dependents field to zero before calling Set_Ekind. Also
+ move Set_Etype to after Set_Ekind, because it's always best to
+ set the Ekind as early as possible.
+ * atree.adb: Improve debugging facilities for vanishing fields.
+
+2021-05-07 Eric Botcazou <ebotcazou@adacore.com>
+
+ * atree.ads (Slot): Change to modular type.
+ (Slot_1_Bit): Delete.
+ (Slot_2_Bit): Likewise.
+ (Slot_4_Bit): Likewise.
+ (Slot_8_Bit): Likewise.
+ (Slot_32_Bit): Likewise.
+ * atree.adb (Get_1_Bit_Val): Adjust to above change.
+ (Get_2_Bit_Val): Likewise.
+ (Get_4_Bit_Val): Likewise.
+ (Get_8_Bit_Val): Likewise.
+ (Get_32_Bit_Val): Likewise.
+ (Set_1_Bit_Val): Likewise.
+ (Set_2_Bit_Val): Likewise.
+ (Set_4_Bit_Val): Likewise.
+ (Set_8_Bit_Val): Likewise.
+ (Set_32_Bit_Val): Likewise.
+ (Print_Atree_Info): Likewise.
+ (Zero): Likewise.
+ * atree.h (Get_1_Bit_Field): Likewise.
+ (Get_2_Bit_Field): Likewise.
+ (Get_4_Bit_Field): Likewise.
+ (Get_8_Bit_Field): Likewise.
+ (Get_32_Bit_Field): Likewise.
+ (Get_32_Bit_Field_With_Default): Likewise.
+ * types.h (slot_1_bit): Delete.
+ (slot_2_bit): Likewise.
+ (slot_4_bit): Likewise.
+ (slot_8_bit): Likewise.
+ (slot_32_bit): Likewise.
+ (any_slot): Change to unsigned int.
+ (Slot_Size): New macro.
+
+2021-05-07 Eric Botcazou <ebotcazou@adacore.com>
+
+ * gcc-interface/gigi.h (enum standard_datatype): Remove
+ ADT_exception_data_name_id and add ADT_not_handled_by_others_name_id.
+ (exception_data_name_id): Delete.
+ (not_handled_by_others_name_id): New macro.
+ * gcc-interface/decl.c (gnat_to_gnu_entity) <E_Exception>: Remove old
+ kludge for exceptions.
+ <E_Record_Type>: Likewise.
+ (gnat_to_gnu_field): Force character type on Not_Handled_By_Others.
+ * gcc-interface/misc.c (gnat_argv): Change type to char **.
+ (gnat_init_options): Adjust accordingly.
+ * gcc-interface/trans.c (gigi): Set not_handled_by_others_name_id
+ and use it to set not_handled_by_others_decl.
+ (Exception_Handler_to_gnu_fe_sjlj): Fix indentation.
+
+2021-05-07 Eric Botcazou <ebotcazou@adacore.com>
+
+ * raise-gcc.c (__gnat_others_value): Remove const qualifier.
+ (__gnat_all_others_value): Likewise.
+ (__gnat_unhandled_others_value): Likewise.
+ (GNAT_OTHERS): Cast to Exception_Id instead of _Unwind_Ptr.
+ (GNAT_ALL_OTHERS): Likewise.
+ (GNAT_UNHANDLED_OTHERS): Likewise.
+ (Is_Handled_By_Others): Change parameter type to Exception_Id.
+ (Language_For): Likewise.
+ (Foreign_Data_For): Likewise.
+ (is_handled_by): Likewise. Adjust throughout, remove redundant
+ line and fix indentation.
+ * libgnat/a-exexpr.adb (Is_Handled_By_Others): Remove pragma and
+ useless qualification from parameter type.
+ (Foreign_Data_For): Likewise.
+ (Language_For): Likewise.
+
+2021-05-07 Eric Botcazou <ebotcazou@adacore.com>
+
+ * libgnat/s-stalib.ads (Exception_Data): Mark components as aliased.
+ * stand.ads (Standard_Entity_Type): Enhance comments.
+ * cstand.adb (Make_Component): Rename into...
+ (Make_Aliased_Component): ...this; set Is_Aliased and Is_Independent
+ flags on the component.
+ (Create_Standard): Adjust the types of the component of the record
+ Standard_Exception_Type and mark them as aliased.
+ * exp_ch11.adb (Expand_N_Exception_Declaration): Use OK
+ conversion to Standard_Address for Full_Name component, except
+ in CodePeer_Mode (set it to 0).
+ * exp_prag.adb (Expand_Pragma_Import_Or_Interface): Likewise.
+ * raise.h (struct Exception_Data): Change the type of Full_Name,
+ HTable_Ptr and Foreign_Data.
+
+2021-05-07 Eric Botcazou <ebotcazou@adacore.com>
+
+ * atree.h (Slots_Ptr): Change pointed-to type to any_slot.
+ * fe.h (Get_RT_Exception_Name): Change type of parameter.
+ * namet.ads (Name_Entry): Mark non-boolean components as aliased,
+ reorder the boolean components and add an explicit Spare component.
+ * namet.adb (Name_Enter): Adjust aggregate accordingly.
+ (Name_Find): Likewise.
+ (Reinitialize): Likewise.
+ * namet.h (struct Name_Entry): Adjust accordingly.
+ (Names_Ptr): Use correct type.
+ (Name_Chars_Ptr): Likewise.
+ (Get_Name_String): Fix declaration and adjust to above changes.
+ * types.ads (RT_Exception_Code): Add pragma Convention C.
+ * types.h (Column_Number_Type): Fix original type.
+ (slot): Rename union type to...
+ (any_slot): ...this and adjust assertion accordingly.
+ (RT_Exception_Code): New enumeration type.
+ * uintp.ads (Uint_Entry): Mark components as aliased.
+ * uintp.h (Uints_Ptr): Use correct type.
+ (Udigits_Ptr): Likewise.
+ * gcc-interface/gigi.h (gigi): Adjust name and type of parameter.
+ * gcc-interface/cuintp.c (UI_To_gnu): Adjust references to Uints_Ptr
+ and Udigits_Ptr.
+ * gcc-interface/trans.c (Slots_Ptr): Adjust pointed-to type.
+ (gigi): Adjust type of parameter.
+ (build_raise_check): Add cast in call to Get_RT_Exception_Name.
+
+2021-05-07 Eric Botcazou <ebotcazou@adacore.com>
+
+ * init.c (__gnat_raise_program_error): Fix parameter type.
+ (Raise_From_Signal_Handler): Likewise and mark as no-return.
+ * raise-gcc.c (__gnat_others_value): Fix type.
+ (__gnat_all_others_value): Likewise.
+ (__gnat_unhandled_others_value): Likewise.
+ * seh_init.c (Raise_From_Signal_Handler): Fix parameter type.
+ * libgnat/a-except.ads (Raise_From_Signal_Handler): Use convention C
+ and new symbol name, move declaration to...
+ (Raise_From_Controlled_Operation): Minor tweak.
+ * libgnat/a-except.adb (Raise_From_Signal_Handler): ...here.
+ * libgnat/a-exexpr.adb (bool): New C compatible boolean type.
+ (Is_Handled_By_Others): Use it as return type for the function.
+
+2021-05-07 Eric Botcazou <ebotcazou@adacore.com>
+
+ * errout.ads (Set_Identifier_Casing): Add pragma Convention C.
+ * eval_fat.ads (Rounding_Mode): Likewise.
+ (Machine): Add WARNING comment line.
+ * exp_code.ads (Clobber_Get_Next): Add pragma Convention C.
+ * fe.h (Compiler_Abort): Fix return type.
+ (Set_Identifier_Casing): Change type of parameters.
+ (Clobber_Get_Next): Change return type.
+ * gcc-interface/trans.c (gnat_to_gnu) <N_Code_Statement>: Add cast.
+
+2021-05-07 Eric Botcazou <ebotcazou@adacore.com>
+
+ * atree.h (Parent): Remove duplicate declaration.
+ (Get_1_Bit_Field): Also use INLINE specifier in the declaration,
+ fix formatting and use gcc_unreachable for the default case.
+ (Get_2_Bit_Field): Likewise.
+ (Get_4_Bit_Field): Likewise.
+ (Get_8_Bit_Field): Likewise.
+ (Get_32_Bit_Field): Likewise.
+ (Get_32_Bit_Field_With_Default): Likewise.
+
+2021-05-07 Bob Duff <duff@adacore.com>
+
+ * atree.ads, atree.adb: Major rewrite to support variable-sized
+ node types. Add pragmas Suppress and Assertion_Policy. We now
+ have an extra level of indirection: Node_Offsets is a table
+ mapping Node_Ids to the offset of the start of each node in
+ Slots. Slots is a table containing one or more contiguous slots
+ for each node. Each slot is a 32-bit unchecked union that can
+ contain any mixture of 1, 2, 4, 8, and 32-bit fields that fits.
+ The old low-level getters and setters (e.g. Flag123) are
+ removed.
+ * gen_il-fields.ads, gen_il-gen-gen_entities.adb,
+ gen_il-gen-gen_nodes.adb, gen_il-gen.adb, gen_il-gen.ads,
+ gen_il-main.adb, gen_il-types.ads, gen_il-utils.adb,
+ gen_il-utils.ads, gen_il.adb, gen_il.ads: New gen_il program
+ that generates various Ada and C++ files. In particular, the
+ following files are generated by gen_il: einfo-entities.adb
+ einfo-entities.ads, gnatvsn.ads, nmake.adb, nmake.ads,
+ seinfo.ads, seinfo_tables.adb, seinfo_tables.ads,
+ sinfo-nodes.adb, sinfo-nodes.ads, einfo.h, and sinfo.h.
+ * sinfo-utils.adb, sinfo-utils.ads, einfo-utils.adb,
+ einfo-utils.ads: New files containing code that needs to refer
+ to Sinfo.Nodes and Einfo.Entities. This code is mostly moved
+ here from Sinfo and Einfo to break cycles.
+ * back_end.adb: Pass node_offsets_ptr and slots_ptr to gigi,
+ instead of nodes_ptr and flags_ptr. The Nodes and Flags tables
+ no longer exist. (Note that gigi never used the Flags table.)
+ * sinfo-cn.ads (Change_Identifier_To_Defining_Identifier,
+ Change_Character_Literal_To_Defining_Character_Literal,
+ Change_Operator_Symbol_To_Defining_Operator_Symbol): Turn N into
+ an IN formal.
+ * sinfo-cn.adb: Update. Add assertions, which can be removed at
+ some point. Rewrite to use higher-level facilities. Make sure
+ vanishing fields are zeroed out. Add with/use for new packages.
+ * sem_util.adb: Remove "Assert(False)" immediately followed by
+ "raise Program_Error". Use higher-level facilities such as
+ Walk_Sinfo_Fields instead of depending on low-level Set_FieldN
+ routines that no longer exist. Use Get_Comes_From_Source_Default
+ instead of Default_Node.Comes_From_Source (Default_Node no
+ longer exists). Use Set_Basic_Convention instead of
+ Basic_Set_Convention. Add with/use for new packages.
+ * sem_util.ads: The Convention field had getter Convention and
+ setter Basic_Set_Convention. Make that more uniform: there is
+ now a field called Basic_Convention, with Basic_Convention and
+ Set_Basic_Convention as getter/setter, and write Convention and
+ Set_Convention here.
+ * nlists.adb: Rewrite to use abstractions, rather then depending
+ on low-level implementation details of Atree. Necessary because
+ those details have changed. Add with/use for new packages.
+ * sem_ch12.adb: Use higher-level facilities such as
+ Walk_Sinfo_Fields instead of depending on low-level Set_FieldN
+ routines that no longer exist. Add with/use for new packages.
+ * exp_cg.adb, sem_ch10.adb, sem_ch4.adb, sem_eval.adb,
+ sem_prag.adb, sem_warn.adb: Change expanded names to refer to
+ the new packages for things that moved. Add with/use for new
+ packages.
+ * sem_ch3.adb: Likewise. Reinitialize vanishing fields.
+ * exp_disp.adb: Likewise. Remove failing assertion.
+ * sinfo.ads, einfo.ads: Remove code that is now generated into
+ Sinfo.Nodes and Einfo.Entities.
+ * sinfo.adb, einfo.adb: Replace bodies with "pragma No_Body;".
+ We should delete these at some point, but No_Body makes make
+ files easier. Some code is moved to Sinfo.Nodes, Einfo.Entities,
+ Sinfo.Utils, and Einfo.Utils. Some is no longer necessary.
+ * treepr.adb: Rewrite to use new tables. We no longer need
+ treeprs.ads.
+ * treepr.ads: Add comment.
+ * types.ads: Move types Component_Alignment_Kind and
+ Float_Rep_Kind here.
+ * atree.h: Major update to match atree.ads changes. Add slot
+ types, for use by getters/setters.
+ * types.h: Move types Component_Alignment_Kind and
+ Float_Rep_Kind here.
+ * fe.h: Rewrite to deal with code that has changed or moved from
+ Atree, Sinfo, Einfo.
+ * nlists.h: Move some code to fe.h.
+ * alloc.ads: Split Nodes_* constants into Node_Offsets and
+ Slots, because Atree has two separate tables. Increase values.
+ Remove Nodes_Release_Threshold. Improve comment.
+ * debug.adb, gnat1drv.adb: Remove obsolete gnatd.A and gnatd.N
+ switches. Add with/use for new packages.
+ * opt.ads: Minor comment fix.
+ * aspects.adb, checks.adb, comperr.adb, contracts.adb,
+ cstand.adb, debug_a.adb, errout.adb, eval_fat.adb, exp_aggr.adb,
+ exp_atag.adb, exp_attr.adb, exp_ch11.adb, exp_ch12.adb,
+ exp_ch13.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_code.adb, exp_dbug.adb, exp_dist.adb, exp_fixd.adb,
+ exp_imgv.adb, exp_intr.adb, exp_pakd.adb, exp_prag.adb,
+ exp_put_image.adb, exp_sel.adb, exp_smem.adb, exp_spark.adb,
+ exp_strm.adb, exp_tss.adb, exp_unst.adb, exp_util.adb,
+ exp_util.ads, expander.adb, freeze.adb, frontend.adb,
+ get_targ.ads, ghost.adb, gnat_cuda.adb, impunit.adb, inline.adb,
+ itypes.adb, itypes.ads, layout.adb, lib.adb, lib-load.adb,
+ lib-writ.adb, lib-xref.adb, lib-xref.ads,
+ lib-xref-spark_specific.adb, live.adb, par.adb, par_sco.adb,
+ pprint.adb, repinfo.adb, restrict.adb, rtsfind.adb, scil_ll.adb,
+ scn.adb, sem.adb, sem.ads, sem_aggr.adb, sem_attr.adb,
+ sem_aux.adb, sem_case.adb, sem_cat.adb, sem_ch11.adb,
+ sem_ch13.adb, sem_ch2.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_intr.adb, sem_mech.adb, sem_res.adb, sem_scil.adb,
+ sem_smem.adb, sem_type.adb, set_targ.ads, sinput.adb,
+ sinput-l.adb, sprint.adb, style.adb, styleg.adb, tbuild.adb,
+ tbuild.ads, uname.adb: Add with/use for new packages.
+ * libgnat/a-stoubu.adb, libgnat/a-stouut.adb: Simplify to ease
+ bootstrap.
+ * libgnat/a-stobfi.adb, libgnat/a-stoufi.adb (Create_File,
+ Create_New_File): Create file in binary format, to avoid
+ introducing unwanted text conversions on Windows. Simplify to
+ ease bootstrap.
+ * libgnat/a-stteou__bootstrap.ads: New.
+ * ceinfo.adb, csinfo.adb, nmake.adt, treeprs.adt, xeinfo.adb,
+ xnmake.adb, xsinfo.adb, xtreeprs.adb: Delete.
+ * Make-generated.in: Build and run the gen_il program to
+ generate files. The files are generated in the ada/gen_il
+ subdirectory, and then moved up to ada. We rely on gnatmake (as
+ opposed to make) to build the gen_il program efficiently (i.e.
+ don't do anything if the sources didn't change).
+ * gcc-interface/Makefile.in (ADAFLAGS): Add -gnatU.
+ (GNATMAKE_OBJS): Add new object files.
+ (GENERATED_FILES_FOR_TOOLS): New variable.
+ (../stamp-tools): Create a link for all
+ GENERATED_FILES_FOR_TOOLS.
+ * gcc-interface/Make-lang.in (GNAT_ADA_OBJS): Add new object
+ files. Remove ada/treeprs.o.
+ (GNATBIND_OBJS): Add new object files.
+ (ada.mostlyclean): Remove ada/sdefault.adb and add
+ ada/stamp-gen_il.
+ (ada.maintainer-clean): Remove ada/treeprs.ads.
+ (update-sources): Remove obsolete target.
+ (ada_generated_files): Rename to...
+ (ADA_GENERATED_FILES): ... this. Add new source files. Add
+ comment.
+ * gcc-interface/trans.c: Remove obsolete Nodes_Ptr and
+ Flags_ptr. Add Node_Offsets_Ptr and Slots_Ptr, which point to
+ the corresponding tables in Atree.
+ * gcc-interface/gigi.h (gigi): New parameters for initializing
+ Node_Offsets_Ptr and Slots_Ptr.
+ * gcc-interface/decl.c: Numeric_Kind,
+ Discrete_Or_Fixed_Point_Kind, and Record_Kind were
+ nonhierarchical, and were therefore removed for simplicity.
+ Replace uses with calls to Is_In_... functions.
+
+2021-05-07 Ed Schonberg <schonberg@adacore.com>
+
+ * exp_ch4.adb (Unconstrained_UU_In_Component_Declaration): A
+ component declaration whose subtype indication is an entity name
+ without an explicit constraint is an Unchecked_Union type only
+ if the entity has an unconstrained nominal subtype (record type
+ or private type) whose parent type is an Unchecked_Union.
+
+2021-05-07 Piotr Trojanek <trojanek@adacore.com>
+
+ * sem_res.adb (Flag_Object): Ignore prefixes of attribute
+ Address.
+
+2021-05-07 Yannick Moy <moy@adacore.com>
+
+ * opt.ads: Update comment for Warn_On_Suspicious_Modulus_Value.
+ * sem_res.adb (Resolve_Unary_Op): Generate warning.
+ * usage.adb: Refine doc for -gnatw.m/M switch.
+ * doc/gnat_ugn/building_executable_programs_with_gnat.rst:
+ Update doc on -gnatw.m switch.
+ * gnat_ugn.texi: Regenerate.
+
+2021-05-07 Piotr Trojanek <trojanek@adacore.com>
+
+ * sem_res.adb (Flag_Object): Replace chained IF with a CASE;
+ remove repeated calls to Entity; do not traverse into
+ N_Identifier and N_Expanded_Name, because only need to examine
+ their Entity field anyway.
+
+2021-05-07 Piotr Trojanek <trojanek@adacore.com>
+
+ * sem_ch4.adb (Analyze_Call): Remove call to End_Interp_List.
+ (Process_Overloaded_Indexed_Component): Remove call to
+ End_Interp_List.
+ * sem_util.adb (Insert_Explicit_Dereference): Remove call to
+ End_Interp_List.
+ * sem_type.ads (End_Interp_List): Remove.
+ * sem_type.adb (Add_Entry): The guard against duplicate entries
+ is now checked before other conditions, so that EXIT statements
+ do not bypass this guard.
+ (End_Interp_List): Remove.
+
+2021-05-07 Ed Schonberg <schonberg@adacore.com>
+
+ * exp_util.adb (Remove_Init_Call): If a simple initialization
+ call is present, and the next statement is an initialization
+ block (that contains a call to a Deep_ Initialize routine),
+ remove the block as well, and insert the first initialization
+ call in it, in case it is needed for later relocation.
+
+2021-05-07 Gary Dismukes <dismukes@adacore.com>
+
+ * errout.ads (Size_Too_Small_Message): Remove low-value ???
+ comment.
+ * exp_util.ads: Remove ??? in part of overall package comments
+ and restructure comment to clarify.
+ (Duplicate_Subexpr): Remove ??? comment that seems unnecessary.
+ * sem_ch3.ads (Analyze_Declarations): Remove two parenthesized
+ ??? comments and add more description of the procedure's
+ actions.
+ (Get_Discriminant_Value): Remove ??? comment requesting more
+ documentation, expanding description of the function's actions.
+ * sem_disp.ads (Check_Operation_From_Incomplete_Type): Add more
+ semantic description of the procedure and remove ??? comment
+ requesting such.
+ (Propagate_Tag): Refine comment to indicate meaning of formal
+ parameters and generally improve the spec comment (and remove
+ ??? comment asking about the parameters).
+
+2021-05-07 Arnaud Charlet <charlet@adacore.com>
+
+ * sem_eval.adb (Fold_Shift): Fix computation of Shift_Left
+ resulting in negative signed values.
+
+2021-05-07 Eric Botcazou <ebotcazou@adacore.com>
+
+ * sem_util.ads (Defining_Entity): Remove Empty_On_Errors parameter.
+ (Defining_Entity_Or_Empty): New function.
+ * sem_util.adb (Defining_Entity): Move bulk of implementation to...
+ (Defining_Entity_Or_Empty): ...here. Do not raise Program_Error.
+ (Innermost_Master_Scope_Depth): Call Defining_Entity_Or_Empty.
+
+2021-05-07 Justin Squirek <squirek@adacore.com>
+
+ * aspects.ads: Add entries to register
+ Aspect_No_Controlled_Parts.
+ * freeze.adb (Check_No_Controlled_Parts_Violations): Added to
+ check requirements of aspect No_Controlled_Parts after a type
+ has been frozen.
+ (Freeze_Entity): Add call to
+ Check_No_Controlled_Parts_Violations.
+ (Find_Aspect_No_Controlled_Parts): Created to obtain the aspect
+ specification for No_Controlled_Parts on a given type when
+ present.
+ (Find_Aspect_No_Controlled_Parts_Value): Protect against invalid
+ value.
+ (Has_Aspect_No_Controlled_Parts): Created as a prediate function
+ to check if No_Controlled_Parts has been specified on a type for
+ Get_Anacestor_Types_With_Specification.
+ (Get_Aspect_No_Controlled_Parts_Value): Created to obtain the
+ value of the aspect No_Controlled_Parts when specified on a
+ given type.
+ (Get_Generic_Formal_Types_In_Hierarchy): Created to collect
+ formal types in a given type's hierarchy.
+ (Get_Types_With_Aspect_In_Hierarchy): Created to collect types
+ in a given type's hierarchy with No_Controlled_Parts specified.
+ * sem_ch13.adb (Analyze_One_Aspect): Add processing for
+ No_Controlled_Parts, and fix error in check for allowed pragmas
+ for formal types.
+ (Check_Expr_Is_OK_Static_Expression): Created to enforce
+ checking of static expressions in the same vein as
+ Analyze_Pragma.Check_Expr_OK_Static_Expression.
+ * sem_util.adb (Collect_Types_In_Hierarchy): Created to collect
+ types in a given type's hierarchy that match a given predicate
+ function.
+ * sem_util.ads: Fix typo.
+ * snames.ads-tmpl: Add entry for No_Controlled_Parts.
+
+2021-05-07 Eric Botcazou <ebotcazou@adacore.com>
+
+ * libgnat/s-fatgen.adb (Scaling): Raise Constraint_Error in the
+ overflow case when T'Machine_Overflows is True.
+
+2021-05-07 Bob Duff <duff@adacore.com>
+
+ * libgnat/a-conhel.adb (TC_Check): Move the Assert into the
+ 'if'.
+
+2021-05-07 Frederic Konrad <konrad@adacore.com>
+
+ * sigtramp-vxworks-target.inc: Use a local label for the TOC.
+
+2021-05-07 Claire Dross <dross@adacore.com>
+
+ * exp_ch4.adb (Has_Inferable_Discriminants): Moved to Sem_Util.
+ * sem_util.ads, sem_util.adb (Has_Inferable_Discriminants):
+ Moved from Exp_Ch4.
+
+2021-05-07 Ed Schonberg <schonberg@adacore.com>
+
+ * exp_util.adb (Build_Class_Wide_Expression, Replace_Entity):
+ Add guard to verify that the enclosing pragma is a precondition.
+
+2021-05-06 Javier Miranda <miranda@adacore.com>
+
+ * exp_disp.adb (Build_Class_Wide_Check): Extending the
+ functionality of this routine to climb to the ancestors
+ searching for the enclosing overridden dispatching primitive
+ that has a class-wide precondition to generate the check.
+
+2021-05-06 Piotr Trojanek <trojanek@adacore.com>
+
+ * sem_ch3.adb (Constraint_Index): Remove redundant problematic
+ analysis.
+
+2021-05-06 Arnaud Charlet <charlet@adacore.com>
+
+ * exp_unst.adb (Note_Uplevel_Bound): Exclude
+ E_Enumeration_Literal.
+
+2021-05-06 Arnaud Charlet <charlet@adacore.com>
+
+ * exp_ch4.adb (Expand_N_If_Expression):
+ Apply_Arithmetic_Overflow_Check will not deal with
+ Then/Else_Actions so skip minimizing overflow checks if any
+ actions are present.
+
+2021-05-06 Boris Yakobowski <yakobowski@adacore.com>
+
+ * gnat1drv.adb (Adjust_Global_Switches): Simplify logic.
+
+2021-05-06 Arnaud Charlet <charlet@adacore.com>
+
+ * libgnat/i-c.ads (bool): New type.
+ * libgnat/i-cexten.ads, libgnat/i-cexten__128.ads (bool): Now
+ a subtype of Interfaces.C.bool.
+ * libgnarl/s-interr__vxworks.adb (Interrupt_Manager): Qualify
+ False.
+ * libgnarl/s-interr.adb, libgnarl/s-interr__hwint.adb,
+ libgnarl/s-tasini.adb, libgnarl/s-tasren.adb,
+ libgnarl/s-tassta.adb, libgnarl/s-tpobmu.adb,
+ libgnarl/s-tpobop.adb, libgnarl/s-tpopmo.adb: Replace
+ Assert (False) by Assert (Standard.False).
+
+2021-05-06 Ghjuvan Lacambre <lacambre@adacore.com>
+
+ * make.adb (Compute_Executable): Document parameter.
+
+2021-05-06 Eric Botcazou <ebotcazou@adacore.com>
+
+ * libgnat/s-fatgen.adb (Scaling): Use single handling of
+ underflow. Add pragma Annotate.
+
+2021-05-06 Ghjuvan Lacambre <lacambre@adacore.com>
+
+ * sem_eval.adb (Is_OK_Static_Subtype): Call Is_Static_Subtype,
+ remove redundant checks.
+
+2021-05-06 Piotr Trojanek <trojanek@adacore.com>
+
+ * sem_res.adb (First_Last_Ref): Simplify "if [condition] then
+ return True" in "return [condition]".
+ (Resolve_Range): Remove calls appearing in IF condition from the
+ THEN statements.
+
+2021-05-06 Piotr Trojanek <trojanek@adacore.com>
+
+ * sem_case.adb (Missing_Choice): Fix typo in comment.
+ (Lit_Of): Simplify with Make_Character_Literal.
+ (Check_Choices): Remove extra spaces in parameter
+ specifications.
+ * sem_case.ads: Same reformatting.
+
+2021-05-06 Ed Schonberg <schonberg@adacore.com>
+
+ * exp_aggr.adb (Expand_Array_Aggregate): If the expression in an
+ Others_Clause has not been analyzed because previous analysis of
+ the enclosing aggregate showed the clause to be ineffective i.e.
+ cover a null range, analyze it now to detect a possible type
+ illegality.
+
+2021-05-06 Eric Botcazou <ebotcazou@adacore.com>
+
+ * libgnat/s-fatgen.adb (Scaling): Fix off-by-one bug for underflow.
+
+2021-05-06 Arnaud Charlet <charlet@adacore.com>
+
+ * sem_ch6.adb (Is_Inline_Pragma): Protect against N not being a
+ list member in both branches.
+
+2021-05-06 Piotr Trojanek <trojanek@adacore.com>
+
+ * libgnat/a-cofove.adb (Insert_Space): Remove hardcoded pragma
+ Warnings.
+
+2021-05-06 Piotr Trojanek <trojanek@adacore.com>
+
+ * sem_ch4.adb (Analyze_Selected_Component): Remove explicit call
+ to Set_Raises_Constraint_Error on statically missing component.
+ * sem_eval.adb (Eval_Arithmetic_Op): Likewise for static
+ divisions by integer and real zeros.
+ * sem_util.adb (Apply_Compile_Time_Constraint_Error): Call
+ Set_Raises_Constraint_Error before exiting early in GNATprove
+ mode.
+
+2021-05-06 Justin Squirek <squirek@adacore.com>
+
+ * checks.adb (Make_Discriminant_Constraint_Check): Add check for
+ null when the type being converted is an access type.
+
+2021-05-06 Arnaud Charlet <charlet@adacore.com>
+
+ * exp_pakd.adb (Expand_Packed_Eq): Fix handling of PATs.
+
+2021-05-06 Piotr Trojanek <trojanek@adacore.com>
+
+ * osint.adb (Read_Library_Info_From_Full): Cleanup unused
+ initial value.
+
+2021-05-06 Eric Botcazou <ebotcazou@adacore.com>
+
+ * doc/gnat_rm/implementation_defined_characteristics.rst (3.5.7):
+ Mention the IEEE standard explicitly. Use current format names.
+ Document assumed rounding mode and new features of I/O support.
+ * gnat_rm.texi: Regenerate.
+
+2021-05-06 Eric Botcazou <ebotcazou@adacore.com>
+
+ * init.c (__gnat_init_float): Use full version on Linux too.
+
+2021-05-06 Eric Botcazou <ebotcazou@adacore.com>
+
+ * libgnat/s-fatgen.adb (Valid): Do a bit comparison with 0.0
+ when denormalized numbers are not supported.
+
+2021-05-06 Piotr Trojanek <trojanek@adacore.com>
+
+ * sem_attr.adb (Check_Enum_Image): Reword comment; add
+ Check_Enumeration_Maps parameter. Now this routine combines
+ both referencing enumeration literals and checking restriction
+ No_Enumeration_Maps, if required.
+ (Analyze_Attribute): Remove duplicated code and instead call
+ Check_Enum_Image.
+
+2021-05-06 Piotr Trojanek <trojanek@adacore.com>
+
+ * sem_attr.adb (Analyze_Image_Attribute): Remove redundant
+ condition; add a missing header box.
+
+2021-05-06 Gary Dismukes <dismukes@adacore.com>
+
+ * doc/gnat_ugn/building_executable_programs_with_gnat.rst: Add
+ mention of underscore and fix grammar error in doc for -gnatd.
+ * gnat_ugn.texi: Regenerate.
+
+2021-05-06 Eric Botcazou <ebotcazou@adacore.com>
+
+ * Makefile.rtl (GNATRTL_NONTASKING_OBJS): Add s-exponr, s-exnflt
+ and s-exnlfl.
+ * exp_ch4.adb (Expand_N_Op_Expon): Use RE_Exn_Float for Short_Float.
+ * rtsfind.ads (RTU_Id): Add System_Exn_Flt and System_Exn_LFlt.
+ (RE_Id): Adjust entries for RE_Exn_Float and RE_Exn_Long_Float.
+ (RE_Unit_Table): Likewise.
+ * libgnat/s-exnflt.ads: New file.
+ * libgnat/s-exnlfl.ads: Likewise.
+ * libgnat/s-exnllf.ads: Change to mere instantiation.
+ * libgnat/s-exnllf.adb: Move implementation to...
+ * libgnat/s-exponr.ads: New generic unit.
+ * libgnat/s-exponr.adb: ...here and also make it generic.
+ (Expon): Do the computation in double precision internally.
+
+2021-05-06 Piotr Trojanek <trojanek@adacore.com>
+
+ * lib-writ.adb, osint.adb, osint.ads: Cleanup.
+
+2021-05-06 Piotr Trojanek <trojanek@adacore.com>
+
+ * exp_ch3.adb (Expand_Freeze_Array_Type): Remove excessive
+ condition.
+ (Expand_N_Object_Declaration): Likewise.
+ (Build_Equivalent_Aggregate): Likewise.
+ (Initialization_Warning): Likewise; change another excessive
+ condition into assertion.
+ * freeze.adb (Freeze_Entity): Remove excessive condition.
+
+2021-05-06 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_res.adb (Resolve_If_Expression): If the context of the
+ expression is an indexed_component, resolve the expression and
+ its dependent_expressions with the base type of the index, to
+ ensure that an index check is generated when resolving the
+ enclosing indexxed_component, and avoid an improper use of
+ discriminants out of scope, when the index type is
+ discriminant-dependent.
+
+2021-05-06 Arnaud Charlet <charlet@adacore.com>
+
+ * einfo.ads, exp_prag.adb, exp_util.adb: Fix typos.
+
+2021-05-05 Piotr Trojanek <trojanek@adacore.com>
+
+ * exp_attr.adb (Expand_N_Attribute_Reference): Fix expansion of
+ attributes Input and Output for unchecked unions.
+ * sem_case.ads: Fix typo "disriminant" and refill comment.
+
+2021-05-05 Piotr Trojanek <trojanek@adacore.com>
+
+ * exp_attr.adb, exp_ch9.adb, sem_ch3.adb: Reuse
+ Has_Defaulted_Discriminants.
+ * sem_ch4.adb (Analyze_Allocator): Reuse
+ Has_Defaulted_Discriminants (after reordering conjuncts); remove
+ redundant IF statement, whose condition is implied by
+ Has_Defaulted_Discriminants.
+ * sem_util.adb (Has_Defaulted_Discriminants): Has_Discriminants
+ implies that the First_Discriminant is present.
+ (Is_Fully_Initialized_Type): Reuse Has_Defaulted_Discriminants.
+
+2021-05-05 Justin Squirek <squirek@adacore.com>
+
+ * exp_ch6.adb (Expand_Call_Helper): Add condition to check for
+ expanded actuals and remove dead code.
+
+2021-05-05 Piotr Trojanek <trojanek@adacore.com>
+
+ * exp_ch4.adb (Has_Unconstrained_UU_Component): Rewrite to
+ follow the Ada RM grammar.
+
+2021-05-05 Piotr Trojanek <trojanek@adacore.com>
+
+ * exp_ch4.adb (User_Defined_Primitive_Equality_Op): Refine type
+ of a local variable.
+ * exp_dbug.adb (Scope_Contains): Refine all types from Node_Id
+ to Entity_Id; rename parameters to match those of the
+ Scope_Within routine (which is similar but not the same); also,
+ simplify an OR ELSE into a membership test.
+
+2021-05-05 Piotr Trojanek <trojanek@adacore.com>
+
+ * exp_ch4.adb (Component_Is_Unconstrained_UU): Detect both
+ qualified and unqualified names of unchecked union components.
+
+2021-05-05 Piotr Trojanek <trojanek@adacore.com>
+
+ * exp_ch4.adb (Variant_Is_Unconstrained_UU): Remove redundant
+ check for empty list.
+ * exp_disp.adb (Find_Entry_Index): Simplify by removing
+ redundant check and counting from zero; fix type of a local
+ variable.
+ * sem_ch12.adb (Save_Global_Descendant): Remove an unnecessary
+ special-case for empty lists.
+
+2021-05-05 Piotr Trojanek <trojanek@adacore.com>
+
+ * exp_ch4.adb (Apply_Accessibility_Check): Skip a statically
+ true condition in expanded raise statement.
+
+2021-05-05 Bob Duff <duff@adacore.com>
+
+ * libgnat/s-os_lib.adb (Missed_Drive_Letter): Simplify the code.
+
+2021-05-05 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_ch5.adb (Analyze_Assignment): Do not emit the warning that
+ a previous value of the target object is useless if the
+ right-hand side of the assignment includes target names.
+
+2021-05-05 Eric Botcazou <ebotcazou@adacore.com>
+
+ * exp_imgv.adb: Add with/use clauses for Targparm.
+ (Build_Enumeration_Image_Tables): Set type of Threshold to Nat and
+ initialize it to Nat'Last if the type is local and the target does
+ not support descriptors. Adjust Threshold_For_Size similarly.
+ (Expand_Value_Attribute): Minor tweaks.
+
+2021-05-05 Ghjuvan Lacambre <lacambre@adacore.com>
+
+ * exp_ch7.adb (Expand_N_Package_Body): Add CUDA init call.
+ * sem_ch7.adb (Analyze_Package_Body_Helper): Remove CUDA init
+ call.
+
+2021-05-05 Ghjuvan Lacambre <lacambre@adacore.com>
+
+ * par-ch5.adb (P_Condition): Check if expression is declare
+ expression.
+
+2021-05-05 Piotr Trojanek <trojanek@adacore.com>
+
+ * make.adb (Make): Use GNAT.Ctrl_C.Install_Handler instead of a
+ custom imported procedure.
+
+2021-05-05 Eric Botcazou <ebotcazou@adacore.com>
+
+ * exp_imgv.adb (Is_User_Defined_Enumeration_Type): Delete.
+ (Expand_Image_Attribute): Move inline expansion into normal flow of
+ control, move down declarations and remove superfluous processing.
+
+2021-05-05 Piotr Trojanek <trojanek@adacore.com>
+
+ * libgnat/g-alleve.adb (Bit_Operation): Now a not-null type.
+ * libgnat/g-sechas.adb (Fill_Buffer_Access): Likewise.
+ * libgnat/s-dwalin.adb (Callback): Likewise.
+
+2021-05-05 Ghjuvan Lacambre <lacambre@adacore.com>
+
+ * exp_util.adb (Is_Possibly_Unaligned_Object): Remove commented
+ code.
+
+2021-05-05 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_ch3.adb (Find_Type_Of_Object): When In_Spec_Expression is
+ set and the object declaration generates a subtype indication,
+ build the corresponding subtype declaration and place it in tree
+ without the use of Insert_Actions, which is disabled in this
+ context.
+
+2021-05-05 Eric Botcazou <ebotcazou@adacore.com>
+
+ * debug.adb (d_x): Document extended usage.
+ * exp_imgv.adb (Expand_Standard_Boolean_Image): New procedure.
+ (Expand_Image_Attribute): Call it to expand in line the attribute
+ for standard boolean by default.
+
+2021-05-05 Eric Botcazou <ebotcazou@adacore.com>
+
+ * debug.adb (d_x): Document new usage.
+ * exp_imgv.adb (Expand_User_Defined_Enumeration_Image): Add Typ
+ parameter and use it throughout the processing.
+ (Expand_Image_Attribute): Retrieve the underlying type of the
+ prefix and use the inline expansion for user-defined enumeration
+ types with a literal string by default.
+
+2021-05-05 Eric Botcazou <ebotcazou@adacore.com>
+
+ * libgnat/s-dorepr.adb (Split): Declare a per-size temporary.
+ Add pragma Annotate.
+
+2021-05-05 Piotr Trojanek <trojanek@adacore.com>
+
+ * exp_ch4.adb, sem_ch13.adb, sem_eval.adb, sem_res.adb: Remove
+ redundant calls to UI_From_Int.
+
+2021-05-05 Eric Botcazou <ebotcazou@adacore.com>
+
+ * exp_imgv.ads (Build_Enumeration_Image_Tables): Adjust comment.
+ * exp_imgv.adb (Build_Enumeration_Image_Tables): Add the
+ declaration nodes of the 4 tables to the declaration list of the
+ function body.
+
+2021-05-05 Piotr Trojanek <trojanek@adacore.com>
+
+ * Makefile.rtl (GNATRTL_NONTASKING_OBJS): Add s-imagen, s-imen16,
+ s-imen32, s-imenu8, s-pehage, s-valuen, s-vaen16, s-vaen32 and
+ s-vaenu8. Remove s-imenne, s-imgenu and s-valenu.
+ * debug.adb (d_h): Document new usage.
+ * einfo.ads (Lit_Hash): New attribute for enumeration types.
+ (Set_Lit_Hash): Declare.
+ * einfo.adb (Lit_Hash): New function.
+ (Set_Lit_Hash): New procedure.
+ (Write_Field21_Name): Print Lit_Hash for Enumeration_Kind.
+ * exp_imgv.ads (Build_Enumeration_Image_Tables): Fix description
+ and document the hash function and its tables.
+ * exp_imgv.adb: Add with/use clauses for Debug. Add with clause
+ for System.Perfect_Hash_Generators.
+ (Append_Table_To): New helper routine.
+ (Build_Enumeration_Image_Tables): Call it to build the tables.
+ In the main unit, register the literals with the hash generator.
+ If they are sufficiently many and -gnatd_h is not passed, generate
+ a perfect hash function and its tables; otherwise, generate a dummy
+ hash function. For the other units, generate only the declaration.
+ In all cases, set Lit_Hash to the entity of the function, if any.
+ (Expand_Value_Attribute): Pass the 'Unrestricted_Access of Lit_Hash,
+ if any, as third argument to the Value_Enumeration_NN function.
+ * gnat1drv.adb (Adjust_Global_Switches): force simpler implementation
+ of 'Value in CodePeer_Mode.
+ * lib.ads (Synchronize_Serial_Number): Add SN parameter.
+ * lib.adb (Synchronize_Serial_Number): Assert that it is larger than
+ the serial number of the current unit and set the latter to it only
+ in this case.
+ * rtsfind.ads (RTU_Id): Add System_Img_Enum_8, System_Img_Enum_16,
+ System_Img_Enum_32, System_Val_Enum_8, System_Val_Enum_16 and
+ System_Val_Enum_32. Remove System_Img_Enum, System_Img_Enum_New
+ and System_Val_Enum.
+ * sem_attr.adb (Analyze_Access_Attribute): Do not flag a compiler
+ generated Unrestricted_Access attribute as illegal in a declare
+ expression.
+ (RE_Unit_Table): Adjust to above changes.
+ * libgnat/g-heasor.ads: Add pragma Compiler_Unit_Warning.
+ * libgnat/g-table.ads: Likewise.
+ * libgnat/g-pehage.ads: Add with clause and local renaming for
+ System.Perfect_Hash_Generators.
+ (Optimization): Turn into derived type.
+ (Verbose): Turn into renaming.
+ (Too_Many_Tries): Likewise.
+ (Table_Name): Move to System.Perfect_Hash_Generators.
+ (Define): Likewise.
+ (Value): Likewise.
+ * libgnat/g-pehage.adb: Remove with clause for Ada.Directories,
+ GNAT.Heap_Sort_G and GNAT.Table. Move bulk of implementation
+ to System.Perfect_Hash_Generators, only keep the output part.
+ * libgnat/s-imagen.ads: New generic unit.
+ * libgnat/s-imagen.adb: New body.
+ * libgnat/s-imen16.ads: New unit.
+ * libgnat/s-imen32.ads: Likewise.
+ * libgnat/s-imenu8.ads: Likewise.
+ * libgnat/s-imenne.ads: Adjust description.
+ * libgnat/s-imgenu.ads: Delete.
+ * libgnat/s-imgenu.adb: Likewise.
+ * libgnat/s-pehage.ads: New unit from GNAT.Perfect_Hash_Generators.
+ * libgnat/s-pehage.adb: New body from GNAT.Perfect_Hash_Generators.
+ * libgnat/s-valuen.ads: New generic unit.
+ * libgnat/s-valuen.adb: New body.
+ * libgnat/s-vaen16.ads: New unit.
+ * libgnat/s-vaen32.ads: Likewise.
+ * libgnat/s-vaenu8.ads: Likewise.
+ * libgnat/s-valenu.ads: Delete.
+ * libgnat/s-valenu.adb: Likewise.
+ * gcc-interface/Make-lang.in (GNAT_ADA_OBJS): Add s-pehage.o.
+ (GNATBIND_OBJS): Remove s-imgenu.o.
+
+2021-05-05 Piotr Trojanek <trojanek@adacore.com>
+
+ * sem_util.ads (Apply_Compile_Time_Constraint_Error): Remove
+ parameter Rep from the function spec and "and if the flag Rep is
+ set" from the comment.
+ * sem_util.adb (Apply_Compile_Time_Constraint_Error): Remove
+ parameter Rep.
+
+2021-05-05 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_aggr.adb (Resolve_Indexed_Aggregate): For indexed
+ aggregates with component associations verify that if there is
+ more than one component association then all the choices are
+ static, that the set of choices define a continuous sequence of
+ values, and that if loop specfications appear, they do not
+ include iterator filters or key expressions.
+
+2021-05-05 Eric Botcazou <ebotcazou@adacore.com>
+
+ * Makefile.rtl (GNATRTL_NONTASKING_OBJS): Add s-dourea, s-imager,
+ s-imgflt, s-imglfl and s-imgllf.
+ (LIBGNAT_TARGET_PAIRS) [PowerPC/VxWorks]: Use s-dorepr__fma.adb.
+ (LIBGNAT_TARGET_PAIRS) [PowerPC/VxWorksAE]: Likewise.
+ (LIBGNAT_TARGET_PAIRS) [Aarch64/VxWorks]: Likewise.
+ (LIBGNAT_TARGET_PAIRS) [Aarch64/QNX]: Likewise.
+ (LIBGNAT_TARGET_PAIRS) [Aarch64/FreeBSD]: Likewise.
+ (LIBGNAT_TARGET_PAIRS) [PowerPC/Linux]: Likewise.
+ (LIBGNAT_TARGET_PAIRS) [Aarch64/Linux]: Likewise.
+ (LIBGNAT_TARGET_PAIRS) [IA-64/Linux]: Likewise.
+ (LIBGNAT_TARGET_PAIRS) [IA-64/HP-UX]: Likewise.
+ (LIBGNAT_TARGET_PAIRS) [RISC-V/Linux]: Likewise.
+ (LIBGNAT_TARGET_PAIRS) [PowerPC/Darwin]: Likewise.
+ * exp_attr.adb (Expand_N_Attribute_Reference) [Attribute_Fore]: Use
+ Fixed suffix and Long_Float type.
+ * exp_imgv.adb (Expand_Image_Attribute): For floating-point types,
+ use the routine of the corresponding root type. For ordinary fixed
+ point types, use Fixed suffix and Long_Float type.
+ (Expand_Value_Attribute): Revert latest change for Long_Long_Float.
+ * gcc-interface/Make-lang.in (GNAT_ADA_OBJS): Remove libgnat units
+ g-hesora.o and s-imgenu.o, add g-heasor.o, g-table.o and s-pehage.o.
+ (GNATBIND_OBJS): Remove libgnat unit s-imgenu.o.
+ * rtsfind.ads (RTU_Id): Add System_Img_Flt, System_Img_LFlt and
+ System_Img_LLF. Remove System_Img_Real.
+ (RE_Id): Rename RE_Fore_Real to RE_Fore_Fixed. Add RE_Image_Float,
+ RE_Image_Long_Float and RE_Image_Long_Long_Float. Rename
+ RE_Image_Ordinary_Fixed_Point to RE_Image_Fixed.
+ (RE_Unit_Table): Adjust to above changes.
+ * libgnat/a-nbnbre.adb (Fixed_Conversions): Use Long_Float instead
+ of Long_Long_Float.
+ * libgnat/a-textio.ads (Field): Remove obsolete comment.
+ * libgnat/a-ticoau.ads (Aux): Adjust ancestor package.
+ * libgnat/a-ticoau.adb: Remove with/use clause for System.Img_Real.
+ (Puts): Call Aux.Set_Image instead of Set_Image_Real.
+ * libgnat/a-ticoio.adb: Add with/use clauses for System.Img_Flt,
+ System.Img_LFlt and System.Img_LLF.
+ (Scalar_Float): Add third actual parameter.
+ (Scalar_Long_Float): Likewise.
+ (Scalar_Long_Long_Float): Likewise.
+ * libgnat/a-tifiio.adb: Add with/use clauses for System.Img_LFlt
+ and System.Val_LFlt. Remove the one for System.Val_LLF. Replace
+ Long_Long_Float with Long_Float throughout.
+ * libgnat/a-tifiio__128.adb: Likewise.
+ * libgnat/a-tiflau.ads: Add Set_Image formal parameter.
+ * libgnat/a-tiflau.adb: Add with/use clause for System.Img_Util,
+ remove the one for System.Img_Real.
+ (Put): Call Set_Image instead of Set_Image_Real.
+ (Puts): Likewise.
+ * libgnat/a-tiflio.adb: Add with/use clause for System.Img_Flt,
+ System.Img_LFlt and System.Img_LLF.
+ (Aux_Float): Add third actual parameter.
+ (Aux_Long_Float): Likewise.
+ (Aux_Long_Long_Float): Likewise.
+ * libgnat/a-witeio.ads (Field): Remove obsolete comment.
+ * libgnat/a-wtcoau.ads (Aux): Adjust ancestor package.
+ * libgnat/a-wtcoau.adb: Remove with/use clause for System.Img_Real.
+ (Puts): Call Aux.Set_Image instead of Set_Image_Real.
+ * libgnat/a-wtcoio.adb: Add with/use clauses for System.Img_Flt,
+ System.Img_LFlt and System.Img_LLF.
+ (Scalar_Float): Add third actual parameter.
+ (Scalar_Long_Float): Likewise.
+ (Scalar_Long_Long_Float): Likewise.
+ * libgnat/a-wtfiio.adb: Add with/use clauses for System.Img_LFlt
+ and System.Val_LFlt. Remove the one for System.Val_LLF. Replace
+ Long_Long_Float with Long_Float throughout.
+ * libgnat/a-wtfiio__128.adb: Likewise.
+ * libgnat/a-wtflau.ads: Add Set_Image formal parameter.
+ * libgnat/a-wtflau.adb: Add with/use clause for System.Img_Util,
+ remove the one for System.Img_Real.
+ (Put): Call Set_Image instead of Set_Image_Real.
+ (Puts): Likewise.
+ * libgnat/a-wtflio.adb: Add with/use clause for System.Img_Flt,
+ System.Img_LFlt and System.Img_LLF.
+ (Aux_Float): Add third actual parameter.
+ (Aux_Long_Float): Likewise.
+ (Aux_Long_Long_Float): Likewise.
+ * libgnat/a-ztexio.ads (Field): Remove obsolete comment.
+ * libgnat/a-ztcoau.ads (Aux): Adjust ancestor package.
+ * libgnat/a-ztcoau.adb: Remove with/use clause for System.Img_Real.
+ (Puts): Call Aux.Set_Image instead of Set_Image_Real.
+ * libgnat/a-ztcoio.adb: Add with/use clauses for System.Img_Flt,
+ System.Img_LFlt and System.Img_LLF.
+ (Scalar_Float): Add third actual parameter.
+ (Scalar_Long_Float): Likewise.
+ (Scalar_Long_Long_Float): Likewise.
+ * libgnat/a-ztfiio.adb: Add with/use clauses for System.Img_LFlt
+ and System.Val_LFlt. Remove the one for System.Val_LLF. Replace
+ Long_Long_Float with Long_Float throughout.
+ * libgnat/a-ztfiio__128.adb: Likewise.
+ * libgnat/a-ztflau.ads: Add Set_Image formal parameter.
+ * libgnat/a-ztflau.adb: Add with/use clause for System.Img_Util,
+ remove the one for System.Img_Real.
+ (Put): Call Set_Image instead of Set_Image_Real.
+ (Puts): Likewise.
+ * libgnat/a-ztflio.adb: Add with/use clause for System.Img_Flt,
+ System.Img_LFlt and System.Img_LLF.
+ (Aux_Float): Add third actual parameter.
+ (Aux_Long_Float): Likewise.
+ (Aux_Long_Long_Float): Likewise.
+ * libgnat/s-dorepr.adb: New file.
+ * libgnat/s-dorepr__fma.adb: Likewise.
+ * libgnat/s-dourea.ads: Likewise.
+ * libgnat/s-dourea.adb: Likewise.
+ * libgnat/s-forrea.ads (Fore_Real): Rename into...
+ (Fore_Fixed): ...this and take Long_Float parameters.
+ * libgnat/s-forrea.adb (Fore_Real): Likewise.
+ (Fore_Fixed): Likewise.
+ * libgnat/s-imgrea.ads: Move to...
+ (Set_Image_Real): Turn into mere renaming.
+ * libgnat/s-imager.ads: ...here.
+ (Image_Ordinary_Fixed_Point): Turn into...
+ (Image_Fixed_Point): ...this.
+ * libgnat/s-imgrea.adb: Add pragma No_Body. Move to...
+ * libgnat/s-imager.adb: ...here.
+ (Image_Ordinary_Fixed_Point): Turn into...
+ (Image_Fixed_Point): ...this.
+ (Is_Negative): Replace Long_Long_Float with Num.
+ (Set_Image_Real): Likewise. Use Double_T instead of single Num
+ throughout the algorithm.
+ * libgnat/s-imgflt.ads: New file.
+ * libgnat/s-imglfl.ads: Likewise.
+ * libgnat/s-imgllf.ads: Likewise.
+ * libgnat/s-imagef.ads: Adjust comment.
+ * libgnat/s-imguti.ads (Max_Real_Image_Length): New named number.
+ * libgnat/s-powflt.ads (Maxpow): Adjust.
+ (Powten): Turn into an exact table of double Float.
+ * libgnat/s-powlfl.ads (Maxpow): Adjust.
+ (Powten): Turn into an exact table of double Long_Float.
+ * libgnat/s-powllf.ads (Maxpow): Adjust.
+ (Powten): Turn into an exact table of double Long_Long_Float.
+ * libgnat/s-valrea.ads: Change order of formal parameters.
+ * libgnat/s-valrea.adb: Add with clause for System.Double_Real.
+ (Double_Real): New instantiation.
+ (Fast2Sum): Delete.
+ (Large_Powten): New function.
+ (Integer_to_Real): Use Quick_Two_Sum instead of Fast2Sum. Convert
+ the value to Double_T. Do the scaling in Double_T for base 10.
+ * libgnat/s-valflt.ads: Remove with/use clasue for Interfaces,
+ add it for System.Unsigned_Types. Use Unsigned.
+ * libgnat/s-vallfl.ads: Remove with/use clasue for Interfaces,
+ add it for System.Unsigned_Types. Use Long_Unsigned.
+ * libgnat/s-valllf.ads: Remove with/use clasue for Interfaces,
+ add it for System.Unsigned_Types. Use Long_Long_Unsigned.
+
+2021-05-05 Piotr Trojanek <trojanek@adacore.com>
+
+ * sem_eval.adb (Eval_Arithmetic_Op): Call
+ Set_Raises_Constraint_Error on real division by zero just like
+ it is called for integer division by zero earlier in this
+ routine.
+
+2021-05-05 Piotr Trojanek <trojanek@adacore.com>
+
+ * freeze.adb (Build_Renamed_Body): Simplify IF and WHILE
+ statements with the same condition.
+
+2021-05-05 Piotr Trojanek <trojanek@adacore.com>
+
+ * pprint.adb (Expr_Name): Introduce local constants to make the
+ code more readable and avoid repeated calls to Next to reach the
+ ELSE part of an if-expression.
+
+2021-05-04 Piotr Trojanek <trojanek@adacore.com>
+
+ * pprint.adb: Remove qualification of arbitrary calls to
+ Sinfo.Expressions and Sinfo.Parameter_Associations.
+
+2021-05-04 Piotr Trojanek <trojanek@adacore.com>
+
+ * pprint.adb (Expr_Name): Simplify with functional variant of
+ UI_Image.
+
+2021-05-04 Piotr Trojanek <trojanek@adacore.com>
+
+ * pprint.adb (To_Mixed): Removed.
+
+2021-05-04 Piotr Trojanek <trojanek@adacore.com>
+
+ * pprint.adb (List_Name_Count): Change type from Integer to
+ Natural.
+
+2021-05-04 Yannick Moy <moy@adacore.com>
+
+ * pprint.adb (Expression_Image): Special case for
+ expression-with-actions.
+
+2021-05-04 Bob Duff <duff@adacore.com>
+
+ * exp_ch4.adb (Expand_Concatenate): Remove the non-optimization.
+
+2021-05-04 Piotr Trojanek <trojanek@adacore.com>
+
+ * lib-xref.adb (Generate_Reference_To_Formals): Remove dedicated
+ branch for generic subprograms (they are now handled together
+ with non-generic subprograms in the ELSE branch); replace a
+ low-level Ekind membership test with a high-level call to
+ Is_Access_Subprogram_Type.
+
+2021-05-04 Piotr Trojanek <trojanek@adacore.com>
+
+ * sem_ch12.adb (Check_Abstract_Primitives): Match First_Formal
+ with Next_Formal.
+ * sem_ch6.adb (Is_Non_Overriding_Operation): Likewise.
+
+2021-05-04 Piotr Trojanek <trojanek@adacore.com>
+
+ * sem_prag.adb (Collect_Global_Item): Iterate directly over
+ formals.
+
+2021-05-04 Piotr Trojanek <trojanek@adacore.com>
+
+ * sem_prag.ads (Collect_Subprogram_Inputs_Outputs): Update
+ comment; this routine is no longer used by GNATprove.
+ * sem_prag.adb (Find_Role): The IN parameter is on output only
+ when it belongs to non-function; also, the otherwise constant
+ object can only be written by a non-function.
+ (Collect_Global_Item): The IN parameter can only be written when
+ it belongs to non-function; also, unnest this check to make it
+ easier to read.
+
+2021-05-04 Arnaud Charlet <charlet@adacore.com>
+
+ * libgnat/s-assert.ads (Assert_Failure): Now a renaming of
+ Assertion_Error.
+ * libgnat/a-assert.ads (Assertion_Error): Now a first class
+ citizen. Remove dependency on System.Assertions.
+ * gcc-interface/a-assert.ads, gcc-interface/a-assert.adb: New.
+ * gcc-interface/Make-lang.in (GNAT_ADA_OBJS, GNATBIND_OBJS): Add
+ a-assert.o from gcc-interface.
+
+2021-05-04 Yannick Moy <moy@adacore.com>
+
+ * erroutc.adb (Matches): Move spec...
+ * erroutc.ads (Matches): ...here.
+
+2021-05-04 Yannick Moy <moy@adacore.com>
+
+ * gnat1drv.adb (Adjust_Global_Switches): Force error marker in
+ GNATprove mode.
+
+2021-05-04 Bob Duff <duff@adacore.com>
+
+ * binde.adb: No need for ??? marks in Binde, because it is
+ superseded by Bindo.
+ * bindo-writers.adb (Write_Unit_Closure): Verified that -Ra
+ works.
+ * exp_ch4.adb, sinfo.ads (Expand_N_Type_Conversion): Rules for
+ conversions passed to gigi are documented in sinfo.ads.
+ (Expand_N_Unchecked_Type_Conversion): Comment is a duplicate of
+ one in sinfo.ads.
+ (Expand_N_In): Robert already added sufficient comments years
+ after the ??? comment was inserted.
+ (Expand_Membership_Minimize_Eliminate_Overflow): I don't see any
+ reason why Stand should export Long_Long_Integer'Base -- it
+ doesn't export any other base types.
+ (Size_In_Storage_Elements): We are doing an allocator, so we
+ don't care about sizes in bits.
+ (Expand_N_Allocator): PolyORB isn't going to be significantly
+ improved, so we're not going to mess with remote access to
+ class-wide types.
+ (Optimize_Return_Stmt): It's not important to optimize return
+ statements in predicate functions -- there are many
+ more-important optimizations we could do. Keep part of the
+ comment without "???", to clarify why the "and then ...".
+ (User_Defined_Primitive_Equality_Op): The optimization doesn't
+ seem important enough.
+ (Expand_N_Unchecked_Type_Conversion): Refactor to use
+ Expand_N_Unchecked_Expression.
+ (Make_Array_Comparison_Op): This seems like a case of "it it's
+ not broken, don't fix it". Too much risk of causing bugs.
+ * debug_a.adb: Remove ??? comments asking why Current_Error_Node
+ is maintained unconditionally, and add a comment explaining why.
+ * errout.adb: These kinds of minor bugs do indeed exist, but
+ we're never going to get around to fixing them "properly", so we
+ need this code for robustness.
+ * gnatchop.adb (Read_File): Document when read can fail.
+ * gnatdll.adb (Parse_Command_Line): Nobody is complaining about
+ these arbitrary limits, so no need to use Table. Increase the
+ limits just in case. It is clear from the names what they are
+ limits on.
+ * gnatlink.adb: Add needed comments.
+ (Delete): An existing comment makes clear it's intentional, and
+ it's been like that since 1996.
+ (Process_Args): Improve comments.
+ (Search_Library_Path): Refactoring to avoid deep nesting.
+ * inline.adb (Build_Body_To_Inline): Probably won't get around
+ to doing that optimization.
+ (Is_Unit_Subprogram): No, this should not be moved to Sem_Aux,
+ because it is too specialized to this context.
+ (Do_Reset): No comment is needed here; it's clear from the
+ comment on Reset_Dispatching_Calls. Do_Reset is an artificial
+ subprogram; if we had proper iterators, it would just be an if
+ statement in the loop.
+ (Rewrite_Function_Call): Probably won't get around to doing that
+ optimization.
+ * layout.adb (Layout_Type): The gigi comment doesn't need to be
+ a ??? comment, and it's been that way since 2000. The
+ limitation to scalars will likely never be investigated, and
+ it's been that way since 2009.
+ * lib.adb (Check_Same_Extended_Unit): This doesn't look like
+ something that needs fixing; it looks like a permanent
+ workaround.
+ * lib-load.adb (Change_Main_Unit_To_Spec): It is good enough in
+ practice.
+ (Load_Unit): Nobody will ever get around to investigating the
+ obscure PMES oddity, and the optimization is not worth the
+ trouble.
+ * live.adb: It's not worth documenting this. It is used only
+ with a debug switch. Nobody who has done significant work on it
+ is still around, so it would require substantial investigation.
+ * mdll.ads: I see no reason for USE.
+ * namet.ads: Routines are obsolete, but they're not going
+ anywhere anytime soon (too much work, and surprisingly delicate
+ because of dependences on global variables).
+ * osint.ads: Minor.
+ * osint.adb: Improve comments.
+ (Full_Lib_File_Name): Use Smart_Find_File.
+
+2021-05-04 Piotr Trojanek <trojanek@adacore.com>
+
+ * exp_prag.adb, sem_prag.adb: Replace low-level Ekind membership
+ tests with a high-level call to Is_Formal_Object.
+
+2021-05-04 Arnaud Charlet <charlet@adacore.com>
+
+ * cstand.adb, sprint.adb, switch-c.adb, xr_tabls.ads,
+ xr_tabls.adb, xref_lib.adb: Address ??? comments.
+
+2021-05-04 Piotr Trojanek <trojanek@adacore.com>
+
+ * sem_prag.adb (Analyze_Global_Item): Take subprogram kind into
+ account when accepting or rejecting a constant of an
+ access-to-variable type as a global Output/In_Out; do this check
+ inside an ELSIF branch to avoid unnecessary evaluation of the
+ subsequent condition.
+
+2021-05-04 Piotr Trojanek <trojanek@adacore.com>
+
+ * sem_prag.adb (Role_Error, Usage_Error): Replace calls to
+ Name_Find and Get_Name_String with a call to To_String.
+
+2021-05-04 Ed Schonberg <schonberg@adacore.com>
+
+ * exp_aggr.adb (Build_Siz_Exp): new function, subsidiary of
+ Expand_Container_Aggregate, to create an expression to be used
+ in the dynamic allocation of a container with a single container
+ element association.
+ (Add_Range): Handle static bounds of ranges over enumerations.
+ (Expand_Container_Aggregate): Add declaration for size
+ expression when needed, and use it in container object
+ declaration for container.
+
+2021-05-04 Arnaud Charlet <charlet@adacore.com>
+
+ * exp_ch7.adb (Build_Finalizer_Helper.New_Finalizer_Name):
+ Unnest so that it can be reused.
+ (Build_Finalizer_Helper.Process_Declarations): Call the
+ xxx__finalize_body procedure of a package instantiation in case
+ it contains finalization statements. Code clean ups.
+ (Build_Finalizer_Helper.Create_Finalizer): Export and set an
+ Interface_Name for library level finalizers since these may be
+ imported now.
+ (Build_Finalizer_Helper): Need to process library level package
+ body instantiations which may contain objects requiring
+ finalization.
+ * libgnat/s-finmas.ads: Fix typo.
+
+2021-05-04 Arnaud Charlet <charlet@adacore.com>
+
+ * checks.adb (Append_Range_Checks, Apply_Selected_Length_Checks,
+ Determine_Range, Insert_Range_Checks,
+ Install_Null_Excluding_Check, Selected_Length_Checks,
+ Selected_Range_Checks): Address ??? comments and code cleanups.
+
+2021-05-04 Piotr Trojanek <trojanek@adacore.com>
+
+ * sem_prag.adb (Check_Mode_Restriction_In_Enclosing_Context):
+ Apply the rule even with no explicit Global contract (and remove
+ a dead condition for Refined_Global).
+
+2021-05-04 Piotr Trojanek <trojanek@adacore.com>
+
+ * sem_prag.adb (Check_Mode_Restriction_In_Enclosing_Context):
+ Extend check to protected entries.
+
+2021-05-04 Piotr Trojanek <trojanek@adacore.com>
+
+ * sem_prag.adb (Check_Mode_Restriction_In_Enclosing_Context):
+ Fix reference to SPARK RM rule number.
+
+2021-05-04 Eric Botcazou <ebotcazou@adacore.com>
+
+ * exp_intr.adb: Remove with/use clauses for Urealp.
+ (Expand_Is_Negative): Delete.
+ (Expand_Intrinsic_Call): Do not call it.
+ * rtsfind.ads (RE_Id): Remove RE_Float_Unsigned.
+ (RE_Unit_Table): Remove entry for RE_Float_Unsigned.
+ * snames.ads-tmpl (Name_Is_Negative): Delete.
+ * libgnat/s-imgrea.ads (Set_Image_Real): Fix mode of S parameter.
+ * libgnat/s-imgrea.adb: Add with/use clauses for System.Img_Util.
+ (LLU): New subtype.
+ (Maxdigs): Use it.
+ (Is_Negative): Reimplement.
+ (Image_Floating_Point): Simplify.
+ (Set_Image_Real): Fix mode of S parameter. Remove the low-level
+ processing on characters. Flip the sign of the Scale variable.
+ Compute the maximum number of digits for the straight notation.
+ Call Set_Decimal_Digits at the end to do the final formatting.
+ * libgnat/s-imguti.ads (Floating_Invalid_Value): New type.
+ (Set_Floating_Invalid_Value): New procedure.
+ * libgnat/s-imguti.adb (Set_Floating_Invalid_Value): Implement it
+ based on existing code from Set_Image_Real.
+ * libgnat/s-unstyp.ads (Float_Unsigned): Delete.
+
+2021-05-04 Piotr Trojanek <trojanek@adacore.com>
+
+ * csets.adb (Initialize): Refactor into CASE statement; raise
+ exception on unsupported code of character set (it will be
+ gently rejected earlier when scanning command line switches).
+ * switch-b.adb (Scan_Binder_Switches): Refactor into a
+ membership expression; add missing '9' choice; reorder as
+ described by GNAT UG, section 4.3.11.
+ * switch-c.adb (Scan_Front_End_Switches): Refactor into a
+ membership expression and reorder as above.
+ * doc/gnat_ugn/building_executable_programs_with_gnat.rst
+ (gnatic): Mention '5' as an allowed value for "c".
+ * gnat_ugn.texi: Regenerate.
+
+2021-05-04 Piotr Trojanek <trojanek@adacore.com>
+
+ * errout.adb (Error_Msg_Internal): Add assertion to prevent
+ style mistakes reappearing in the future.
+
+2021-05-04 Javier Miranda <miranda@adacore.com>
+
+ * exp_ch4.adb (Tagged_Membership): Remove wrong condition that
+ is not consistent with the documentation of this subprogram.
+
+2021-05-04 Yannick Moy <moy@adacore.com>
+
+ * sem_res.adb (Valid_Conversion): Make message a continuation.
+
+2021-05-04 Arnaud Charlet <charlet@adacore.com>
+
+ * styleg.adb: Address ??? comments.
+
+2021-05-03 Arnaud Charlet <charlet@adacore.com>
+
+ * libgnat/a-stunau.ads, libgnat/a-stunau.adb,
+ libgnat/a-stunau__shared.adb (Set_String): Remove old version,
+ replace by a new version taking a callback to set the string.
+
+2021-05-03 Arnaud Charlet <charlet@adacore.com>
+
+ * libgnat/a-coorma.ads (Map): Add missing
+ Preelaborate_Initialization.
+
+2021-05-03 Piotr Trojanek <trojanek@adacore.com>
+
+ * exp_ch4.adb (Analyze_Number_Declaration, Expand_N_Op_Expon):
+ Simplify with Is_Universal_Numeric_Type.
+ * sem_attr.adb (Resolve_Attribute): Likewise.
+ * sem_ch3.adb: Likewise.
+ * sem_ch4.adb (Check_Common_Type, Check_Arithmetic_Pair):
+ Likewise.
+ * sem_eval.adb (Eval_Unary_Op, Test_In_Range): Likewise.
+ * sem_res.adb (Resolve_Arithmetic_Op, Resolve_Membership_Op,
+ Resolve_Op_Expon, Resolve_Unary_Op, Set_Mixed_Mode_Operand,
+ Set_Operand_Type): Likewise.
+ * sem_type.adb (Disambiguate, Find_Unique_Type): Likewise.
+ * sem_util.adb (Universal_Interpretation): Likewise.
+
+2021-05-03 Piotr Trojanek <trojanek@adacore.com>
+
+ * exp_aggr.adb (Max_Aggregate_Size): Add header boxes for nested
+ routines; move a local constant after nested subprogram bodies;
+ refill comment.
+
+2021-05-03 Piotr Trojanek <trojanek@adacore.com>
+
+ * sem_attr.adb (Analyze_Attribute): Reuse Resolve with implicit
+ type when analysing attribute Priority.
+ * sem_ch5.adb (Analyze_Case_Statement): Likewise for a rare case
+ in analysis of case statements.
+ (Analyze_Iterator_Specification): Likewise for non-overloaded
+ domain of iteration.
+
+2021-05-03 Piotr Trojanek <trojanek@adacore.com>
+
+ * einfo.adb (Write_Entity_Info): Simplify an Ekind membership
+ test.
+ * exp_aggr.adb (Is_CCG_Supported_Aggregate): Likewise.
+
+2021-05-03 Piotr Trojanek <trojanek@adacore.com>
+
+ * exp_ch7.adb (Build_Finalize_Statements): Refine type of a
+ local counter variable.
+ * exp_dist.adb (Append_Record_Traversal): Refine type of Counter
+ parameter.
+ (Add_Process_Element): Likewise.
+ (Build_From_Any_Call): Refine type of a local counter variable.
+ (Build_From_Any_Function): Likewise.
+ (Build_To_Any_Function): Likewise.
+ (FA_Rec_Add_Process_Element): Likewise.
+ (TA_Append_Record_Traversal): Likewise.
+ (TA_Rec_Add_Process_Element): Likewise.
+
+2021-05-03 Piotr Trojanek <trojanek@adacore.com>
+
+ * rtsfind.adb (SPARK_Implicit_Load): Simplify with Discard_Node.
+
+2021-05-03 Arnaud Charlet <charlet@adacore.com>
+
+ * Makefile.rtl: Update copyright notice.
+ * ada_get_targ.adb: Likewise.
+ * 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_put_image.adb: Likewise.
+ * exp_put_image.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.
+ * gcc-interface/ada-tree.h: Likewise.
+ * gcc-interface/ada.h: Likewise.
+ * gcc-interface/cuintp.c: Likewise.
+ * gcc-interface/decl.c: Likewise.
+ * gcc-interface/gadaint.h: Likewise.
+ * gcc-interface/gigi.h: Likewise.
+ * gcc-interface/lang-specs.h: Likewise.
+ * gcc-interface/misc.c: Likewise.
+ * gcc-interface/system.ads: Likewise.
+ * gcc-interface/targtyps.c: Likewise.
+ * gcc-interface/trans.c: Likewise.
+ * gcc-interface/utils.c: Likewise.
+ * gcc-interface/utils2.c: 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.
+ * gnat_cuda.adb: Likewise.
+ * gnat_cuda.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.
+ * gnatvsn.ads: 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-tasini.adb: Likewise.
+ * libgnarl/a-tasini.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-decima__128.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-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-nagefl.ads: Likewise.
+ * libgnat/a-naliop.ads: Likewise.
+ * libgnat/a-naliop__nolibm.ads: Likewise.
+ * libgnat/a-nallfl.ads: Likewise.
+ * libgnat/a-nallfl__wraplf.ads: Likewise.
+ * libgnat/a-nalofl.ads: Likewise.
+ * libgnat/a-nashfl.ads: Likewise.
+ * libgnat/a-nashfl__wraplf.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-nuauco.ads: Likewise.
+ * libgnat/a-nuauco__x86.ads: Likewise.
+ * libgnat/a-nuaufl.ads: Likewise.
+ * libgnat/a-nuaufl__wraplf.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-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-stobbu.adb: Likewise.
+ * libgnat/a-stobbu.ads: Likewise.
+ * libgnat/a-stobfi.adb: Likewise.
+ * libgnat/a-stobfi.ads: Likewise.
+ * libgnat/a-storio.adb: Likewise.
+ * libgnat/a-stoubu.adb: Likewise.
+ * libgnat/a-stoubu.ads: Likewise.
+ * libgnat/a-stoufi.adb: Likewise.
+ * libgnat/a-stoufi.ads: Likewise.
+ * libgnat/a-stoufo.adb: Likewise.
+ * libgnat/a-stoufo.ads: Likewise.
+ * libgnat/a-stouut.adb: Likewise.
+ * libgnat/a-stouut.ads: 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-strsto.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-ststbo.adb: Likewise.
+ * libgnat/a-ststbo.ads: Likewise.
+ * libgnat/a-ststio.adb: Likewise.
+ * libgnat/a-ststio.ads: Likewise.
+ * libgnat/a-ststun.adb: Likewise.
+ * libgnat/a-ststun.ads: Likewise.
+ * libgnat/a-stteou.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-tideio__128.adb: Likewise.
+ * libgnat/a-tienau.adb: Likewise.
+ * libgnat/a-tienau.ads: Likewise.
+ * libgnat/a-tienio.adb: Likewise.
+ * libgnat/a-tifiau.adb: Likewise.
+ * libgnat/a-tifiau.ads: Likewise.
+ * libgnat/a-tifiio.adb: Likewise.
+ * libgnat/a-tifiio__128.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-tiinio__128.adb: Likewise.
+ * libgnat/a-timoio.adb: Likewise.
+ * libgnat/a-timoio.ads: Likewise.
+ * libgnat/a-timoio__128.adb: 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-wtdeio__128.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-wtfiau.adb: Likewise.
+ * libgnat/a-wtfiau.ads: Likewise.
+ * libgnat/a-wtfiio.adb: Likewise.
+ * libgnat/a-wtfiio__128.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-wtinio__128.adb: Likewise.
+ * libgnat/a-wtmoio.adb: Likewise.
+ * libgnat/a-wtmoio.ads: Likewise.
+ * libgnat/a-wtmoio__128.adb: 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-ztdeio__128.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-ztfiau.adb: Likewise.
+ * libgnat/a-ztfiau.ads: Likewise.
+ * libgnat/a-ztfiio.adb: Likewise.
+ * libgnat/a-ztfiio__128.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-ztinio__128.adb: Likewise.
+ * libgnat/a-ztmoio.adb: Likewise.
+ * libgnat/a-ztmoio__128.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-socpol.adb: Likewise.
+ * libgnat/g-socpol.ads: Likewise.
+ * libgnat/g-socpol__dummy.adb: Likewise.
+ * libgnat/g-socpol__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-sopowa.adb: Likewise.
+ * libgnat/g-sopowa__mingw.adb: Likewise.
+ * libgnat/g-sopowa__posix.adb: 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-spogwa.adb: Likewise.
+ * libgnat/g-spogwa.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-cexten__128.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/interfac__2020.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-aoinar.adb: Likewise.
+ * libgnat/s-aoinar.ads: Likewise.
+ * libgnat/s-aomoar.adb: Likewise.
+ * libgnat/s-aomoar.ads: Likewise.
+ * libgnat/s-aotase.adb: Likewise.
+ * libgnat/s-aotase.ads: Likewise.
+ * libgnat/s-aridou.adb: Likewise.
+ * libgnat/s-aridou.ads: Likewise.
+ * libgnat/s-arit128.adb: Likewise.
+ * libgnat/s-arit128.ads: Likewise.
+ * libgnat/s-arit32.adb: Likewise.
+ * libgnat/s-arit32.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-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-casi128.adb: Likewise.
+ * libgnat/s-casi128.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-caun128.adb: Likewise.
+ * libgnat/s-caun128.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-exnllli.ads: Likewise.
+ * libgnat/s-expint.adb: Likewise.
+ * libgnat/s-expint.ads: Likewise.
+ * libgnat/s-explli.adb: Likewise.
+ * libgnat/s-explli.ads: Likewise.
+ * libgnat/s-expllli.ads: Likewise.
+ * libgnat/s-explllu.ads: Likewise.
+ * libgnat/s-expllu.adb: Likewise.
+ * libgnat/s-expllu.ads: Likewise.
+ * libgnat/s-expmod.adb: Likewise.
+ * libgnat/s-expmod.ads: Likewise.
+ * libgnat/s-exponn.adb: Likewise.
+ * libgnat/s-exponn.ads: Likewise.
+ * libgnat/s-expont.adb: Likewise.
+ * libgnat/s-expont.ads: Likewise.
+ * libgnat/s-exponu.adb: Likewise.
+ * libgnat/s-exponu.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-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-fode128.ads: Likewise.
+ * libgnat/s-fode32.ads: Likewise.
+ * libgnat/s-fode64.ads: Likewise.
+ * libgnat/s-fofi128.ads: Likewise.
+ * libgnat/s-fofi32.ads: Likewise.
+ * libgnat/s-fofi64.ads: Likewise.
+ * libgnat/s-fore_d.adb: Likewise.
+ * libgnat/s-fore_d.ads: Likewise.
+ * libgnat/s-fore_f.adb: Likewise.
+ * libgnat/s-fore_f.ads: Likewise.
+ * libgnat/s-forrea.adb: Likewise.
+ * libgnat/s-forrea.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-imageb.adb: Likewise.
+ * libgnat/s-imageb.ads: Likewise.
+ * libgnat/s-imaged.adb: Likewise.
+ * libgnat/s-imaged.ads: Likewise.
+ * libgnat/s-imagef.adb: Likewise.
+ * libgnat/s-imagef.ads: Likewise.
+ * libgnat/s-imagei.adb: Likewise.
+ * libgnat/s-imagei.ads: Likewise.
+ * libgnat/s-imageu.adb: Likewise.
+ * libgnat/s-imageu.ads: Likewise.
+ * libgnat/s-imagew.adb: Likewise.
+ * libgnat/s-imagew.ads: Likewise.
+ * libgnat/s-imde128.ads: Likewise.
+ * libgnat/s-imde32.ads: Likewise.
+ * libgnat/s-imde64.ads: Likewise.
+ * libgnat/s-imenne.adb: Likewise.
+ * libgnat/s-imenne.ads: Likewise.
+ * libgnat/s-imfi128.ads: Likewise.
+ * libgnat/s-imfi32.ads: Likewise.
+ * libgnat/s-imfi64.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-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-imglli.adb: Likewise.
+ * libgnat/s-imglli.ads: Likewise.
+ * libgnat/s-imglllb.ads: Likewise.
+ * libgnat/s-imgllli.ads: Likewise.
+ * libgnat/s-imglllu.ads: Likewise.
+ * libgnat/s-imglllw.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-imguti.adb: Likewise.
+ * libgnat/s-imguti.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-pack100.adb: Likewise.
+ * libgnat/s-pack100.ads: Likewise.
+ * libgnat/s-pack101.adb: Likewise.
+ * libgnat/s-pack101.ads: Likewise.
+ * libgnat/s-pack102.adb: Likewise.
+ * libgnat/s-pack102.ads: Likewise.
+ * libgnat/s-pack103.adb: Likewise.
+ * libgnat/s-pack103.ads: Likewise.
+ * libgnat/s-pack104.adb: Likewise.
+ * libgnat/s-pack104.ads: Likewise.
+ * libgnat/s-pack105.adb: Likewise.
+ * libgnat/s-pack105.ads: Likewise.
+ * libgnat/s-pack106.adb: Likewise.
+ * libgnat/s-pack106.ads: Likewise.
+ * libgnat/s-pack107.adb: Likewise.
+ * libgnat/s-pack107.ads: Likewise.
+ * libgnat/s-pack108.adb: Likewise.
+ * libgnat/s-pack108.ads: Likewise.
+ * libgnat/s-pack109.adb: Likewise.
+ * libgnat/s-pack109.ads: Likewise.
+ * libgnat/s-pack11.adb: Likewise.
+ * libgnat/s-pack11.ads: Likewise.
+ * libgnat/s-pack110.adb: Likewise.
+ * libgnat/s-pack110.ads: Likewise.
+ * libgnat/s-pack111.adb: Likewise.
+ * libgnat/s-pack111.ads: Likewise.
+ * libgnat/s-pack112.adb: Likewise.
+ * libgnat/s-pack112.ads: Likewise.
+ * libgnat/s-pack113.adb: Likewise.
+ * libgnat/s-pack113.ads: Likewise.
+ * libgnat/s-pack114.adb: Likewise.
+ * libgnat/s-pack114.ads: Likewise.
+ * libgnat/s-pack115.adb: Likewise.
+ * libgnat/s-pack115.ads: Likewise.
+ * libgnat/s-pack116.adb: Likewise.
+ * libgnat/s-pack116.ads: Likewise.
+ * libgnat/s-pack117.adb: Likewise.
+ * libgnat/s-pack117.ads: Likewise.
+ * libgnat/s-pack118.adb: Likewise.
+ * libgnat/s-pack118.ads: Likewise.
+ * libgnat/s-pack119.adb: Likewise.
+ * libgnat/s-pack119.ads: Likewise.
+ * libgnat/s-pack12.adb: Likewise.
+ * libgnat/s-pack12.ads: Likewise.
+ * libgnat/s-pack120.adb: Likewise.
+ * libgnat/s-pack120.ads: Likewise.
+ * libgnat/s-pack121.adb: Likewise.
+ * libgnat/s-pack121.ads: Likewise.
+ * libgnat/s-pack122.adb: Likewise.
+ * libgnat/s-pack122.ads: Likewise.
+ * libgnat/s-pack123.adb: Likewise.
+ * libgnat/s-pack123.ads: Likewise.
+ * libgnat/s-pack124.adb: Likewise.
+ * libgnat/s-pack124.ads: Likewise.
+ * libgnat/s-pack125.adb: Likewise.
+ * libgnat/s-pack125.ads: Likewise.
+ * libgnat/s-pack126.adb: Likewise.
+ * libgnat/s-pack126.ads: Likewise.
+ * libgnat/s-pack127.adb: Likewise.
+ * libgnat/s-pack127.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-pack65.adb: Likewise.
+ * libgnat/s-pack65.ads: Likewise.
+ * libgnat/s-pack66.adb: Likewise.
+ * libgnat/s-pack66.ads: Likewise.
+ * libgnat/s-pack67.adb: Likewise.
+ * libgnat/s-pack67.ads: Likewise.
+ * libgnat/s-pack68.adb: Likewise.
+ * libgnat/s-pack68.ads: Likewise.
+ * libgnat/s-pack69.adb: Likewise.
+ * libgnat/s-pack69.ads: Likewise.
+ * libgnat/s-pack70.adb: Likewise.
+ * libgnat/s-pack70.ads: Likewise.
+ * libgnat/s-pack71.adb: Likewise.
+ * libgnat/s-pack71.ads: Likewise.
+ * libgnat/s-pack72.adb: Likewise.
+ * libgnat/s-pack72.ads: Likewise.
+ * libgnat/s-pack73.adb: Likewise.
+ * libgnat/s-pack73.ads: Likewise.
+ * libgnat/s-pack74.adb: Likewise.
+ * libgnat/s-pack74.ads: Likewise.
+ * libgnat/s-pack75.adb: Likewise.
+ * libgnat/s-pack75.ads: Likewise.
+ * libgnat/s-pack76.adb: Likewise.
+ * libgnat/s-pack76.ads: Likewise.
+ * libgnat/s-pack77.adb: Likewise.
+ * libgnat/s-pack77.ads: Likewise.
+ * libgnat/s-pack78.adb: Likewise.
+ * libgnat/s-pack78.ads: Likewise.
+ * libgnat/s-pack79.adb: Likewise.
+ * libgnat/s-pack79.ads: Likewise.
+ * libgnat/s-pack80.adb: Likewise.
+ * libgnat/s-pack80.ads: Likewise.
+ * libgnat/s-pack81.adb: Likewise.
+ * libgnat/s-pack81.ads: Likewise.
+ * libgnat/s-pack82.adb: Likewise.
+ * libgnat/s-pack82.ads: Likewise.
+ * libgnat/s-pack83.adb: Likewise.
+ * libgnat/s-pack83.ads: Likewise.
+ * libgnat/s-pack84.adb: Likewise.
+ * libgnat/s-pack84.ads: Likewise.
+ * libgnat/s-pack85.adb: Likewise.
+ * libgnat/s-pack85.ads: Likewise.
+ * libgnat/s-pack86.adb: Likewise.
+ * libgnat/s-pack86.ads: Likewise.
+ * libgnat/s-pack87.adb: Likewise.
+ * libgnat/s-pack87.ads: Likewise.
+ * libgnat/s-pack88.adb: Likewise.
+ * libgnat/s-pack88.ads: Likewise.
+ * libgnat/s-pack89.adb: Likewise.
+ * libgnat/s-pack89.ads: Likewise.
+ * libgnat/s-pack90.adb: Likewise.
+ * libgnat/s-pack90.ads: Likewise.
+ * libgnat/s-pack91.adb: Likewise.
+ * libgnat/s-pack91.ads: Likewise.
+ * libgnat/s-pack92.adb: Likewise.
+ * libgnat/s-pack92.ads: Likewise.
+ * libgnat/s-pack93.adb: Likewise.
+ * libgnat/s-pack93.ads: Likewise.
+ * libgnat/s-pack94.adb: Likewise.
+ * libgnat/s-pack94.ads: Likewise.
+ * libgnat/s-pack95.adb: Likewise.
+ * libgnat/s-pack95.ads: Likewise.
+ * libgnat/s-pack96.adb: Likewise.
+ * libgnat/s-pack96.ads: Likewise.
+ * libgnat/s-pack97.adb: Likewise.
+ * libgnat/s-pack97.ads: Likewise.
+ * libgnat/s-pack98.adb: Likewise.
+ * libgnat/s-pack98.ads: Likewise.
+ * libgnat/s-pack99.adb: Likewise.
+ * libgnat/s-pack99.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-powflt.ads: Likewise.
+ * libgnat/s-powlfl.ads: Likewise.
+ * libgnat/s-powllf.ads: Likewise.
+ * libgnat/s-purexc.ads: Likewise.
+ * libgnat/s-putaim.adb: Likewise.
+ * libgnat/s-putaim.ads: Likewise.
+ * libgnat/s-putima.adb: Likewise.
+ * libgnat/s-putima.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-scaval__128.adb: Likewise.
+ * libgnat/s-scaval__128.ads: Likewise.
+ * libgnat/s-secsta.adb: Likewise.
+ * libgnat/s-secsta.ads: Likewise.
+ * libgnat/s-sequio.adb: Likewise.
+ * libgnat/s-sequio.ads: Likewise.
+ * libgnat/s-shabig.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-statxd.adb: Likewise.
+ * libgnat/s-statxd.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-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-vade128.ads: Likewise.
+ * libgnat/s-vade32.ads: Likewise.
+ * libgnat/s-vade64.ads: Likewise.
+ * libgnat/s-vafi128.ads: Likewise.
+ * libgnat/s-vafi32.ads: Likewise.
+ * libgnat/s-vafi64.ads: Likewise.
+ * libgnat/s-valboo.adb: Likewise.
+ * libgnat/s-valboo.ads: Likewise.
+ * libgnat/s-valcha.adb: Likewise.
+ * libgnat/s-valcha.ads: Likewise.
+ * libgnat/s-valenu.adb: Likewise.
+ * libgnat/s-valenu.ads: Likewise.
+ * libgnat/s-valflt.ads: Likewise.
+ * libgnat/s-valint.adb: Likewise.
+ * libgnat/s-valint.ads: Likewise.
+ * libgnat/s-vallfl.ads: Likewise.
+ * libgnat/s-valllf.ads: Likewise.
+ * libgnat/s-vallli.adb: Likewise.
+ * libgnat/s-vallli.ads: Likewise.
+ * libgnat/s-valllli.ads: Likewise.
+ * libgnat/s-vallllu.ads: Likewise.
+ * libgnat/s-valllu.adb: Likewise.
+ * libgnat/s-valllu.ads: Likewise.
+ * libgnat/s-valrea.adb: Likewise.
+ * libgnat/s-valrea.ads: Likewise.
+ * libgnat/s-valued.adb: Likewise.
+ * libgnat/s-valued.ads: Likewise.
+ * libgnat/s-valuef.adb: Likewise.
+ * libgnat/s-valuef.ads: Likewise.
+ * libgnat/s-valuei.adb: Likewise.
+ * libgnat/s-valuei.ads: Likewise.
+ * libgnat/s-valuer.adb: Likewise.
+ * libgnat/s-valuer.ads: Likewise.
+ * libgnat/s-valueu.adb: Likewise.
+ * libgnat/s-valueu.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-widint.ads: Likewise.
+ * libgnat/s-widlli.adb: Likewise.
+ * libgnat/s-widlli.ads: Likewise.
+ * libgnat/s-widllli.ads: Likewise.
+ * libgnat/s-widlllu.ads: Likewise.
+ * libgnat/s-widllu.adb: Likewise.
+ * libgnat/s-widllu.ads: Likewise.
+ * libgnat/s-widthi.adb: Likewise.
+ * libgnat/s-widthi.ads: Likewise.
+ * libgnat/s-widthu.adb: Likewise.
+ * libgnat/s-widthu.ads: Likewise.
+ * libgnat/s-widuns.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.
+ * 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.
+ * snames.adb-tmpl: Likewise.
+ * snames.ads-tmpl: Likewise.
+ * socket.c: Likewise.
+ * spark_xrefs.adb: Likewise.
+ * spark_xrefs.ads: Likewise.
+ * sprint.adb: Likewise.
+ * sprint.ads: 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.
+ * 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.
+ * 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.
+ * vast.adb: Likewise.
+ * vast.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.
+
+2021-05-03 Piotr Trojanek <trojanek@adacore.com>
+
+ * exp_dist.adb (Build_From_Any_Call): Remove initial value for
+ Fnam; fix style.
+ (Build_To_Any_Call): Remove initial value for Fnam.
+ (Build_TypeCode_Call): Likewise.
+
+2021-05-03 Piotr Trojanek <trojanek@adacore.com>
+
+ * checks.adb, exp_aggr.adb, exp_attr.adb, exp_ch6.adb,
+ exp_disp.adb, exp_imgv.adb, exp_util.adb, sem_attr.adb,
+ sem_ch13.adb, sem_ch8.adb, sem_eval.adb, sem_scil.adb,
+ sem_util.adb: Replace calls to RTE with Is_RTE.
+
+2021-05-03 Piotr Trojanek <trojanek@adacore.com>
+
+ * sem_ch4.adb (Try_Object_Operation): Reuse local constant.
+
+2021-05-03 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_ch4.adb (Try_Object_Operation): When a prefixed call is
+ overloaded and illegal, and the All_Errors flag is off, generate
+ an error message if the re-analysis of some candidate
+ interpretation fails to produce one.
+
+2021-05-03 Dmitriy Anisimkov <anisimko@adacore.com>
+
+ * libgnat/g-casuti.adb: Replace with "pragma No_Body".
+ * libgnat/g-casuti.ads: Replace with a package renaming.
+
+2021-05-03 Piotr Trojanek <trojanek@adacore.com>
+
+ * sem_attr.adb (Check_Program_Unit): Fix references to
+ Concurrent_Kind and Is_Concurrent_Type; avoid repeated calls to
+ Entity.
+
+2021-05-03 Piotr Trojanek <trojanek@adacore.com>
+
+ * sem_attr.adb (Check_Program_Unit): Replace tests for Task_Kind
+ and Protected_Kind with a collective test for Concurrent_Kind;
+ likewise, replace calls to Is_Task_Type and Is_Protected_Type
+ with a collective call to Is_Concurrent_Type; simplify into a
+ single membership test; add missing Entry_Kind alternative.
+
+2021-05-03 Piotr Trojanek <trojanek@adacore.com>
+
+ * sem_aggr.adb (Resolve_Record_Aggregate): Fix casing in error
+ message.
+ * sem_ch3.adb (Add_Internal_Interface_Entities): Fix unbalanced
+ parens.
+ * sem_elim.adb (Eliminate_Error_Msg): Add insertion character.
+
+2021-05-03 Piotr Trojanek <trojanek@adacore.com>
+
+ * freeze.adb (Freeze_Profile): Replace Error_Msg_NE with
+ Error_Msg_N; change to continuation message.
+ * sem_cat.adb, sem_ch10.adb, sem_ch12.adb, sem_ch5.adb: Replace
+ calls to Error_Msg_NE with calls to Error_Msg_N.
+
+2021-05-03 Piotr Trojanek <trojanek@adacore.com>
+
+ * exp_disp.adb, sem_aggr.adb, sem_cat.adb, sem_ch10.adb,
+ sem_ch12.adb, sem_ch3.adb, sem_ch4.adb, sem_ch5.adb,
+ sem_ch6.adb, sem_ch8.adb, sem_ch9.adb, sem_prag.adb,
+ sem_res.adb: Remove extra leading and trailing space in error
+ messages.
+
+2021-05-03 Arnaud Charlet <charlet@adacore.com>
+
+ * sem_prag.adb (Set_Exported): Do not warn on exporting a type.
+
+2021-05-03 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_warn.adb (Check_References): Do not emit warning on a
+ selected component when enclosing type has no discriminant and
+ type of component has partial initialization.
+
+2021-05-03 Justin Squirek <squirek@adacore.com>
+
+ * contracts.adb (Build_Postconditions_Procedure): Remove
+ internally generated if statement used to control finalization
+ actions.
+ * exp_ch6.adb (Add_Return, Expand_Non_Function_Return,
+ Expand_Simple_Function_Return): Add if statement around
+ _postconditions to control finalization.
+ * exp_ch7.adb (Build_Finalizer): Likewise.
+ * sem_prag.adb (Find_Related_Declaration_Or_Body): Add case to
+ handle Context itself being a handled sequence of statements.
+
+2021-05-03 Justin Squirek <squirek@adacore.com>
+
+ * sem_util.adb (In_Return_Value): Modified to detect when
+ implicit dereference is specified on the return type of a
+ function call within the expression being checked.
+
+2021-05-03 Ed Schonberg <schonberg@adacore.com>
+
+ * exp_aggr.adb (Expand_Array_Aggregate): If the parent node of
+ the aggregate is a subprogram call there is no target in which
+ to build the aggregate, and it has to be expanded into component
+ assignments.
+
+2021-05-03 Piotr Trojanek <trojanek@adacore.com>
+
+ * exp_prag.adb (Expand_Pragma_CUDA_Execute): Refill comments;
+ remove periods after single-line comments; use procedural
+ variant of Next_Entity.
+ * gnat_cuda.adb: Refill comments; remove periods after
+ single-line comments; replace calls to UI_From_Int with
+ constants; change iteration bounds so they match the comments.
+ * sem_prag.adb (Analyze_Pragma): Add checks for malformed pragma
+ CUDA_Kernel aggregate; simplify processing of pragma CUDA_Global
+ with Check_Arg_Count; sync comment with code for CUDA_Global.
+
+2021-05-03 Arnaud Charlet <charlet@adacore.com>
+
+ * tbuild.adb (Make_Implicit_Loop_Statement): Disable restriction
+ checking on dead paths.
+
+2021-05-03 Arnaud Charlet <charlet@adacore.com>
+
+ * sem_util.adb (Check_Result_And_Post_State): Replace custom
+ Has_In_Out_Parameter with existing Has_Out_Or_In_Out_Parameter
+ flag which corresponds exactly to what we need.
+
+2021-05-03 Arnaud Charlet <charlet@adacore.com>
+
+ * libgnat/a-ztcoio.adb: Remove unused with clause.
+
+2021-05-03 Piotr Trojanek <trojanek@adacore.com>
+
+ * sem_ch13.adb (Build_Predicate_Functions): Fix typo in comment.
+ (Resolve_Aspect_Expressions): Fix typo in comment; remove
+ redundant check for no aspects; simplify with Discard_Node.
+
+2021-05-03 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_util.adb (Build_Constrained_Itype): Remove prior patch,
+ issue is better handled in Sem_Ch13.Build_Predicate_Functions.
+ * sem_ch13.adb (Build_Predicate_Functions): Do not build
+ predicate function for an Itype with a defined
+ Predicated_Parent, even if that designated parent does not yet
+ have a Predicate_Function. This can happen in instance bodies
+ nested within a generic unit.
+
+2021-04-29 Eric Botcazou <ebotcazou@adacore.com>
+
+ * exp_attr.adb (Expand_N_Attribute_Reference)
+ <Attribute_Max_Size_In_Storage_Elements>: Apply the checks for
+ universal integer contexts only in the default case.
+ * exp_ch4.adb (Get_Size_For_Range): Move to library level.
+ (Expand_N_Type_Conversion): If the operand has Universal_Integer
+ type and the conversion requires an overflow check, try to do an
+ intermediate conversion to a narrower type.
+
+2021-04-29 Arnaud Charlet <charlet@adacore.com>
+
+ * sem_ch3.adb (Check_Anonymous_Access_Component): Factor out
+ core processing of Check_Anonymous_Access_Components.
+ (Check_Anonymous_Access_Components): Call
+ Check_Anonymous_Access_Component.
+ (Process_Discriminants): Call Check_Anonymous_Access_Component.
+ * freeze.adb (Freeze_Record_Type): Code cleanups and add more tree
+ checking to handle changes in sem_ch3.adb.
+ * sem_ch8.adb (Find_Type): Remove special case for access
+ discriminant in task types, these are now supported.
+
+2021-04-29 Eric Botcazou <ebotcazou@adacore.com>
+
+ * exp_ch4.adb (Expand_Compare_Minimize_Eliminate_Overflow): Remove
+ entry condition.
+ (Expand_N_In): Call Minimized_Eliminated_Overflow_Check on the left
+ operand before doing the special overflow expansion.
+ (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_Ne): Likewise.
+ (Minimized_Eliminated_Overflow_Check): Return False for Minimized
+ if the size of the type is greater than that of Long_Long_Integer.
+
+2021-04-29 Arnaud Charlet <charlet@adacore.com>
+
+ * exp_ch5.adb (Expand_N_If_Statement): Only perform the
+ simplification on return True/False for internal nodes when
+ -fpreserve-control-flow is not set.
+
+2021-04-29 Eric Botcazou <ebotcazou@adacore.com>
+
+ * sem_attr.adb (Eval_Attribute) <Attribute_Machine>: Use
+ Round_Even instead of Round in the call to the Machine routine.
+
+2021-04-29 Bob Duff <duff@adacore.com>
+
+ * sem_attr.adb (Analyze_Attribute): Change "$" to "&".
+ Otherwise, Errout will trip over an uninitialized (invalid)
+ variable (Error_Msg_Unit_1).
+
+2021-04-29 Eric Botcazou <ebotcazou@adacore.com>
+
+ * libgnat/s-valuer.adb (Scan_Decimal_Digits): Set Extra to zero
+ when the precision limit is reached by means of trailing zeros
+ and prevent it from being overwritten later.
+
+2021-04-29 Yannick Moy <moy@adacore.com>
+
+ * errout.adb (Output_Messages): Insert SGR strings where needed.
+ * erroutc.adb (Output_Message_Txt): Insert SGR strings where
+ needed in the text of the message itself.
+ (Output_Msg_Text): Allow for style message not to start
+ with (style).
+ * erroutc.ads: Add new constants and functions to control colors
+ in messages output to the terminal. Add variable Use_SGR_Control
+ that should be set to True for using SGR color control strings.
+
+2021-04-29 Yannick Moy <moy@adacore.com>
+
+ * sem_eval.adb (Check_Non_Static_Context_For_Overflow): Apply
+ compile-time checking for overflows in non-static contexts
+ including inlined code.
+ (Eval_Arithmetic_Op): Use the new procedure.
+ (Eval_Unary_Op, Eval_Op_Expon): Add call to the new procedure.
+
+2021-04-29 Justin Squirek <squirek@adacore.com>
+
+ * checks.adb (Apply_Type_Conversion_Checks): Move out constraint
+ check generation, and add case for general access types with
+ constraints.
+ (Make_Discriminant_Constraint_Check): Created to centralize
+ generation of constraint checks for stored discriminants.
+
+2021-04-29 Eric Botcazou <ebotcazou@adacore.com>
+
+ * gnat1drv.adb (Adjust_Global_Switches): Force a 32-bit Duration
+ type if the maximum integer size is lower than 64 bits.
+
+2021-04-29 Arnaud Charlet <charlet@adacore.com>
+
+ * Makefile.rtl (ADA_EXCLUDE_SRCS): Remove unused files.
+ (ADA_INCLUDE_SRCS): Remove libgnat/system.ads
+
+2021-04-29 Arnaud Charlet <charlet@adacore.com>
+
+ * exp_aggr.adb (Collect_Initialization_Statements): Removed.
+ (Convert_Aggr_In_Object_Decl, Expand_Array_Aggregate): Fix
+ creation and insertion of Initialization_Statements. Do not set
+ Initialization_Statements when a transient scope is involved.
+ Move processing of Array_Slice here. Ensure that an object with
+ an Array_Slice call gets its array component initialized. Add
+ comments.
+ * exp_ch7.adb: Update comments.
+ (Store_Actions_In_Scope): Deal properly with an empty list which
+ might now be generated by Convert_Aggr_In_Object_Decl.
+ * exp_ch3.adb: Update comments.
+ (Expand_N_Object_Declaration): Remove processing of Array_Slice.
+
+2021-04-29 Arnaud Charlet <charlet@adacore.com>
+
+ * sem_ch8.adb (Analyze_Object_Renaming): Update check for
+ AI12-0401.
+
+2021-04-29 Patrick Bernardi <bernardi@adacore.com>
+
+ * libgnat/s-stoele.ads (Storage_Offset): Cleanup comment.
+
+2021-04-29 Gary Dismukes <dismukes@adacore.com>
+
+ * exp_util.adb (Add_Own_DIC): Relax the suppression of adding a
+ DIC Check pragma that's done for abstract types by still doing
+ it in the case where GNATprove_Mode is set.
+
+2021-04-29 Joel Brobecker <brobecker@adacore.com>
+
+ * Makefile.rtl (ADA_EXCLUDE_SRCS): Remove s-gcc.adb, s-gcc.ads,
+ s-gccdiv.adb, s-gccdiv.ads, s-gccshi.adb and s-gccshi.ads.
+
+2021-04-29 Piotr Trojanek <trojanek@adacore.com>
+
+ * layout.adb (Layout_Type): Refine type of a local variable with
+ the required size of object from Int to Pos (it is initialized
+ with 8 and only multiplied by 2); fix unbalanced parens in
+ comment.
+
+2021-04-29 Eric Botcazou <ebotcazou@adacore.com>
+
+ * eval_fat.adb (Succ): Use Ureal_Half in a couple of places.
+
+2021-04-29 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_util.adb (Build_Constrained_Itype): Inhibit the generation
+ of predicate functions for this Itype, which is created for an
+ aggregate of a discriminated type. The object to which the
+ aggregate is assigned, e.g a writable actual parameter, will
+ apply the predicates if any are inherited from the base type.
+
+2021-04-29 Piotr Trojanek <trojanek@adacore.com>
+
+ * sem_cat.adb (Set_Categorization_From_Pragmas): Remove special
+ case for generic child units; remove optimization for empty list
+ of pragmas; properly restore visibility.
+
+2021-04-29 Piotr Trojanek <trojanek@adacore.com>
+
+ * sem_elab.adb (Process_SPARK_Instantiation): Fix typo in
+ comment.
+ * sem_prag.adb (Find_Related_Context): Add missing reference to
+ No_Caching in the comment; handle pragmas on compilation units.
+
+2021-04-29 Piotr Trojanek <trojanek@adacore.com>
+
+ * doc/gnat_rm/implementation_defined_attributes.rst: Change all
+ occurrences of "permissible prefix" to "allowed prefix", for
+ consistency.
+ * gnat_rm.texi: Regenerate.
+
+2021-04-29 Eric Botcazou <ebotcazou@adacore.com>
+
+ * eval_fat.adb (Succ): Add a special case for zero if the type does
+ not support denormalized numbers. Always use the canonical formula
+ in other cases and add commentary throughout the function.
+
+2021-04-29 Eric Botcazou <ebotcazou@adacore.com>
+
+ * libgnat/s-fatgen.adb: Remove with clause for Interfaces and
+ use type clauses for Interfaces.Unsigned_{16,32,64}.
+ (Small16): Remove.
+ (Small32): Likewise
+ (Small64): Likewise.
+ (Small80): Likewise.
+ (Tiny16): Likewise.
+ (Tiny32): Likewise.
+ (Tiny64): Likewise.
+ (Tiny80): Likewise.
+ (Siz): Always use 16.
+ (NR): New constant.
+ (Rep_Last): Use it in the computation.
+ (Exp_Factor): Remove special case for 80-bit.
+ (Sign_Mask): Likewise.
+ (Finite_Succ): New function implementing the Succ attribute for
+ finite numbers.
+ (Pred): Rewrite in terms of Finite_Succ.
+ (Succ): Likewise.
+
+2021-04-29 Arnaud Charlet <charlet@adacore.com>
+
+ * debug_a.adb (Debug_Output_Astring): Remove obsolete comment.
+
+2021-04-29 Arnaud Charlet <charlet@adacore.com>
+
+ * sem_attr.adb (Check_Image_Type): Protect against empty
+ Image_Type.
+
+2021-04-29 Arnaud Charlet <charlet@adacore.com>
+
+ * libgnat/a-nbnbin.ads (From_Universal_Image): New.
+ (Big_Integer): Update definition.
+ * libgnat/a-nbnbre.ads, libgnat/a-nbnbre.adb
+ (From_Universal_Image): New.
+ (From_String): Remove alternate body, replaced by
+ From_Universal_Image.
+ (Big_Real): Update definition.
+
+2021-04-29 Gary Dismukes <dismukes@adacore.com>
+
+ * sem_ch8.adb (Find_Type): Check the No_Obsolescent_Features
+ restriction for 'Class applied to an untagged incomplete
+ type (when Ada_Version >= Ada_2005). Remove disabling of the
+ warning message for such usage, along with the ??? comment,
+ which no longer applies (because the -gnatg switch no longer
+ sets Warn_On_Obsolescent_Feature).
+
+2021-04-29 Yannick Moy <moy@adacore.com>
+
+ * errout.adb (Error_Msg_NEL): Extract span from node.
+ (First_And_Last_Nodes): Use spans for subtype indications and
+ attribute definition clauses.
+ (Write_Source_Code_Lines): Fix for tabulation characters. Change
+ output for large spans to skip intermediate lines.
+ * sem_case.adb (Check_Choice_Set): Report duplicate choice on
+ the Original_Node for the case.
+ (Generic_Check_Choices): Set the Original_Node for the rewritten
+ case, so that the subtree used in spans has the correct
+ locations.
+
+2021-04-28 Piotr Trojanek <trojanek@adacore.com>
+
+ * sem_ch13.adb, sem_util.adb: Fix style.
+
+2021-04-28 Piotr Trojanek <trojanek@adacore.com>
+
+ * nlists.ads (List_Length): Adapt comment to match the
+ behaviour.
+
+2021-04-28 Arnaud Charlet <charlet@adacore.com>
+
+ * sem_eval.adb (Eval_Selected_Component): Only consider compile
+ time known aggregates.
+
+2021-04-28 Eric Botcazou <ebotcazou@adacore.com>
+
+ * libgnat/s-fatgen.adb: Add use clause for Interfaces.Unsigned_16
+ and Interfaces.Unsigned_32.
+ (Small16): New constant.
+ (Small32): Likewise.
+ (Small64): Likewise.
+ (Small80): Likewise.
+ (Pred): Declare a local overlay for Small and return it negated
+ for zero if the type does not support denormalized numbers.
+ (Succ): Likewise, but return it directly.
+
+2021-04-28 Piotr Trojanek <trojanek@adacore.com>
+
+ * inline.adb (Formal_Is_Used_Once): Refine type of the counter
+ variable; remove redundant assignment.
+
+2021-04-28 Patrick Bernardi <bernardi@adacore.com>
+
+ * libgnarl/s-interr.adb (Install_Restricted_Handlers): Change
+ Prio parameter to type Interrupt_Priority.
+ * libgnarl/s-interr.ads (Install_Restricted_Handlers): Likewise.
+ * libgnarl/s-interr__dummy.adb (Install_Restricted_Handlers):
+ Likewise.
+ * libgnarl/s-interr__hwint.adb (Install_Restricted_Handlers):
+ Likewise.
+ * libgnarl/s-interr__sigaction.adb (Install_Restricted_Handlers):
+ Likewise.
+ * libgnarl/s-interr__vxworks.adb (Install_Restricted_Handlers):
+ Likewise.
+
+2021-04-28 Piotr Trojanek <trojanek@adacore.com>
+
+ * sem_type.ads (Write_Interp_Ref): Removed; no longer needed.
+ * sem_type.adb (Headers): Removed; now the hash table is
+ directly in the Interp_Map alone.
+ (Interp_Map): Now an instance of the GNAT.HTable.Simple_HTable.
+ (Last_Overloaded): New variable to emulate Interp_Map.Last.
+ (Add_One_Interp): Adapt to new data structure.
+ (Get_First_Interp): Likewise.
+ (Hash): Likewise.
+ (Init_Interp_Tables): Likewise.
+ (New_Interps): Likewise.
+ (Save_Interps): Likewise; handle O_N variable like in
+ Get_First_Interp.
+ (Write_Interp_Ref): Removed; no longer needed.
+
+2021-04-28 Piotr Trojanek <trojanek@adacore.com>
+
+ * inline.adb (Do_Reset_Calls): Now an instance of Traverse_Proc.
+
+2021-04-28 Piotr Trojanek <trojanek@adacore.com>
+
+ * sem_ch13.adb (Analyze_Aspect_Static): Reuse
+ Error_Msg_Ada_2020_Feature for aspect Static.
+ (Analyze_One_Aspect): Likewise for aspect Full_Access.
+
+2021-04-28 Piotr Trojanek <trojanek@adacore.com>
+
+ * sem_ch13.adb (Analyze_Aspect_Static): Refactor to have a
+ single check for the expression being present; adapt comments.
+
+2021-04-28 Piotr Trojanek <trojanek@adacore.com>
+
+ * sem_ch13.adb (Analyze_Aspect_Static): Use aspect name in the
+ error message.
+
+2021-04-28 Piotr Trojanek <trojanek@adacore.com>
+
+ * sem_eval.adb (Eval_Selected_Component): Simplify with
+ Unqualify.
+
+2021-04-28 Eric Botcazou <ebotcazou@adacore.com>
+
+ * libgnat/s-valrea.adb (Fast2Sum): New function.
+ (Integer_to_Real): Use it in an iterated addition with exact
+ error handling for the case where an extra digit is needed.
+ Move local variable now only used in the exponentiation case.
+
+2021-04-28 Yannick Moy <moy@adacore.com>
+
+ * errout.adb: (Error_Msg_Internal): Use span instead of
+ location.
+ (Error_Msg, Error_Msg_NEL): Add versions with span parameter.
+ (Error_Msg_F, Error_Msg_FE, Error_Msg_N, Error_Msg_NE,
+ Error_Msg_NW): Retrieve span from node.
+ (First_Node): Use the new First_And_Last_Nodes.
+ (First_And_Last_Nodes): Expand on previous First_Node. Apply to
+ other nodes than expressions.
+ (First_Sloc): Protect against inconsistent locations.
+ (Last_Node): New function based on First_And_Last_Nodes.
+ (Last_Sloc): New function similar to First_Sloc.
+ (Output_Messages): Update output when -gnatdF is used. Use
+ character ~ for making the span visible, similar to what is done
+ in GCC and Clang.
+ * errout.ads (Error_Msg, Error_Msg_NEL): Add versions with span
+ parameter.
+ (First_And_Last_Nodes, Last_Node, Last_Sloc): New subprograms.
+ * erroutc.adb: Adapt to Sptr field being a span.
+ * erroutc.ads (Error_Msg_Object): Change field Sptr from
+ location to span.
+ * errutil.adb: Adapt to Sptr field being a span.
+ * freeze.adb: Use Errout reporting procedures for nodes to get
+ spans.
+ * par-ch3.adb: Likewise.
+ * par-prag.adb: Likewise.
+ * par-util.adb: Likewise.
+ * sem_case.adb: Likewise.
+ * sem_ch13.adb: Likewise.
+ * sem_ch3.adb: Likewise.
+ * sem_prag.adb: Likewise.
+ * types.ads: (Source_Span): New type for spans.
+ (To_Span): Basic constructors for spans.
+
+2021-04-28 Arnaud Charlet <charlet@adacore.com>
+
+ * einfo.adb (Discriminant_Constraint): Refine assertion.
+
+2021-04-28 Gary Dismukes <dismukes@adacore.com>
+
+ * exp_util.adb (Add_Own_DIC): Suppress expansion of a DIC pragma
+ when the pragma occurs for an abstract type, since that could
+ lead to a call to an abstract function, and such DIC checks can
+ never be performed for abstract types in any case.
+ * sem_disp.adb (Check_Dispatching_Context): Suppress the check
+ for illegal calls to abstract subprograms when the call occurs
+ within a Default_Initial_Condition aspect and the call is passed
+ the current instance as an actual.
+ (Has_Controlling_Current_Instance_Actual): New function to test
+ a call to see if it has any actuals given by direct references
+ to a current instance of a type
+ * sem_res.adb (Resolve_Actuals): Issue an error for a call
+ within a DIC aspect to a nonprimitive subprogram with an actual
+ given by the name of the DIC type's current instance (which will
+ show up as a reference to the formal parameter of a DIC
+ procedure).
+
+2021-04-28 Ed Schonberg <schonberg@adacore.com>
+
+ * exp_ch3.adb (Expand_Record_Extension): Set Parent_Subtype on
+ the type extension when within a generic unit, even though
+ expansion is disabled, to allow for proper resolution of
+ selected components inherited from an ancestor.
+
+2021-04-28 Arnaud Charlet <charlet@adacore.com>
+
+ * sem_aux.adb (Is_Limited_Type): Fix logic to check Is_Type
+ before assuming Ent is a typo.
+ * sem_ch4.adb (Analyze_Expression_With_Actions): Update
+ comments, minor reformatting.
+ * sem_res.adb (Resolve_Declare_Expression): Add protection
+ against no type.
+
+2021-04-28 Arnaud Charlet <charlet@adacore.com>
+
+ * exp_ch6.adb: Fix typo in comment.
+ * sem_ch3.adb (Access_Subprogram_Declaration): Add missing call
+ to Create_Extra_Formals. Remove obsolete bootstrap check.
+ * sem_eval.adb (Eval_Selected_Component): Simplify a
+ selected_component on an aggregate.
+
+2021-04-28 Piotr Trojanek <trojanek@adacore.com>
+
+ * fmap.ads (Reset_Tables): Remove outdated references to
+ GNSA/ASIS.
+ * sem_eval.ads (Initialize): Likewise.
+ * sem_type.adb (Headers): Remove initialization at elaboration.
+ * sem_type.ads (Init_Interp_Tables): Remove outdated reference
+ to gnatf.
+ * stringt.ads (Initialize): Fix style in comment.
+
+2021-04-28 Piotr Trojanek <trojanek@adacore.com>
+
+ * sem_res.ads: Update reference in comment.
+ * sem_type.ads: Fix casing in a name of a unit.
+
+2021-04-28 Yannick Moy <moy@adacore.com>
+
+ * ghost.adb (Check_Ghost_Context): Add continuation message when
+ in predicate.
+
+2021-04-28 Eric Botcazou <ebotcazou@adacore.com>
+
+ * libgnat/s-valrea.adb (Integer_to_Real): Use a subtype of Num
+ for the component type of the table of powers of ten.
+ * libgnat/s-valuer.adb (Round_Extra): Add assertion on Base.
+
+2021-04-28 Piotr Trojanek <trojanek@adacore.com>
+
+ * sem_ch5.adb (Analyze_Case_Statement): Extend optimization to
+ all objects; fix typo in comment.
+
+2021-04-28 Piotr Trojanek <trojanek@adacore.com>
+
+ * exp_ch9.adb (Build_Barrier_Function): Refine type of a
+ protected type entity.
+ (Is_Pure_Barrier): Fix style.
+
+2021-04-28 Bob Duff <duff@adacore.com>
+
+ * exp_ch3.adb (Simple_Init_Defaulted_Type): Simplify the code,
+ and always use OK_Convert_To, rather than Unchecked_Convert_To
+ and Convert_To.
+
+2021-04-28 Arnaud Charlet <charlet@adacore.com>
+
+ * sem_ch3.adb (Analyze_Object_Declaration): Remove dead code.
+ * ali.ads, ali.adb (Scan_ALI): Remove unused parameters.
+ Remove unused code related to Xref lines.
+ (Get_Typeref): Removed, no longer used.
+
+2021-04-28 Arnaud Charlet <charlet@adacore.com>
+
+ * exp_attr.adb (Build_Array_VS_Func, Build_Record_VS_Func,
+ Expand_N_Attribute_Reference): Use Get_Fullest_View instead of
+ Validated_View.
+ (Build_Record_VS_Func): Adjust to keep using Validated_View.
+ (Expand_N_Attribute_Reference) [Valid]: Use
+ Small_Integer_Type_For to allow for more compile time
+ evaluations.
+ * sem_util.adb (Cannot_Raise_Constraint_Error): Add more precise
+ support for N_Indexed_Component and fix support for
+ N_Selected_Component which wasn't completely safe.
+ (List_Cannot_Raise_CE): New.
+ * libgnat/i-cobol.adb (Valid_Packed): Simplify test to address
+ new GNAT warning.
+
+2021-04-28 Arnaud Charlet <charlet@adacore.com>
+
+ * .gitignore: New.
+ * doc/share/conf.py: Add Python 3 compatibility.
+ * doc/share/gnat.sty: Add missing file.
+
+2021-04-28 Richard Wai <richard@annexi-strayline.com>
+
+ * libgnat/a-cohase.ads (Cursor): Synchronize comments for the Cursor
+ type definition to be consistent with identical definitions in other
+ container packages. Add additional comments regarding the importance of
+ maintaining the "Position" component for predefined equality.
+ * libgnat/a-cohama.ads (Cursor): Likewise.
+ * libgnat/a-cihama.ads (Cursor): Likewise.
+ * libgnat/a-cohase.adb (Find, Insert): Ensure that Cursor objects
+ always have their "Position" component set to ensure predefined
+ equality works as required.
+ * libgnat/a-cohama.adb (Find, Insert): Likewise.
+ * libgnat/a-cihama.adb (Find, Insert): Likewise.
+
+2021-04-28 Eric Botcazou <ebotcazou@adacore.com>
+
+ * gcc-interface/decl.c (gnat_to_gnu_subprog_type): Do not demote a
+ const or pure function because of a parameter whose type is pointer
+ to function.
+ * gcc-interface/trans.c (Call_to_gnu): Do not put back a conversion
+ between an actual and a formal that are unconstrained array types.
+ (gnat_gimplify_expr) <CALL_EXPR>: New case.
+ * gcc-interface/utils2.c (build_binary_op): Do not use |= operator.
+ (gnat_stabilize_reference_1): Likewise.
+ (gnat_rewrite_reference): Likewise.
+ (build_unary_op): Do not clear existing TREE_CONSTANT on the result.
+ (gnat_build_constructor): Also accept the address of a constant
+ CONSTRUCTOR as constant element.
+
+2021-04-28 Eric Botcazou <ebotcazou@adacore.com>
+
+ * gcc-interface/trans.c (is_array_of_scalar_type): New predicate.
+ (find_decls_r): New function.
+ (return_slot_opt_for_pure_call_p): New predicate.
+ (Call_to_gnu): Do not create a temporary for the return value if the
+ parent node is an aggregate. If there is a target, try to apply the
+ return slot optimization to regular calls to pure functions returning
+ an array of scalar type.
+
+2021-04-28 Eric Botcazou <ebotcazou@adacore.com>
+
+ * gcc-interface/trans.c (language_function): Add comment.
+ (loop_info_d): Add fndecl and invariants fields.
+ (find_loop_for): Test fndecl instead of the context of var.
+ (find_loop): New function.
+ (Regular_Loop_to_gnu): Fold back into...
+ (Loop_Statement_to_gnu): ...this. Emit invariants on entry, if any.
+ (gnat_to_gnu) <N_Selected_Component>: Record nonconstant invariant
+ offset computations in loops when optimization is enabled.
+ * gcc-interface/utils2.c (gnat_invariant_expr): Handle BIT_AND_EXPR.
+
+2021-04-20 Martin Liska <mliska@suse.cz>
+
+ * gnatvsn.ads: Bump Library_Version to 12.
+
+2021-04-13 Eric Botcazou <ebotcazou@adacore.com>
+
+ * gcc-interface/misc.c (gnat_init): Set default range bits to 0.
+ * gcc-interface/trans.c (extract_encoding): Delete.
+ (decode_name): Likewise.
+ (File_Name_to_gnu): New function.
+ (gigi): Call it to translate file names. Replace assertion on
+ 1-1 mapping between files and line maps with conditional error.
+
+2021-04-11 Gerald Pfeifer <gerald@pfeifer.com>
+
+ * gnat_ugn.texi (Top): Avoid invalid "up" link.
+
+2021-03-29 Eric Botcazou <ebotcazou@adacore.com>
+
+ PR ada/99802
+ * freeze.adb (Is_Full_Access_Aggregate): Call Is_Full_Access_Object
+ on the name of an N_Assignment_Statement to spot full access.
+
2021-03-10 Eric Botcazou <ebotcazou@adacore.com>
* gcc-interface/decl.c (gnat_to_gnu_entity): Build a TYPE_STUB_DECL
diff --git a/gcc/ada/Make-generated.in b/gcc/ada/Make-generated.in
index 757eaa8..948fc50 100644
--- a/gcc/ada/Make-generated.in
+++ b/gcc/ada/Make-generated.in
@@ -2,10 +2,6 @@
# Note: can't use ?= here, not supported by older versions of GNU Make
-ifeq ($(origin ADA_GEN_SUBDIR), undefined)
-ADA_GEN_SUBDIR=ada
-endif
-
ifeq ($(origin CP), undefined)
CP=cp
endif
@@ -14,60 +10,50 @@ ifeq ($(origin MKDIR), undefined)
MKDIR=mkdir -p
endif
-ifeq ($(origin MOVE_IF_CHANGE), undefined)
-MOVE_IF_CHANGE=mv -f
-endif
-
-.PHONY: ada_extra_files
-ada_extra_files : $(ADA_GEN_SUBDIR)/treeprs.ads $(ADA_GEN_SUBDIR)/einfo.h $(ADA_GEN_SUBDIR)/sinfo.h $(ADA_GEN_SUBDIR)/nmake.adb \
- $(ADA_GEN_SUBDIR)/nmake.ads $(ADA_GEN_SUBDIR)/snames.ads $(ADA_GEN_SUBDIR)/snames.adb $(ADA_GEN_SUBDIR)/snames.h
+fsrcdir := $(shell cd $(srcdir);${PWD_COMMAND})
-# We delete the files before copying, below, in case they are read-only.
+GEN_IL_INCLUDES = -I$(fsrcdir)/ada
+GEN_IL_FLAGS = -gnata -gnat2012 -gnatw.g -gnatyg -gnatU $(GEN_IL_INCLUDES)
-$(ADA_GEN_SUBDIR)/treeprs.ads : $(ADA_GEN_SUBDIR)/treeprs.adt $(ADA_GEN_SUBDIR)/sinfo.ads $(ADA_GEN_SUBDIR)/xtreeprs.adb
- -$(MKDIR) $(ADA_GEN_SUBDIR)/bldtools/treeprs
- $(RM) $(addprefix $(ADA_GEN_SUBDIR)/bldtools/treeprs/,$(notdir $^))
- $(CP) $^ $(ADA_GEN_SUBDIR)/bldtools/treeprs
- (cd $(ADA_GEN_SUBDIR)/bldtools/treeprs; gnatmake -q xtreeprs ; ./xtreeprs treeprs.ads )
- $(MOVE_IF_CHANGE) $(ADA_GEN_SUBDIR)/bldtools/treeprs/treeprs.ads $(ADA_GEN_SUBDIR)/treeprs.ads
+ada/seinfo_tables.ads ada/seinfo_tables.adb ada/sinfo.h ada/einfo.h ada/nmake.ads ada/nmake.adb ada/seinfo.ads ada/sinfo-nodes.ads ada/sinfo-nodes.adb ada/einfo-entities.ads ada/einfo-entities.adb: ada/stamp-gen_il ; @true
+ada/stamp-gen_il: $(fsrcdir)/ada/gen_il*
+ $(MKDIR) ada/gen_il
+ cd ada/gen_il; gnatmake -q -g $(GEN_IL_FLAGS) gen_il-main
+ # Ignore errors to work around finalization issues in older compilers
+ - cd ada/gen_il; ./gen_il-main
+ $(fsrcdir)/../move-if-change ada/gen_il/seinfo_tables.ads ada/seinfo_tables.ads
+ $(fsrcdir)/../move-if-change ada/gen_il/seinfo_tables.adb ada/seinfo_tables.adb
+ $(fsrcdir)/../move-if-change ada/gen_il/sinfo.h ada/sinfo.h
+ $(fsrcdir)/../move-if-change ada/gen_il/einfo.h ada/einfo.h
+ $(fsrcdir)/../move-if-change ada/gen_il/nmake.ads ada/nmake.ads
+ $(fsrcdir)/../move-if-change ada/gen_il/nmake.adb ada/nmake.adb
+ $(fsrcdir)/../move-if-change ada/gen_il/seinfo.ads ada/seinfo.ads
+ $(fsrcdir)/../move-if-change ada/gen_il/sinfo-nodes.ads ada/sinfo-nodes.ads
+ $(fsrcdir)/../move-if-change ada/gen_il/sinfo-nodes.adb ada/sinfo-nodes.adb
+ $(fsrcdir)/../move-if-change ada/gen_il/einfo-entities.ads ada/einfo-entities.ads
+ $(fsrcdir)/../move-if-change ada/gen_il/einfo-entities.adb ada/einfo-entities.adb
+ touch ada/stamp-gen_il
-$(ADA_GEN_SUBDIR)/einfo.h : $(ADA_GEN_SUBDIR)/einfo.ads $(ADA_GEN_SUBDIR)/einfo.adb $(ADA_GEN_SUBDIR)/xeinfo.adb $(ADA_GEN_SUBDIR)/ceinfo.adb
- -$(MKDIR) $(ADA_GEN_SUBDIR)/bldtools/einfo
- $(RM) $(addprefix $(ADA_GEN_SUBDIR)/bldtools/einfo/,$(notdir $^))
- $(CP) $^ $(ADA_GEN_SUBDIR)/bldtools/einfo
- (cd $(ADA_GEN_SUBDIR)/bldtools/einfo; gnatmake -q xeinfo ; ./xeinfo einfo.h )
- $(MOVE_IF_CHANGE) $(ADA_GEN_SUBDIR)/bldtools/einfo/einfo.h $(ADA_GEN_SUBDIR)/einfo.h
+# We need -gnatX to compile seinfo_tables, because it uses extensions. This
+# target is not currently used when building gnat, because these extensions
+# would cause bootstrapping with older compilers to fail. You can call it by
+# hand, as a sanity check that these files are legal.
+ada/seinfo_tables.o: ada/seinfo_tables.ads ada/seinfo_tables.adb
+ cd ada ; gnatmake $(GEN_IL_INCLUDES) seinfo_tables.adb -gnatU -gnatX
-$(ADA_GEN_SUBDIR)/sinfo.h : $(ADA_GEN_SUBDIR)/sinfo.ads $(ADA_GEN_SUBDIR)/sinfo.adb $(ADA_GEN_SUBDIR)/xsinfo.adb $(ADA_GEN_SUBDIR)/csinfo.adb
- -$(MKDIR) $(ADA_GEN_SUBDIR)/bldtools/sinfo
- $(RM) $(addprefix $(ADA_GEN_SUBDIR)/bldtools/sinfo/,$(notdir $^))
- $(CP) $^ $(ADA_GEN_SUBDIR)/bldtools/sinfo
- (cd $(ADA_GEN_SUBDIR)/bldtools/sinfo; gnatmake -q xsinfo ; ./xsinfo sinfo.h )
- $(MOVE_IF_CHANGE) $(ADA_GEN_SUBDIR)/bldtools/sinfo/sinfo.h $(ADA_GEN_SUBDIR)/sinfo.h
+ada/snames.h ada/snames.ads ada/snames.adb : ada/stamp-snames ; @true
+ada/stamp-snames : ada/snames.ads-tmpl ada/snames.adb-tmpl ada/snames.h-tmpl ada/xsnamest.adb ada/xutil.ads ada/xutil.adb
+ -$(MKDIR) ada/bldtools/snamest
+ $(RM) $(addprefix ada/bldtools/snamest/,$(notdir $^))
+ $(CP) $^ ada/bldtools/snamest
+ cd ada/bldtools/snamest; gnatmake -q xsnamest ; ./xsnamest
+ $(fsrcdir)/../move-if-change ada/bldtools/snamest/snames.ns ada/snames.ads
+ $(fsrcdir)/../move-if-change ada/bldtools/snamest/snames.nb ada/snames.adb
+ $(fsrcdir)/../move-if-change ada/bldtools/snamest/snames.nh ada/snames.h
+ touch ada/stamp-snames
-$(ADA_GEN_SUBDIR)/snames.h $(ADA_GEN_SUBDIR)/snames.ads $(ADA_GEN_SUBDIR)/snames.adb : $(ADA_GEN_SUBDIR)/stamp-snames ; @true
-$(ADA_GEN_SUBDIR)/stamp-snames : $(ADA_GEN_SUBDIR)/snames.ads-tmpl $(ADA_GEN_SUBDIR)/snames.adb-tmpl $(ADA_GEN_SUBDIR)/snames.h-tmpl $(ADA_GEN_SUBDIR)/xsnamest.adb $(ADA_GEN_SUBDIR)/xutil.ads $(ADA_GEN_SUBDIR)/xutil.adb
- -$(MKDIR) $(ADA_GEN_SUBDIR)/bldtools/snamest
- $(RM) $(addprefix $(ADA_GEN_SUBDIR)/bldtools/snamest/,$(notdir $^))
- $(CP) $^ $(ADA_GEN_SUBDIR)/bldtools/snamest
- (cd $(ADA_GEN_SUBDIR)/bldtools/snamest; gnatmake -q xsnamest ; ./xsnamest )
- $(MOVE_IF_CHANGE) $(ADA_GEN_SUBDIR)/bldtools/snamest/snames.ns $(ADA_GEN_SUBDIR)/snames.ads
- $(MOVE_IF_CHANGE) $(ADA_GEN_SUBDIR)/bldtools/snamest/snames.nb $(ADA_GEN_SUBDIR)/snames.adb
- $(MOVE_IF_CHANGE) $(ADA_GEN_SUBDIR)/bldtools/snamest/snames.nh $(ADA_GEN_SUBDIR)/snames.h
- touch $(ADA_GEN_SUBDIR)/stamp-snames
-
-$(ADA_GEN_SUBDIR)/nmake.adb $(ADA_GEN_SUBDIR)/nmake.ads: $(ADA_GEN_SUBDIR)/stamp-nmake ; @true
-$(ADA_GEN_SUBDIR)/stamp-nmake: $(ADA_GEN_SUBDIR)/sinfo.ads $(ADA_GEN_SUBDIR)/nmake.adt $(ADA_GEN_SUBDIR)/xnmake.adb $(ADA_GEN_SUBDIR)/xutil.ads $(ADA_GEN_SUBDIR)/xutil.adb
- -$(MKDIR) $(ADA_GEN_SUBDIR)/bldtools/nmake
- $(RM) $(addprefix $(ADA_GEN_SUBDIR)/bldtools/nmake/,$(notdir $^))
- $(CP) $^ $(ADA_GEN_SUBDIR)/bldtools/nmake
- (cd $(ADA_GEN_SUBDIR)/bldtools/nmake; gnatmake -q xnmake ; ./xnmake -b nmake.adb ; ./xnmake -s nmake.ads)
- $(MOVE_IF_CHANGE) $(ADA_GEN_SUBDIR)/bldtools/nmake/nmake.ads $(ADA_GEN_SUBDIR)/nmake.ads
- $(MOVE_IF_CHANGE) $(ADA_GEN_SUBDIR)/bldtools/nmake/nmake.adb $(ADA_GEN_SUBDIR)/nmake.adb
- touch $(ADA_GEN_SUBDIR)/stamp-nmake
-
-$(ADA_GEN_SUBDIR)/sdefault.adb: $(ADA_GEN_SUBDIR)/stamp-sdefault ; @true
-$(ADA_GEN_SUBDIR)/stamp-sdefault : $(srcdir)/version.c Makefile
+ada/sdefault.adb: ada/stamp-sdefault ; @true
+ada/stamp-sdefault : $(srcdir)/ada/version.c Makefile
$(ECHO) "pragma Style_Checks (Off);" >tmp-sdefault.adb
$(ECHO) "with Osint; use Osint;" >>tmp-sdefault.adb
$(ECHO) "package body Sdefault is" >>tmp-sdefault.adb
@@ -93,5 +79,8 @@ $(ADA_GEN_SUBDIR)/stamp-sdefault : $(srcdir)/version.c Makefile
$(ECHO) " return Relocate_Path (S0, S4);" >>tmp-sdefault.adb
$(ECHO) " end Search_Dir_Prefix;" >>tmp-sdefault.adb
$(ECHO) "end Sdefault;" >> tmp-sdefault.adb
- $(MOVE_IF_CHANGE) tmp-sdefault.adb $(ADA_GEN_SUBDIR)/sdefault.adb
- touch $(ADA_GEN_SUBDIR)/stamp-sdefault
+ $(fsrcdir)/../move-if-change tmp-sdefault.adb ada/sdefault.adb
+ touch ada/stamp-sdefault
+
+ada/%: $(srcdir)/ada/libgnat/%
+ $(CP) -f $< $@
diff --git a/gcc/ada/Makefile.rtl b/gcc/ada/Makefile.rtl
index 987eff0..fb851a6 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-2020, Free Software Foundation, Inc.
+# Copyright (C) 2003-2021, Free Software Foundation, Inc.
#This file is part of GCC.
@@ -275,13 +275,7 @@ 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) \
@@ -295,7 +289,12 @@ GNATRTL_NONTASKING_OBJS= \
a-strsup$(objext) \
a-strunb$(objext) \
a-ststio$(objext) \
- a-stteou$(objext) \
+ a-sttebu$(objext) \
+ a-stbuun$(objext) \
+ a-stbubo$(objext) \
+ a-stbuut$(objext) \
+ a-stbufi$(objext) \
+ a-stbufo$(objext) \
a-stunau$(objext) \
a-stunha$(objext) \
a-stuten$(objext) \
@@ -575,6 +574,7 @@ GNATRTL_NONTASKING_OBJS= \
s-dlmkio$(objext) \
s-dlmopr$(objext) \
s-dmotpr$(objext) \
+ s-dourea$(objext) \
s-dsaser$(objext) \
s-elaall$(objext) \
s-excdeb$(objext) \
@@ -582,6 +582,8 @@ GNATRTL_NONTASKING_OBJS= \
s-exctab$(objext) \
s-exctra$(objext) \
s-exnint$(objext) \
+ s-exnflt$(objext) \
+ s-exnlfl$(objext) \
s-exnllf$(objext) \
s-exnlli$(objext) \
s-expint$(objext) \
@@ -589,6 +591,7 @@ GNATRTL_NONTASKING_OBJS= \
s-expllu$(objext) \
s-expmod$(objext) \
s-exponn$(objext) \
+ s-exponr$(objext) \
s-expont$(objext) \
s-exponu$(objext) \
s-expuns$(objext) \
@@ -618,18 +621,24 @@ GNATRTL_NONTASKING_OBJS= \
s-imaged$(objext) \
s-imagef$(objext) \
s-imagei$(objext) \
+ s-imagen$(objext) \
+ s-imager$(objext) \
s-imageu$(objext) \
s-imagew$(objext) \
s-imde32$(objext) \
s-imde64$(objext) \
- s-imenne$(objext) \
+ s-imen16$(objext) \
+ s-imen32$(objext) \
+ s-imenu8$(objext) \
s-imfi32$(objext) \
s-imfi64$(objext) \
s-imgbiu$(objext) \
s-imgboo$(objext) \
s-imgcha$(objext) \
- s-imgenu$(objext) \
+ s-imgflt$(objext) \
s-imgint$(objext) \
+ s-imglfl$(objext) \
+ s-imgllf$(objext) \
s-imgllb$(objext) \
s-imglli$(objext) \
s-imgllu$(objext) \
@@ -709,6 +718,7 @@ GNATRTL_NONTASKING_OBJS= \
s-pack63$(objext) \
s-parame$(objext) \
s-parint$(objext) \
+ s-pehage$(objext) \
s-pooglo$(objext) \
s-pooloc$(objext) \
s-poosiz$(objext) \
@@ -754,9 +764,11 @@ GNATRTL_NONTASKING_OBJS= \
s-valcha$(objext) \
s-vade32$(objext) \
s-vade64$(objext) \
+ s-vaen16$(objext) \
+ s-vaen32$(objext) \
+ s-vaenu8$(objext) \
s-vafi32$(objext) \
s-vafi64$(objext) \
- s-valenu$(objext) \
s-valflt$(objext) \
s-valint$(objext) \
s-vallfl$(objext) \
@@ -767,6 +779,7 @@ GNATRTL_NONTASKING_OBJS= \
s-valued$(objext) \
s-valuef$(objext) \
s-valuei$(objext) \
+ s-valuen$(objext) \
s-valuer$(objext) \
s-valueu$(objext) \
s-valuns$(objext) \
@@ -1030,7 +1043,7 @@ EXTRA_GNATRTL_NONTASKING_OBJS=
EXTRA_GNATRTL_TASKING_OBJS=
# Subsets of extra libgnat sources that always go together
-VX_SIGTRAMP_EXTRA_SRCS=sigtramp.h sigtramp-vxworks-target.inc
+VX_SIGTRAMP_EXTRA_SRCS=sigtramp.h sigtramp-vxworks-target.h
# Additional object files that should go in the same directory as libgnat,
# aside the library itself. Typically useful for crtbegin/crtend kind of files.
@@ -1069,12 +1082,13 @@ ifeq ($(strip $(filter-out powerpc% wrs vxworks vxworksspe vxworks7% vxworks7spe
a-naliop.ads<libgnat/a-naliop__nolibm.ads \
a-nuaufl.ads<libgnat/a-nuaufl__wraplf.ads \
a-nashfl.ads<libgnat/a-nashfl__wraplf.ads \
+ s-dorepr.adb<libgnat/s-dorepr__fma.adb \
s-inmaop.adb<libgnarl/s-inmaop__vxworks.adb \
s-intman.ads<libgnarl/s-intman__vxworks.ads \
s-intman.adb<libgnarl/s-intman__vxworks.adb \
s-osinte.ads<libgnarl/s-osinte__vxworks.ads \
s-osinte.adb<libgnarl/s-osinte__vxworks.adb \
- s-osprim.adb<libgnat/s-osprim__vxworks.adb \
+ s-osprim.adb<libgnat/s-osprim__posix.adb \
s-parame.ads<libgnat/s-parame__vxworks.ads \
s-parame.adb<libgnat/s-parame__vxworks.adb \
s-taprop.adb<libgnarl/s-taprop__vxworks.adb \
@@ -1202,6 +1216,7 @@ ifeq ($(strip $(filter-out powerpc% wrs vxworksae vxworksaespe,$(target_cpu) $(t
a-nuaufl.ads<libgnat/a-nuaufl__wraplf.ads \
a-nashfl.ads<libgnat/a-nashfl__wraplf.ads \
g-io.adb<hie/g-io__vxworks-cert.adb \
+ s-dorepr.adb<libgnat/s-dorepr__fma.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 \
@@ -1218,9 +1233,9 @@ ifeq ($(strip $(filter-out powerpc% wrs vxworksae vxworksaespe,$(target_cpu) $(t
s-vxwext.adb<libgnarl/s-vxwext__noints.adb \
s-vxwext.ads<libgnarl/s-vxwext__vthreads.ads \
s-vxwork.ads<libgnarl/s-vxwork__ppc.ads \
- system.ads<libgnat/system-vxworks-$(ARCH_STR)-vthread.ads \
$(ATOMICS_TARGET_PAIRS) \
- $(ATOMICS_BUILTINS_TARGET_PAIRS)
+ $(ATOMICS_BUILTINS_TARGET_PAIRS) \
+ system.ads<libgnat/system-vxworks-$(ARCH_STR)-vthread.ads
EH_MECHANISM=-gcc
@@ -1324,7 +1339,7 @@ ifeq ($(strip $(filter-out %86 x86_64 wrs vxworks vxworks7%,$(target_cpu) $(targ
s-inmaop.adb<libgnarl/s-inmaop__vxworks.adb \
s-intman.ads<libgnarl/s-intman__vxworks.ads \
s-intman.adb<libgnarl/s-intman__vxworks.adb \
- s-osprim.adb<libgnat/s-osprim__vxworks.adb \
+ s-osprim.adb<libgnat/s-osprim__posix.adb \
s-parame.ads<libgnat/s-parame__vxworks.ads \
s-parame.adb<libgnat/s-parame__vxworks.adb \
s-stchop.ads<libgnat/s-stchop__limit.ads \
@@ -1435,12 +1450,12 @@ ifeq ($(strip $(filter-out %86 x86_64 wrs vxworks vxworks7%,$(target_cpu) $(targ
endif
endif
- EXTRA_GNATRTL_NONTASKING_OBJS += i-vxwork.o i-vxwoio.o
+ EXTRA_GNATRTL_NONTASKING_OBJS += i-vxinco.o i-vxwork.o i-vxwoio.o
endif
endif
EXTRA_GNATRTL_NONTASKING_OBJS += s-stchop.o
- EXTRA_GNATRTL_TASKING_OBJS += i-vxinco.o s-vxwork.o s-vxwext.o
+ EXTRA_GNATRTL_TASKING_OBJS += s-vxwork.o s-vxwext.o
EXTRA_LIBGNAT_OBJS+=vx_stack_info.o
@@ -1471,7 +1486,7 @@ ifeq ($(strip $(filter-out aarch64 arm% coff wrs vx%,$(target_cpu) $(target_vend
s-intman.adb<libgnarl/s-intman__vxworks.adb \
s-osinte.adb<libgnarl/s-osinte__vxworks.adb \
s-osinte.ads<libgnarl/s-osinte__vxworks.ads \
- s-osprim.adb<libgnat/s-osprim__vxworks.adb \
+ s-osprim.adb<libgnat/s-osprim__posix.adb \
s-parame.ads<libgnat/s-parame__vxworks.ads \
s-parame.adb<libgnat/s-parame__vxworks.adb \
s-stchop.ads<libgnat/s-stchop__limit.ads \
@@ -1490,7 +1505,8 @@ ifeq ($(strip $(filter-out aarch64 arm% coff wrs vx%,$(target_cpu) $(target_vend
EH_MECHANISM=-gcc
SIGTRAMP_OBJ=sigtramp-vxworks.o
LIBGNAT_TARGET_PAIRS += $(GNATRTL_128BIT_PAIRS) \
- a-nallfl.ads<libgnat/a-nallfl__wraplf.ads
+ a-nallfl.ads<libgnat/a-nallfl__wraplf.ads \
+ s-dorepr.adb<libgnat/s-dorepr__fma.adb
EXTRA_GNATRTL_NONTASKING_OBJS += $(GNATRTL_128BIT_OBJS)
else
ifeq ($(strip $(filter-out arm%, $(target_cpu))),)
@@ -1611,6 +1627,7 @@ ifeq ($(strip $(filter-out aarch64 %qnx,$(target_cpu) $(target_os))),)
LIBGNAT_TARGET_PAIRS = \
a-intnam.ads<libgnarl/a-intnam__qnx.ads \
a-nallfl.ads<libgnat/a-nallfl__wraplf.ads \
+ s-dorepr.adb<libgnat/s-dorepr__fma.adb \
s-inmaop.adb<libgnarl/s-inmaop__posix.adb \
s-intman.adb<libgnarl/s-intman__qnx.adb \
s-osinte.adb<libgnarl/s-osinte__qnx.adb \
@@ -1878,6 +1895,7 @@ ifeq ($(strip $(filter-out %aarch64 freebsd%,$(target_cpu) $(target_os))),)
LIBGNAT_TARGET_PAIRS = \
a-intnam.ads<libgnarl/a-intnam__freebsd.ads \
a-nallfl.ads<libgnat/a-nallfl__wraplf.ads \
+ s-dorepr.adb<libgnat/s-dorepr__fma.adb \
s-inmaop.adb<libgnarl/s-inmaop__posix.adb \
s-intman.adb<libgnarl/s-intman__posix.adb \
s-mudido.adb<libgnarl/s-mudido__affinity.adb \
@@ -2144,6 +2162,7 @@ ifeq ($(strip $(filter-out lynxos178%,$(target_os))),)
ifeq ($(strip $(filter-out lynxos178e,$(target_os))),)
LIBGNAT_TARGET_PAIRS += \
+ s-parame.ads<libgnat/s-parame__posix2008.ads \
s-osinte.ads<libgnarl/s-osinte__lynxos178e.ads \
s-osprim.adb<libgnat/s-osprim__posix2008.adb \
s-tracon.adb<hie/s-tracon__ppc-eabi.adb
@@ -2163,6 +2182,7 @@ ifeq ($(strip $(filter-out rtems%,$(target_os))),)
s-osinte.ads<libgnarl/s-osinte__rtems.ads \
s-osprim.adb<libgnat/s-osprim__rtems.adb \
s-parame.adb<libgnat/s-parame__rtems.adb \
+ s-parame.ads<libgnat/s-parame__posix2008.ads \
s-taprop.adb<libgnarl/s-taprop__posix.adb \
s-taspri.ads<libgnarl/s-taspri__posix.ads \
s-tpopsp.adb<libgnarl/s-tpopsp__tls.adb \
@@ -2175,7 +2195,7 @@ ifeq ($(strip $(filter-out rtems%,$(target_os))),)
EH_MECHANISM=-gcc
endif
- ifeq ($(strip $(filter-out riscv%,$(target_cpu))),)
+ ifeq ($(strip $(filter-out aarch64% riscv%,$(target_cpu))),)
LIBGNAT_TARGET_PAIRS += a-nallfl.ads<libgnat/a-nallfl__wraplf.ads
endif
endif
@@ -2342,6 +2362,7 @@ ifeq ($(strip $(filter-out powerpc% linux%,$(target_cpu) $(target_os))),)
a-nallfl.ads<libgnat/a-nallfl__wraplf.ads \
a-synbar.adb<libgnarl/a-synbar__posix.adb \
a-synbar.ads<libgnarl/a-synbar__posix.ads \
+ s-dorepr.adb<libgnat/s-dorepr__fma.adb \
s-inmaop.adb<libgnarl/s-inmaop__posix.adb \
s-intman.adb<libgnarl/s-intman__posix.adb \
s-linux.ads<libgnarl/s-linux.ads \
@@ -2425,9 +2446,11 @@ ifeq ($(strip $(filter-out aarch64% linux%,$(target_cpu) $(target_os))),)
a-nallfl.ads<libgnat/a-nallfl__wraplf.ads \
a-synbar.adb<libgnarl/a-synbar__posix.adb \
a-synbar.ads<libgnarl/a-synbar__posix.ads \
+ s-dorepr.adb<libgnat/s-dorepr__fma.adb \
s-inmaop.adb<libgnarl/s-inmaop__posix.adb \
s-intman.adb<libgnarl/s-intman__posix.adb \
s-linux.ads<libgnarl/s-linux.ads \
+ $(TRASYM_DWARF_UNIX_PAIRS) \
s-mudido.adb<libgnarl/s-mudido__affinity.adb \
s-osinte.ads<libgnarl/s-osinte__linux.ads \
s-osinte.adb<libgnarl/s-osinte__posix.adb \
@@ -2444,7 +2467,8 @@ ifeq ($(strip $(filter-out aarch64% linux%,$(target_cpu) $(target_os))),)
TOOLS_TARGET_PAIRS = indepsw.adb<indepsw-gnu.adb
- EXTRA_GNATRTL_NONTASKING_OBJS = $(GNATRTL_128BIT_OBJS)
+ EXTRA_GNATRTL_NONTASKING_OBJS += $(GNATRTL_128BIT_OBJS) \
+ $(TRASYM_DWARF_UNIX_OBJS)
EXTRA_GNATRTL_TASKING_OBJS=s-linux.o a-exetim.o
EH_MECHANISM=-gcc
THREADSLIB=-lpthread -lrt
@@ -2584,6 +2608,7 @@ ifeq ($(strip $(filter-out %ia64 linux%,$(target_cpu) $(target_os))),)
a-nuauco.ads<libgnat/a-nuauco__x86.ads \
a-synbar.adb<libgnarl/a-synbar__posix.adb \
a-synbar.ads<libgnarl/a-synbar__posix.ads \
+ s-dorepr.adb<libgnat/s-dorepr__fma.adb \
s-inmaop.adb<libgnarl/s-inmaop__posix.adb \
s-intman.adb<libgnarl/s-intman__posix.adb \
s-linux.ads<libgnarl/s-linux.ads \
@@ -2620,6 +2645,7 @@ endif
ifeq ($(strip $(filter-out ia64% hp hpux%,$(target_cpu) $(target_vendor) $(target_os))),)
LIBGNAT_TARGET_PAIRS = \
a-intnam.ads<libgnarl/a-intnam__hpux.ads \
+ s-dorepr.adb<libgnat/s-dorepr__fma.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 \
@@ -2736,6 +2762,7 @@ ifeq ($(strip $(filter-out %x32 linux%,$(target_cpu) $(target_os))),)
s-osinte.ads<libgnarl/s-osinte__linux.ads \
s-osinte.adb<libgnarl/s-osinte__x32.adb \
s-osprim.adb<libgnat/s-osprim__x32.adb \
+ s-parame.ads<libgnat/s-parame__posix2008.ads \
s-taprop.adb<libgnarl/s-taprop__linux.adb \
s-tasinf.ads<libgnarl/s-tasinf__linux.ads \
s-tasinf.adb<libgnarl/s-tasinf__linux.adb \
@@ -2761,6 +2788,7 @@ ifeq ($(strip $(filter-out riscv% linux%,$(target_cpu) $(target_os))),)
LIBGNAT_TARGET_PAIRS = \
a-intnam.ads<libgnarl/a-intnam__linux.ads \
a-nallfl.ads<libgnat/a-nallfl__wraplf.ads \
+ s-dorepr.adb<libgnat/s-dorepr__fma.adb \
s-inmaop.adb<libgnarl/s-inmaop__posix.adb \
s-intman.adb<libgnarl/s-intman__posix.adb \
s-linux.ads<libgnarl/s-linux__riscv.ads \
@@ -2890,6 +2918,7 @@ ifeq ($(strip $(filter-out darwin%,$(target_os))),)
LIBGNAT_TARGET_PAIRS += \
a-nallfl.ads<libgnat/a-nallfl__wraplf.ads \
s-intman.adb<libgnarl/s-intman__susv3.adb \
+ s-dorepr.adb<libgnat/s-dorepr__fma.adb \
s-osprim.adb<libgnat/s-osprim__darwin.adb \
$(ATOMICS_TARGET_PAIRS) \
$(ATOMICS_BUILTINS_TARGET_PAIRS) \
@@ -2933,6 +2962,13 @@ ifeq ($(strip $(filter-out linux%,$(target_os))),)
g-sercom.adb<libgnat/g-sercom__linux.adb
endif
+# Turn on shared gnatlib for specific vx7r2 targets for RTP runtimes. Once
+# all targets are ported the target_cpu selector can be removed.
+ifeq ($(strip $(filter-out vxworks7r2 powerpc64 x86_64 rtp rtp-smp, $(target_os) $(target_cpu) $(THREAD_KIND))),)
+ GNATLIB_SHARED = gnatlib-shared-dual
+ LIBRARY_VERSION := $(LIB_VERSION)
+endif
+
LIBGNAT_TARGET_PAIRS += \
interfac.ads<libgnat/interfac__2020.ads
@@ -2967,7 +3003,7 @@ 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 libgnat/memtrack.adb \
+ libgnat/sequenio.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 \
@@ -2987,21 +3023,10 @@ ADA_EXCLUDE_SRCS =\
g-altive.ads g-alveop.adb g-alveop.ads g-alvety.ads g-alvevi.ads \
g-intpri.ads g-regist.adb g-regist.ads g-sse.ads g-ssvety.ads \
i-vxinco.adb i-vxinco.ads i-vxwoio.adb i-vxwoio.ads i-vxwork.ads \
- s-bb.ads s-bbbosu.ads s-bbcaco.ads s-bbcppr.ads s-bbexti.adb \
- s-bbexti.ads s-bbinte.adb s-bbinte.ads s-bbprot.adb s-bbprot.ads \
- s-bbsle3.ads s-bbsuer.ads s-bbsule.ads s-bbthqu.adb s-bbthqu.ads \
- s-bbthre.adb s-bbthre.ads s-bbtiev.adb s-bbtiev.ads s-bbtime.adb \
- s-bbtime.ads s-bcprmu.adb s-bcprmu.ads s-btstch.adb s-btstch.ads \
- s-gcc.adb s-gcc.ads s-gccdiv.adb s-gccdiv.ads \
- s-gccshi.adb s-gccshi.ads \
- s-init.ads s-init.adb s-linux.ads s-macres.ads \
- s-memcom.adb s-memcom.ads s-memmov.adb s-memmov.ads s-memset.adb \
- s-memset.ads s-mufalo.adb s-mufalo.ads s-musplo.adb s-musplo.ads \
- s-sam4.ads s-sopco3.adb s-sopco3.ads s-sopco4.adb s-sopco4.ads \
- s-sopco5.adb s-sopco5.ads s-stchop.ads s-stchop.adb s-stm32.ads \
+ s-linux.ads s-vxwext.adb s-vxwext.ads s-win32.ads s-winext.ads \
+ s-sopco3.adb s-sopco3.ads s-sopco4.adb s-sopco4.ads \
+ s-sopco5.adb s-sopco5.ads s-stchop.ads s-stchop.adb \
s-strcom.adb s-strcom.ads s-thread.ads \
- s-vxwext.adb s-vxwext.ads \
- s-win32.ads s-winext.ads
# ADA_EXCLUDE_SRCS without the sources used by the target
ADA_EXCLUDE_FILES=$(filter-out \
diff --git a/gcc/ada/ada_get_targ.adb b/gcc/ada/ada_get_targ.adb
index 123ba4e..6098478 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -214,7 +214,7 @@ package body Get_Targ is
function Get_Max_Unaligned_Field return Pos is
begin
- return 64; -- Can be different on some targets (e.g., AAMP)
+ return 64; -- Can be different on some targets
end Get_Max_Unaligned_Field;
-----------------------------
diff --git a/gcc/ada/adabkend.adb b/gcc/ada/adabkend.adb
index b10c0bd..2ad58ef 100644
--- a/gcc/ada/adabkend.adb
+++ b/gcc/ada/adabkend.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2001-2020, AdaCore --
+-- Copyright (C) 2001-2021, 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/adabkend.ads b/gcc/ada/adabkend.ads
index c641cb0..86b1bce 100644
--- a/gcc/ada/adabkend.ads
+++ b/gcc/ada/adabkend.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute 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 43a378f..1e8d306 100644
--- a/gcc/ada/adadecode.c
+++ b/gcc/ada/adadecode.c
@@ -6,7 +6,7 @@
* *
* C Implementation File *
* *
- * Copyright (C) 2001-2020, Free Software Foundation, Inc. *
+ * Copyright (C) 2001-2021, Free Software Foundation, Inc. *
* *
* GNAT is free software; you can redistribute 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 0db7040..a2ac9d2 100644
--- a/gcc/ada/adadecode.h
+++ b/gcc/ada/adadecode.h
@@ -6,7 +6,7 @@
* *
* C Header File *
* *
- * Copyright (C) 2001-2020, Free Software Foundation, Inc. *
+ * Copyright (C) 2001-2021, Free Software Foundation, Inc. *
* *
* GNAT is free software; you can redistribute 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 0a90c92..06a4895 100644
--- a/gcc/ada/adaint.c
+++ b/gcc/ada/adaint.c
@@ -6,7 +6,7 @@
* *
* C Implementation File *
* *
- * Copyright (C) 1992-2020, Free Software Foundation, Inc. *
+ * Copyright (C) 1992-2021, Free Software Foundation, Inc. *
* *
* GNAT is free software; you can redistribute it and/or modify it under *
* terms of the GNU General Public License as published by the Free Soft- *
@@ -1570,7 +1570,7 @@ extern long long __gnat_file_time(char* name)
/* Set the file time stamp. */
void
-__gnat_set_file_time_name (char *name, time_t time_stamp)
+__gnat_set_file_time_name (char *name, OS_Time time_stamp)
{
#if defined (__vxworks)
@@ -1606,7 +1606,7 @@ __gnat_set_file_time_name (char *name, time_t time_stamp)
time_t t;
/* Set modification time to requested time. */
- utimbuf.modtime = time_stamp;
+ utimbuf.modtime = (time_t) time_stamp;
/* Set access time to now in local time. */
t = time (NULL);
@@ -2423,7 +2423,6 @@ __gnat_portable_spawn (char *args[] ATTRIBUTE_UNUSED)
if (pid == 0)
{
/* The child. */
- __gnat_in_child_after_fork = 1;
if (execv (args[0], MAYBE_TO_PTR32 (args)) != 0)
_exit (1);
}
@@ -2486,7 +2485,7 @@ __gnat_number_of_cpus (void)
{
int cores = 1;
-#ifdef _SC_NPROCESSORS_ONLN
+#if defined (_SC_NPROCESSORS_ONLN)
cores = (int) sysconf (_SC_NPROCESSORS_ONLN);
#elif defined (__QNX__)
diff --git a/gcc/ada/adaint.h b/gcc/ada/adaint.h
index 85997b9..a63ceef 100644
--- a/gcc/ada/adaint.h
+++ b/gcc/ada/adaint.h
@@ -6,7 +6,7 @@
* *
* C Header File *
* *
- * Copyright (C) 1992-2020, Free Software Foundation, Inc. *
+ * Copyright (C) 1992-2021, Free Software Foundation, Inc. *
* *
* GNAT is 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,11 +101,7 @@ extern "C" {
#endif
/* Type corresponding to GNAT.OS_Lib.OS_Time */
-#if defined (_WIN64)
typedef long long OS_Time;
-#else
-typedef long OS_Time;
-#endif
#define __int64 long long
GNAT_STRUCT_STAT;
@@ -205,7 +201,7 @@ extern OS_Time __gnat_file_time_name (char *);
extern OS_Time __gnat_file_time_fd (int);
/* return -1 in case of error */
-extern void __gnat_set_file_time_name (char *, time_t);
+extern void __gnat_set_file_time_name (char *, OS_Time);
extern int __gnat_dup (int);
extern int __gnat_dup2 (int, int);
diff --git a/gcc/ada/affinity.c b/gcc/ada/affinity.c
index 10fdd35..6a3dbb2 100644
--- a/gcc/ada/affinity.c
+++ b/gcc/ada/affinity.c
@@ -6,7 +6,7 @@
* *
* C Implementation File *
* *
- * Copyright (C) 2005-2020, Free Software Foundation, Inc. *
+ * Copyright (C) 2005-2021, Free Software Foundation, Inc. *
* *
* GNAT is free software; you can redistribute 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 7dabbfb..9074a9a 100644
--- a/gcc/ada/ali-util.adb
+++ b/gcc/ada/ali-util.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute 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 dfa5efe4..e7e1c0d 100644
--- a/gcc/ada/ali-util.ads
+++ b/gcc/ada/ali-util.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute 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 f213c30..24f1677 100644
--- a/gcc/ada/ali.adb
+++ b/gcc/ada/ali.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -894,8 +894,6 @@ package body ALI is
T : Text_Buffer_Ptr;
Ignore_ED : Boolean;
Err : Boolean;
- Read_Xref : Boolean := False;
- Read_Lines : String := "";
Ignore_Lines : String := "X";
Ignore_Errors : Boolean := False;
Directly_Scanned : Boolean := False) return ALI_Id
@@ -907,7 +905,8 @@ package body ALI is
NS_Found : Boolean;
First_Arg : Arg_Id;
- Ignore : array (Character range 'A' .. 'Z') of Boolean;
+ Ignore : array (Character range 'A' .. 'Z') of Boolean :=
+ (others => False);
-- Ignore (X) is set to True if lines starting with X are to
-- be ignored by Scan_ALI and skipped, and False if the lines
-- are to be read and processed.
@@ -1006,16 +1005,6 @@ package body ALI is
function Nextc return Character;
-- Return current character without modifying pointer P
- procedure Get_Typeref
- (Current_File_Num : Sdep_Id;
- Ref : out Tref_Kind;
- File_Num : out Sdep_Id;
- Line : out Nat;
- Ref_Type : out Character;
- Col : out Nat;
- Standard_Entity : out Name_Id);
- -- Parse the definition of a typeref (<...>, {...} or (...))
-
procedure Scan_Invocation_Graph_Line;
-- Parse a single line that encodes a piece of the invocation graph
@@ -1423,94 +1412,6 @@ package body ALI is
return T;
end Get_Stamp;
- -----------------
- -- Get_Typeref --
- -----------------
-
- procedure Get_Typeref
- (Current_File_Num : Sdep_Id;
- Ref : out Tref_Kind;
- File_Num : out Sdep_Id;
- Line : out Nat;
- Ref_Type : out Character;
- Col : out Nat;
- Standard_Entity : out Name_Id)
- is
- N : Nat;
- begin
- case Nextc is
- when '<' => Ref := Tref_Derived;
- when '(' => Ref := Tref_Access;
- when '{' => Ref := Tref_Type;
- when others => Ref := Tref_None;
- end case;
-
- -- Case of typeref field present
-
- if Ref /= Tref_None then
- P := P + 1; -- skip opening bracket
-
- if Nextc in 'a' .. 'z' then
- File_Num := No_Sdep_Id;
- Line := 0;
- Ref_Type := ' ';
- Col := 0;
- Standard_Entity := Get_Name (Ignore_Spaces => True);
- else
- N := Get_Nat;
-
- if Nextc = '|' then
- File_Num := Sdep_Id (N + Nat (First_Sdep_Entry) - 1);
- P := P + 1;
- N := Get_Nat;
- else
- File_Num := Current_File_Num;
- end if;
-
- Line := N;
- Ref_Type := Getc;
- Col := Get_Nat;
- Standard_Entity := No_Name;
- end if;
-
- -- ??? Temporary workaround for nested generics case:
- -- 4i4 Directories{1|4I9[4|6[3|3]]}
- -- See C918-002
-
- declare
- Nested_Brackets : Natural := 0;
-
- begin
- loop
- case Nextc is
- when '[' =>
- Nested_Brackets := Nested_Brackets + 1;
- when ']' =>
- Nested_Brackets := Nested_Brackets - 1;
- when others =>
- if Nested_Brackets = 0 then
- exit;
- end if;
- end case;
-
- Skipc;
- end loop;
- end;
-
- P := P + 1; -- skip closing bracket
- Skip_Space;
-
- -- No typeref entry present
-
- else
- File_Num := No_Sdep_Id;
- Line := 0;
- Ref_Type := ' ';
- Col := 0;
- Standard_Entity := No_Name;
- end if;
- end Get_Typeref;
-
----------
-- Getc --
----------
@@ -1836,31 +1737,10 @@ package body ALI is
begin
First_Sdep_Entry := Sdep.Last + 1;
- -- Acquire lines to be ignored
-
- if Read_Xref then
- Ignore :=
- ('T' | 'U' | 'W' | 'Y' | 'Z' | 'D' | 'X' => False, others => True);
-
- -- Read_Lines parameter given
-
- elsif Read_Lines /= "" then
- Ignore := ('U' => False, others => True);
-
- for J in Read_Lines'Range loop
- Ignore (Read_Lines (J)) := False;
- end loop;
-
- -- Process Ignore_Lines parameter
-
- else
- Ignore := (others => False);
-
- for J in Ignore_Lines'Range loop
- pragma Assert (Ignore_Lines (J) /= 'U');
- Ignore (Ignore_Lines (J)) := True;
- end loop;
- end if;
+ for J in Ignore_Lines'Range loop
+ pragma Assert (Ignore_Lines (J) /= 'U');
+ Ignore (Ignore_Lines (J)) := True;
+ end loop;
-- Setup ALI Table entry with appropriate defaults
@@ -3465,347 +3345,7 @@ package body ALI is
Fatal_Error;
end if;
- -- If we are ignoring Xref sections we are done (we ignore all
- -- remaining lines since only xref related lines follow X).
-
- if Ignore ('X') and then not Debug_Flag_X then
- return Id;
- end if;
-
- -- Loop through Xref sections
-
- X_Loop : loop
- Check_Unknown_Line;
- exit X_Loop when C /= 'X';
-
- -- Make new entry in section table
-
- Xref_Section.Increment_Last;
-
- Read_Refs_For_One_File : declare
- XS : Xref_Section_Record renames
- Xref_Section.Table (Xref_Section.Last);
-
- Current_File_Num : Sdep_Id;
- -- Keeps track of the current file number (changed by nn|)
-
- begin
- XS.File_Num := Sdep_Id (Get_Nat + Nat (First_Sdep_Entry) - 1);
- XS.File_Name := Get_File_Name;
- XS.First_Entity := Xref_Entity.Last + 1;
-
- Current_File_Num := XS.File_Num;
-
- Skip_Space;
-
- Skip_Eol;
- C := Nextc;
-
- -- Loop through Xref entities
-
- while C /= 'X' and then C /= EOF loop
- Xref_Entity.Increment_Last;
-
- Read_Refs_For_One_Entity : declare
- XE : Xref_Entity_Record renames
- Xref_Entity.Table (Xref_Entity.Last);
- N : Nat;
-
- procedure Read_Instantiation_Reference;
- -- Acquire instantiation reference. Caller has checked
- -- that current character is '[' and on return the cursor
- -- is skipped past the corresponding closing ']'.
-
- ----------------------------------
- -- Read_Instantiation_Reference --
- ----------------------------------
-
- procedure Read_Instantiation_Reference is
- Local_File_Num : Sdep_Id := Current_File_Num;
-
- begin
- Xref.Increment_Last;
-
- declare
- XR : Xref_Record renames Xref.Table (Xref.Last);
-
- begin
- P := P + 1; -- skip [
- N := Get_Nat;
-
- if Nextc = '|' then
- XR.File_Num :=
- Sdep_Id (N + Nat (First_Sdep_Entry) - 1);
- Local_File_Num := XR.File_Num;
- P := P + 1;
- N := Get_Nat;
-
- else
- XR.File_Num := Local_File_Num;
- end if;
-
- XR.Line := N;
- XR.Rtype := ' ';
- XR.Col := 0;
-
- -- Recursive call for next reference
-
- if Nextc = '[' then
- pragma Warnings (Off); -- kill recursion warning
- Read_Instantiation_Reference;
- pragma Warnings (On);
- end if;
-
- -- Skip closing bracket after recursive call
-
- P := P + 1;
- end;
- end Read_Instantiation_Reference;
-
- -- Start of processing for Read_Refs_For_One_Entity
-
- begin
- XE.Line := Get_Nat;
- XE.Etype := Getc;
- XE.Col := Get_Nat;
-
- case Getc is
- when '*' =>
- XE.Visibility := Global;
- when '+' =>
- XE.Visibility := Static;
- when others =>
- XE.Visibility := Other;
- end case;
-
- XE.Entity := Get_Name;
-
- -- Handle the information about generic instantiations
-
- if Nextc = '[' then
- Skipc; -- Opening '['
- N := Get_Nat;
-
- if Nextc /= '|' then
- XE.Iref_File_Num := Current_File_Num;
- XE.Iref_Line := N;
- else
- XE.Iref_File_Num :=
- Sdep_Id (N + Nat (First_Sdep_Entry) - 1);
- Skipc;
- XE.Iref_Line := Get_Nat;
- end if;
-
- if Getc /= ']' then
- Fatal_Error;
- end if;
-
- else
- XE.Iref_File_Num := No_Sdep_Id;
- XE.Iref_Line := 0;
- end if;
-
- Current_File_Num := XS.File_Num;
-
- -- Renaming reference is present
-
- if Nextc = '=' then
- P := P + 1;
- XE.Rref_Line := Get_Nat;
-
- if Getc /= ':' then
- Fatal_Error;
- end if;
-
- XE.Rref_Col := Get_Nat;
-
- -- No renaming reference present
-
- else
- XE.Rref_Line := 0;
- XE.Rref_Col := 0;
- end if;
-
- Skip_Space;
-
- XE.Oref_File_Num := No_Sdep_Id;
- XE.Tref_File_Num := No_Sdep_Id;
- XE.Tref := Tref_None;
- XE.First_Xref := Xref.Last + 1;
-
- -- Loop to check for additional info present
-
- loop
- declare
- Ref : Tref_Kind;
- File : Sdep_Id;
- Line : Nat;
- Typ : Character;
- Col : Nat;
- Std : Name_Id;
-
- begin
- Get_Typeref
- (Current_File_Num, Ref, File, Line, Typ, Col, Std);
- exit when Ref = Tref_None;
-
- -- Do we have an overriding procedure?
-
- if Ref = Tref_Derived and then Typ = 'p' then
- XE.Oref_File_Num := File;
- XE.Oref_Line := Line;
- XE.Oref_Col := Col;
-
- -- Arrays never override anything, and <> points to
- -- the index types instead
-
- elsif Ref = Tref_Derived and then XE.Etype = 'A' then
-
- -- Index types are stored in the list of references
-
- Xref.Increment_Last;
-
- declare
- XR : Xref_Record renames Xref.Table (Xref.Last);
- begin
- XR.File_Num := File;
- XR.Line := Line;
- XR.Rtype := Array_Index_Reference;
- XR.Col := Col;
- XR.Name := Std;
- end;
-
- -- Interfaces are stored in the list of references,
- -- although the parent type itself is stored in XE.
- -- The first interface (when there are only
- -- interfaces) is stored in XE.Tref*)
-
- elsif Ref = Tref_Derived
- and then Typ = 'R'
- and then XE.Tref_File_Num /= No_Sdep_Id
- then
- Xref.Increment_Last;
-
- declare
- XR : Xref_Record renames Xref.Table (Xref.Last);
- begin
- XR.File_Num := File;
- XR.Line := Line;
- XR.Rtype := Interface_Reference;
- XR.Col := Col;
- XR.Name := Std;
- end;
-
- else
- XE.Tref := Ref;
- XE.Tref_File_Num := File;
- XE.Tref_Line := Line;
- XE.Tref_Type := Typ;
- XE.Tref_Col := Col;
- XE.Tref_Standard_Entity := Std;
- end if;
- end;
- end loop;
-
- -- Loop through cross-references for this entity
-
- loop
- Skip_Space;
-
- if At_Eol then
- Skip_Eol;
- exit when Nextc /= '.';
- P := P + 1;
- end if;
-
- Xref.Increment_Last;
-
- declare
- XR : Xref_Record renames Xref.Table (Xref.Last);
-
- begin
- N := Get_Nat;
-
- if Nextc = '|' then
- XR.File_Num :=
- Sdep_Id (N + Nat (First_Sdep_Entry) - 1);
- Current_File_Num := XR.File_Num;
- P := P + 1;
- N := Get_Nat;
- else
- XR.File_Num := Current_File_Num;
- end if;
-
- XR.Line := N;
- XR.Rtype := Getc;
-
- -- Imported entities reference as in:
- -- 494b<c,__gnat_copy_attribs>25
-
- if Nextc = '<' then
- Skipc;
- XR.Imported_Lang := Get_Name;
-
- pragma Assert (Nextc = ',');
- Skipc;
-
- XR.Imported_Name := Get_Name;
-
- pragma Assert (Nextc = '>');
- Skipc;
-
- else
- XR.Imported_Lang := No_Name;
- XR.Imported_Name := No_Name;
- end if;
-
- XR.Col := Get_Nat;
-
- if Nextc = '[' then
- Read_Instantiation_Reference;
- end if;
- end;
- end loop;
-
- -- Record last cross-reference
-
- XE.Last_Xref := Xref.Last;
- C := Nextc;
-
- exception
- when Bad_ALI_Format =>
-
- -- If ignoring errors, then we skip a line with an
- -- unexpected error, and try to continue subsequent
- -- xref lines.
-
- if Ignore_Errors then
- Xref_Entity.Decrement_Last;
- Skip_Line;
- C := Nextc;
-
- -- Otherwise, we reraise the fatal exception
-
- else
- raise;
- end if;
- end Read_Refs_For_One_Entity;
- end loop;
-
- -- Record last entity
-
- XS.Last_Entity := Xref_Entity.Last;
- end Read_Refs_For_One_File;
-
- C := Getc;
- end loop X_Loop;
-
- -- Here after dealing with xref sections
-
- -- Ignore remaining lines, which belong to an additional section of the
- -- ALI file not considered here (like SCO or SPARK information).
-
- Check_Unknown_Line;
+ -- This ALI parser does not care about Xref lines.
return Id;
diff --git a/gcc/ada/ali.ads b/gcc/ada/ali.ads
index ccb516f..3ac9f0e 100644
--- a/gcc/ada/ali.ads
+++ b/gcc/ada/ali.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -1391,8 +1391,6 @@ package ALI is
T : Text_Buffer_Ptr;
Ignore_ED : Boolean;
Err : Boolean;
- Read_Xref : Boolean := False;
- Read_Lines : String := "";
Ignore_Lines : String := "X";
Ignore_Errors : Boolean := False;
Directly_Scanned : Boolean := False) return ALI_Id;
@@ -1417,24 +1415,6 @@ package ALI is
-- tables will not be filled in this case. It is not possible
-- to ignore U (unit) lines, they are always read.
--
- -- Read_Lines requests that Scan_ALI process only lines that start
- -- with one of the given characters. The corresponding data in the
- -- ALI file for any characters not given in the list will not be
- -- set. The default value of the null string indicates that all
- -- lines should be read (unless Ignore_Lines is specified). U
- -- (unit) lines are always read regardless of the value of this
- -- parameter.
- --
- -- Note: either Ignore_Lines or Read_Lines should be non-null, but not
- -- both. If both are provided then only the Read_Lines value is used,
- -- and the Ignore_Lines parameter is ignored.
- --
- -- Read_Xref is set True to read and acquire the cross-reference
- -- information. If Read_XREF is set to True, then the effect is to ignore
- -- all lines other than U, W, D and X lines and the Ignore_Lines and
- -- Read_Lines parameters are ignored (i.e. the use of True for Read_XREF
- -- is equivalent to specifying an argument of "UWDX" for Read_Lines.
- --
-- Ignore_Errors is normally False. If it is set True, then Scan_ALI
-- will do its best to scan through a file and extract all information
-- it can, even if there are errors. In this case Err is only set if
diff --git a/gcc/ada/alloc.ads b/gcc/ada/alloc.ads
index e7b5bca..85944c9 100644
--- a/gcc/ada/alloc.ads
+++ b/gcc/ada/alloc.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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 @@
package Alloc is
- -- The comment shows the unit in which the table is defined
+ -- The comment shows the unit in which the tables are defined
All_Interp_Initial : constant := 1_000; -- Sem_Type
All_Interp_Increment : constant := 100;
@@ -94,9 +94,11 @@ package Alloc is
Names_Initial : constant := 6_000; -- Namet
Names_Increment : constant := 100;
- Nodes_Initial : constant := 50_000; -- Atree
- Nodes_Increment : constant := 100;
- Nodes_Release_Threshold : constant := 100_000;
+ Node_Offsets_Initial : constant := 500_000; -- Atree, Nlists
+ Node_Offsets_Increment : constant := 100;
+
+ Slots_Initial : constant := 2_000_000; -- Atree
+ Slots_Increment : constant := 100;
Notes_Initial : constant := 100; -- Lib
Notes_Increment : constant := 200;
diff --git a/gcc/ada/argv-lynxos178-raven-cert.c b/gcc/ada/argv-lynxos178-raven-cert.c
index cd5aa6e..21cead3 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-2020, Free Software Foundation, Inc. *
+ * Copyright (C) 1992-2021, Free Software Foundation, Inc. *
* *
* GNAT is 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,6 +41,7 @@
minimal support for Ada.Command_Line.Command_Name */
#include <sys/types.h>
+#include <stdlib.h>
#include <string.h>
#ifdef __cplusplus
@@ -53,8 +54,8 @@ extern "C" {
the binder-generated file so they need to be defined here */
int gnat_argc = 0;
-const char **gnat_argv = (const char **) 0;
-const char **gnat_envp = (const char **) 0;
+char **gnat_argv = NULL;
+char **gnat_envp = NULL;
int
__gnat_len_arg (int arg_num)
diff --git a/gcc/ada/argv.c b/gcc/ada/argv.c
index 2b298fc..4734415 100644
--- a/gcc/ada/argv.c
+++ b/gcc/ada/argv.c
@@ -6,7 +6,7 @@
* *
* C Implementation File *
* *
- * Copyright (C) 1992-2020, Free Software Foundation, Inc. *
+ * Copyright (C) 1992-2021, Free Software Foundation, Inc. *
* *
* GNAT is 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,6 +44,7 @@
#ifdef IN_RTS
#include "runtime.h"
+#include <stdlib.h>
#include <string.h>
#else
#include "config.h"
@@ -60,14 +61,13 @@ extern "C" {
envp of the main program is saved under gnat_envp. */
int gnat_argc = 0;
-const char **gnat_argv = (const char **) 0;
-const char **gnat_envp = (const char **) 0;
+char **gnat_argv = NULL;
+char **gnat_envp = NULL;
#if defined (_WIN32) && !defined (RTX)
/* Note that on Windows environment the environ point to a buffer that could
be reallocated if needed. It means that gnat_envp needs to be updated
before using gnat_envp to point to the right environment space */
-#include <stdlib.h>
/* for the environ variable definition */
#define gnat_envp (environ)
#endif
diff --git a/gcc/ada/aspects.adb b/gcc/ada/aspects.adb
index 91550c8..a6e4f28 100644
--- a/gcc/ada/aspects.adb
+++ b/gcc/ada/aspects.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2010-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2010-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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,14 @@
-- --
------------------------------------------------------------------------------
-with Atree; use Atree;
-with Einfo; use Einfo;
-with Nlists; use Nlists;
-with Sinfo; use Sinfo;
+with Atree; use Atree;
+with Einfo; use Einfo;
+with Einfo.Entities; use Einfo.Entities;
+with Einfo.Utils; use Einfo.Utils;
+with Nlists; use Nlists;
+with Sinfo; use Sinfo;
+with Sinfo.Nodes; use Sinfo.Nodes;
+with Sinfo.Utils; use Sinfo.Utils;
with GNAT.HTable;
@@ -224,7 +228,7 @@ package body Aspects is
while Present (Item) loop
if Nkind (Item) = N_Aspect_Specification
and then Get_Aspect_Id (Item) = A
- and then Class_Present = Sinfo.Class_Present (Item)
+ and then Class_Present = Sinfo.Nodes.Class_Present (Item)
then
return Item;
end if;
@@ -237,6 +241,10 @@ package body Aspects is
-- find the declaration node where the aspects reside. This is usually
-- the parent or the parent of the parent.
+ if No (Parent (Owner)) then
+ return Empty;
+ end if;
+
Decl := Parent (Owner);
if not Permits_Aspect_Specifications (Decl) then
Decl := Parent (Decl);
@@ -248,7 +256,7 @@ package body Aspects is
Spec := First (Aspect_Specifications (Decl));
while Present (Spec) loop
if Get_Aspect_Id (Spec) = A
- and then Class_Present = Sinfo.Class_Present (Spec)
+ and then Class_Present = Sinfo.Nodes.Class_Present (Spec)
then
return Spec;
end if;
@@ -484,6 +492,7 @@ package body Aspects is
function Permits_Aspect_Specifications (N : Node_Id) return Boolean is
begin
+ pragma Assert (Present (N));
return Has_Aspect_Specifications_Flag (Nkind (N));
end Permits_Aspect_Specifications;
diff --git a/gcc/ada/aspects.ads b/gcc/ada/aspects.ads
index e16ceb0..0f9ed23 100644
--- a/gcc/ada/aspects.ads
+++ b/gcc/ada/aspects.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2010-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2010-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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,7 @@ package Aspects is
Aspect_External_Tag,
Aspect_Ghost, -- GNAT
Aspect_Global, -- GNAT
+ Aspect_GNAT_Annotate, -- GNAT
Aspect_Implicit_Dereference,
Aspect_Initial_Condition, -- GNAT
Aspect_Initializes, -- GNAT
@@ -116,6 +117,8 @@ package Aspects is
Aspect_Max_Entry_Queue_Length,
Aspect_Max_Queue_Length, -- GNAT
Aspect_No_Caching, -- GNAT
+ Aspect_No_Controlled_Parts,
+ Aspect_No_Task_Parts, -- GNAT
Aspect_Object_Size, -- GNAT
Aspect_Obsolescent, -- GNAT
Aspect_Output,
@@ -171,7 +174,6 @@ package Aspects is
Aspect_Remote_Call_Interface,
Aspect_Remote_Types,
Aspect_Shared_Passive,
- Aspect_Universal_Data, -- GNAT
-- Remaining aspects have a static boolean value that turns the aspect
-- on or off. They all correspond to pragmas, but are only converted to
@@ -268,6 +270,7 @@ package Aspects is
Aspect_Favor_Top_Level => True,
Aspect_Ghost => True,
Aspect_Global => True,
+ Aspect_GNAT_Annotate => True,
Aspect_Inline_Always => True,
Aspect_Invariant => True,
Aspect_Lock_Free => True,
@@ -290,7 +293,6 @@ package Aspects is
Aspect_Thread_Local_Storage => True,
Aspect_Test_Case => True,
Aspect_Universal_Aliasing => True,
- Aspect_Universal_Data => True,
Aspect_Unmodified => True,
Aspect_Unreferenced => True,
Aspect_Unreferenced_Objects => True,
@@ -318,9 +320,10 @@ package Aspects is
-- the same aspect attached to the same declaration are allowed.
No_Duplicates_Allowed : constant array (Aspect_Id) of Boolean :=
- (Aspect_Annotate => False,
- Aspect_Test_Case => False,
- others => True);
+ (Aspect_Annotate => False,
+ Aspect_GNAT_Annotate => False,
+ Aspect_Test_Case => False,
+ others => True);
-- The following subtype defines aspects corresponding to library unit
-- pragmas, these can only validly appear as aspects for library units,
@@ -328,7 +331,7 @@ package Aspects is
-- the occurrence of the aspect.
subtype Library_Unit_Aspects is
- Aspect_Id range Aspect_All_Calls_Remote .. Aspect_Universal_Data;
+ Aspect_Id range Aspect_All_Calls_Remote .. Aspect_Shared_Passive;
-- The following subtype defines aspects accepting an optional static
-- boolean parameter indicating if the aspect should be active or
@@ -387,6 +390,7 @@ package Aspects is
Aspect_External_Tag => Expression,
Aspect_Ghost => Optional_Expression,
Aspect_Global => Expression,
+ Aspect_GNAT_Annotate => Expression,
Aspect_Implicit_Dereference => Name,
Aspect_Initial_Condition => Expression,
Aspect_Initializes => Expression,
@@ -403,6 +407,8 @@ package Aspects is
Aspect_Max_Entry_Queue_Length => Expression,
Aspect_Max_Queue_Length => Expression,
Aspect_No_Caching => Optional_Expression,
+ Aspect_No_Controlled_Parts => Optional_Expression,
+ Aspect_No_Task_Parts => Optional_Expression,
Aspect_Object_Size => Expression,
Aspect_Obsolescent => Optional_Expression,
Aspect_Output => Name,
@@ -489,6 +495,7 @@ package Aspects is
Aspect_External_Tag => False,
Aspect_Ghost => False,
Aspect_Global => False,
+ Aspect_GNAT_Annotate => False,
Aspect_Implicit_Dereference => False,
Aspect_Initial_Condition => False,
Aspect_Initializes => False,
@@ -505,6 +512,8 @@ package Aspects is
Aspect_Max_Entry_Queue_Length => False,
Aspect_Max_Queue_Length => False,
Aspect_No_Caching => False,
+ Aspect_No_Controlled_Parts => False,
+ Aspect_No_Task_Parts => False,
Aspect_Object_Size => True,
Aspect_Obsolescent => False,
Aspect_Output => False,
@@ -643,6 +652,7 @@ package Aspects is
Aspect_Full_Access_Only => Name_Full_Access_Only,
Aspect_Ghost => Name_Ghost,
Aspect_Global => Name_Global,
+ Aspect_GNAT_Annotate => Name_GNAT_Annotate,
Aspect_Implicit_Dereference => Name_Implicit_Dereference,
Aspect_Import => Name_Import,
Aspect_Independent => Name_Independent,
@@ -666,6 +676,8 @@ package Aspects is
Aspect_Max_Entry_Queue_Length => Name_Max_Entry_Queue_Length,
Aspect_Max_Queue_Length => Name_Max_Queue_Length,
Aspect_No_Caching => Name_No_Caching,
+ Aspect_No_Controlled_Parts => Name_No_Controlled_Parts,
+ Aspect_No_Task_Parts => Name_No_Task_Parts,
Aspect_No_Elaboration_Code_All => Name_No_Elaboration_Code_All,
Aspect_No_Inline => Name_No_Inline,
Aspect_No_Return => Name_No_Return,
@@ -726,7 +738,6 @@ package Aspects is
Aspect_Unchecked_Union => Name_Unchecked_Union,
Aspect_Unimplemented => Name_Unimplemented,
Aspect_Universal_Aliasing => Name_Universal_Aliasing,
- Aspect_Universal_Data => Name_Universal_Data,
Aspect_Unmodified => Name_Unmodified,
Aspect_Unreferenced => Name_Unreferenced,
Aspect_Unreferenced_Objects => Name_Unreferenced_Objects,
@@ -927,7 +938,6 @@ package Aspects is
Aspect_Type_Invariant => Always_Delay,
Aspect_Unchecked_Union => Always_Delay,
Aspect_Universal_Aliasing => Always_Delay,
- Aspect_Universal_Data => Always_Delay,
Aspect_Unmodified => Always_Delay,
Aspect_Unreferenced => Always_Delay,
Aspect_Unreferenced_Objects => Always_Delay,
@@ -953,6 +963,7 @@ package Aspects is
Aspect_Extensions_Visible => Never_Delay,
Aspect_Ghost => Never_Delay,
Aspect_Global => Never_Delay,
+ Aspect_GNAT_Annotate => Never_Delay,
Aspect_Import => Never_Delay,
Aspect_Initial_Condition => Never_Delay,
Aspect_Initializes => Never_Delay,
@@ -960,6 +971,8 @@ package Aspects is
Aspect_Max_Entry_Queue_Length => Never_Delay,
Aspect_Max_Queue_Length => Never_Delay,
Aspect_No_Caching => Never_Delay,
+ Aspect_No_Controlled_Parts => Never_Delay,
+ Aspect_No_Task_Parts => Never_Delay,
Aspect_No_Elaboration_Code_All => Never_Delay,
Aspect_No_Tagged_Streams => Never_Delay,
Aspect_Obsolescent => Never_Delay,
diff --git a/gcc/ada/atree.adb b/gcc/ada/atree.adb
index d3d40d9..c7e295b 100644
--- a/gcc/ada/atree.adb
+++ b/gcc/ada/atree.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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,24 +23,32 @@
-- --
------------------------------------------------------------------------------
-pragma Style_Checks (All_Checks);
--- Turn off subprogram ordering check for this package
+-- Assertions in this package are too slow, and are mostly needed when working
+-- on this package itself, or on gen_il, so we disable them.
+-- To debug low-level bugs in this area, comment out the following pragma,
+-- and run with -gnatd_v.
--- WARNING: There is a C version of this package. Any changes to this source
--- file must be properly reflected in the file atree.h which is a C header
--- file containing equivalent definitions for use by gigi.
+pragma Assertion_Policy (Ignore);
-with Aspects; use Aspects;
-with Debug; use Debug;
-with Nlists; use Nlists;
-with Opt; use Opt;
-with Output; use Output;
-with Sinput; use Sinput;
-
-with GNAT.Heap_Sort_G;
+with Aspects; use Aspects;
+with Debug; use Debug;
+with Namet; use Namet;
+with Nlists; use Nlists;
+with Opt; use Opt;
+with Output; use Output;
+with Seinfo; use Seinfo;
+with Sinfo.Utils; use Sinfo.Utils;
+with System.Storage_Elements;
package body Atree is
+ ---------------
+ -- Debugging --
+ ---------------
+
+ -- Suppose you find that node 12345 is messed up. You might want to find
+ -- the code that created that node. See sinfo-utils.adb for how to do that.
+
Ignored_Ghost_Recording_Proc : Ignored_Ghost_Record_Proc := null;
-- This soft link captures the procedure invoked during the creation of an
-- ignored Ghost node or entity.
@@ -57,463 +65,49 @@ package body Atree is
Rewriting_Proc : Rewrite_Proc := null;
-- This soft link captures the procedure invoked during a node rewrite
- ---------------
- -- Debugging --
- ---------------
-
- -- Suppose you find that node 12345 is messed up. You might want to find
- -- the code that created that node. There are two ways to do this:
-
- -- One way is to set a conditional breakpoint on New_Node_Debugging_Output
- -- (nickname "nnd"):
- -- break nnd if n = 12345
- -- and run gnat1 again from the beginning.
-
- -- The other way is to set a breakpoint near the beginning (e.g. on
- -- gnat1drv), and run. Then set Watch_Node (nickname "ww") to 12345 in gdb:
- -- ww := 12345
- -- and set a breakpoint on New_Node_Breakpoint (nickname "nn"). Continue.
-
- -- Either way, gnat1 will stop when node 12345 is created, or certain other
- -- interesting operations are performed, such as Rewrite. To see exactly
- -- which operations, search for "pragma Debug" below.
-
- -- The second method is much faster if the amount of Ada code being
- -- compiled is large.
-
- ww : Node_Id'Base := Node_Id'First - 1;
- pragma Export (Ada, ww); -- trick the optimizer
- Watch_Node : Node_Id'Base renames ww;
- -- Node to "watch"; that is, whenever a node is created, we check if it
- -- is equal to Watch_Node, and if so, call New_Node_Breakpoint. You have
- -- presumably set a breakpoint on New_Node_Breakpoint. Note that the
- -- initial value of Node_Id'First - 1 ensures that by default, no node
- -- will be equal to Watch_Node.
-
- procedure nn;
- pragma Export (Ada, nn);
- procedure New_Node_Breakpoint renames nn;
- -- This doesn't do anything interesting; it's just for setting breakpoint
- -- on as explained above.
-
- procedure nnd (N : Node_Id);
- pragma Export (Ada, nnd);
- procedure New_Node_Debugging_Output (N : Node_Id) renames nnd;
- -- For debugging. If debugging is turned on, New_Node and New_Entity call
- -- this. If debug flag N is turned on, this prints out the new node.
- --
- -- If Node = Watch_Node, this prints out the new node and calls
- -- New_Node_Breakpoint. Otherwise, does nothing.
-
- procedure Node_Debug_Output (Op : String; N : Node_Id);
- -- Called by nnd; writes Op followed by information about N
-
-----------------------------
-- Local Objects and Types --
-----------------------------
Comes_From_Source_Default : Boolean := False;
- use Unchecked_Access;
- -- We are allowed to see these from within our own body
-
use Atree_Private_Part;
-- We are also allowed to see our private data structures
- -- Functions used to store Entity_Kind value in Nkind field
-
- -- The following declarations are used to store flags 65-72 in the
- -- Nkind field of the third component of an extended (entity) node.
-
- type Flag_Byte is record
- Flag65 : Boolean;
- Flag66 : Boolean;
- Flag67 : Boolean;
- Flag68 : Boolean;
- Flag69 : Boolean;
- Flag70 : Boolean;
- Flag71 : Boolean;
- Flag72 : Boolean;
- end record;
-
- pragma Pack (Flag_Byte);
- for Flag_Byte'Size use 8;
-
- type Flag_Byte_Ptr is access all Flag_Byte;
- type Node_Kind_Ptr is access all Node_Kind;
-
- function To_Flag_Byte is new
- Unchecked_Conversion (Node_Kind, Flag_Byte);
-
- function To_Flag_Byte_Ptr is new
- Unchecked_Conversion (Node_Kind_Ptr, Flag_Byte_Ptr);
-
- -- The following declarations are used to store flags 239-246 in the
- -- Nkind field of the fourth component of an extended (entity) node.
-
- type Flag_Byte2 is record
- Flag239 : Boolean;
- Flag240 : Boolean;
- Flag241 : Boolean;
- Flag242 : Boolean;
- Flag243 : Boolean;
- Flag244 : Boolean;
- Flag245 : Boolean;
- Flag246 : Boolean;
- end record;
-
- pragma Pack (Flag_Byte2);
- for Flag_Byte2'Size use 8;
-
- type Flag_Byte2_Ptr is access all Flag_Byte2;
-
- function To_Flag_Byte2 is new
- Unchecked_Conversion (Node_Kind, Flag_Byte2);
-
- function To_Flag_Byte2_Ptr is new
- Unchecked_Conversion (Node_Kind_Ptr, Flag_Byte2_Ptr);
-
- -- The following declarations are used to store flags 247-254 in the
- -- Nkind field of the fifth component of an extended (entity) node.
-
- type Flag_Byte3 is record
- Flag247 : Boolean;
- Flag248 : Boolean;
- Flag249 : Boolean;
- Flag250 : Boolean;
- Flag251 : Boolean;
- Flag252 : Boolean;
- Flag253 : Boolean;
- Flag254 : Boolean;
- end record;
-
- pragma Pack (Flag_Byte3);
- for Flag_Byte3'Size use 8;
-
- type Flag_Byte3_Ptr is access all Flag_Byte3;
-
- function To_Flag_Byte3 is new
- Unchecked_Conversion (Node_Kind, Flag_Byte3);
-
- function To_Flag_Byte3_Ptr is new
- Unchecked_Conversion (Node_Kind_Ptr, Flag_Byte3_Ptr);
-
- -- The following declarations are used to store flags 310-317 in the
- -- Nkind field of the sixth component of an extended (entity) node.
-
- type Flag_Byte4 is record
- Flag310 : Boolean;
- Flag311 : Boolean;
- Flag312 : Boolean;
- Flag313 : Boolean;
- Flag314 : Boolean;
- Flag315 : Boolean;
- Flag316 : Boolean;
- Flag317 : Boolean;
- end record;
-
- pragma Pack (Flag_Byte4);
- for Flag_Byte4'Size use 8;
-
- type Flag_Byte4_Ptr is access all Flag_Byte4;
-
- function To_Flag_Byte4 is new
- Unchecked_Conversion (Node_Kind, Flag_Byte4);
-
- function To_Flag_Byte4_Ptr is new
- Unchecked_Conversion (Node_Kind_Ptr, Flag_Byte4_Ptr);
-
- -- The following declarations are used to store flags 73-96 and the
- -- Convention field in the Field12 field of the third component of an
- -- extended (Entity) node.
-
- type Flag_Word is record
- Flag73 : Boolean;
- Flag74 : Boolean;
- Flag75 : Boolean;
- Flag76 : Boolean;
- Flag77 : Boolean;
- Flag78 : Boolean;
- Flag79 : Boolean;
- Flag80 : Boolean;
-
- Flag81 : Boolean;
- Flag82 : Boolean;
- Flag83 : Boolean;
- Flag84 : Boolean;
- Flag85 : Boolean;
- Flag86 : Boolean;
- Flag87 : Boolean;
- Flag88 : Boolean;
-
- Flag89 : Boolean;
- Flag90 : Boolean;
- Flag91 : Boolean;
- Flag92 : Boolean;
- Flag93 : Boolean;
- Flag94 : Boolean;
- Flag95 : Boolean;
- Flag96 : Boolean;
-
- Convention : Convention_Id;
- end record;
-
- pragma Pack (Flag_Word);
- for Flag_Word'Size use 32;
- for Flag_Word'Alignment use 4;
-
- type Flag_Word_Ptr is access all Flag_Word;
- type Union_Id_Ptr is access all Union_Id;
-
- function To_Flag_Word is new
- Unchecked_Conversion (Union_Id, Flag_Word);
-
- function To_Flag_Word_Ptr is new
- Unchecked_Conversion (Union_Id_Ptr, Flag_Word_Ptr);
-
- -- The following declarations are used to store flags 97-128 in the
- -- Field12 field of the fourth component of an extended (entity) node.
-
- type Flag_Word2 is record
- Flag97 : Boolean;
- Flag98 : Boolean;
- Flag99 : Boolean;
- Flag100 : Boolean;
- Flag101 : Boolean;
- Flag102 : Boolean;
- Flag103 : Boolean;
- Flag104 : Boolean;
-
- Flag105 : Boolean;
- Flag106 : Boolean;
- Flag107 : Boolean;
- Flag108 : Boolean;
- Flag109 : Boolean;
- Flag110 : Boolean;
- Flag111 : Boolean;
- Flag112 : Boolean;
-
- Flag113 : Boolean;
- Flag114 : Boolean;
- Flag115 : Boolean;
- Flag116 : Boolean;
- Flag117 : Boolean;
- Flag118 : Boolean;
- Flag119 : Boolean;
- Flag120 : Boolean;
-
- Flag121 : Boolean;
- Flag122 : Boolean;
- Flag123 : Boolean;
- Flag124 : Boolean;
- Flag125 : Boolean;
- Flag126 : Boolean;
- Flag127 : Boolean;
- Flag128 : Boolean;
- end record;
-
- pragma Pack (Flag_Word2);
- for Flag_Word2'Size use 32;
- for Flag_Word2'Alignment use 4;
-
- type Flag_Word2_Ptr is access all Flag_Word2;
-
- function To_Flag_Word2 is new
- Unchecked_Conversion (Union_Id, Flag_Word2);
-
- function To_Flag_Word2_Ptr is new
- Unchecked_Conversion (Union_Id_Ptr, Flag_Word2_Ptr);
-
- -- The following declarations are used to store flags 152-183 in the
- -- Field11 field of the fourth component of an extended (entity) node.
-
- type Flag_Word3 is record
- Flag152 : Boolean;
- Flag153 : Boolean;
- Flag154 : Boolean;
- Flag155 : Boolean;
- Flag156 : Boolean;
- Flag157 : Boolean;
- Flag158 : Boolean;
- Flag159 : Boolean;
-
- Flag160 : Boolean;
- Flag161 : Boolean;
- Flag162 : Boolean;
- Flag163 : Boolean;
- Flag164 : Boolean;
- Flag165 : Boolean;
- Flag166 : Boolean;
- Flag167 : Boolean;
-
- Flag168 : Boolean;
- Flag169 : Boolean;
- Flag170 : Boolean;
- Flag171 : Boolean;
- Flag172 : Boolean;
- Flag173 : Boolean;
- Flag174 : Boolean;
- Flag175 : Boolean;
-
- Flag176 : Boolean;
- Flag177 : Boolean;
- Flag178 : Boolean;
- Flag179 : Boolean;
- Flag180 : Boolean;
- Flag181 : Boolean;
- Flag182 : Boolean;
- Flag183 : Boolean;
- end record;
-
- pragma Pack (Flag_Word3);
- for Flag_Word3'Size use 32;
- for Flag_Word3'Alignment use 4;
-
- type Flag_Word3_Ptr is access all Flag_Word3;
-
- function To_Flag_Word3 is new
- Unchecked_Conversion (Union_Id, Flag_Word3);
-
- function To_Flag_Word3_Ptr is new
- Unchecked_Conversion (Union_Id_Ptr, Flag_Word3_Ptr);
-
- -- The following declarations are used to store flags 184-215 in the
- -- Field12 field of the fifth component of an extended (entity) node.
-
- type Flag_Word4 is record
- Flag184 : Boolean;
- Flag185 : Boolean;
- Flag186 : Boolean;
- Flag187 : Boolean;
- Flag188 : Boolean;
- Flag189 : Boolean;
- Flag190 : Boolean;
- Flag191 : Boolean;
-
- Flag192 : Boolean;
- Flag193 : Boolean;
- Flag194 : Boolean;
- Flag195 : Boolean;
- Flag196 : Boolean;
- Flag197 : Boolean;
- Flag198 : Boolean;
- Flag199 : Boolean;
-
- Flag200 : Boolean;
- Flag201 : Boolean;
- Flag202 : Boolean;
- Flag203 : Boolean;
- Flag204 : Boolean;
- Flag205 : Boolean;
- Flag206 : Boolean;
- Flag207 : Boolean;
-
- Flag208 : Boolean;
- Flag209 : Boolean;
- Flag210 : Boolean;
- Flag211 : Boolean;
- Flag212 : Boolean;
- Flag213 : Boolean;
- Flag214 : Boolean;
- Flag215 : Boolean;
- end record;
-
- pragma Pack (Flag_Word4);
- for Flag_Word4'Size use 32;
- for Flag_Word4'Alignment use 4;
-
- type Flag_Word4_Ptr is access all Flag_Word4;
-
- function To_Flag_Word4 is new
- Unchecked_Conversion (Union_Id, Flag_Word4);
-
- function To_Flag_Word4_Ptr is new
- Unchecked_Conversion (Union_Id_Ptr, Flag_Word4_Ptr);
-
- -- The following declarations are used to store flags 255-286 in the
- -- Field12 field of the sixth component of an extended (entity) node.
-
- type Flag_Word5 is record
- Flag255 : Boolean;
- Flag256 : Boolean;
- Flag257 : Boolean;
- Flag258 : Boolean;
- Flag259 : Boolean;
- Flag260 : Boolean;
- Flag261 : Boolean;
- Flag262 : Boolean;
-
- Flag263 : Boolean;
- Flag264 : Boolean;
- Flag265 : Boolean;
- Flag266 : Boolean;
- Flag267 : Boolean;
- Flag268 : Boolean;
- Flag269 : Boolean;
- Flag270 : Boolean;
-
- Flag271 : Boolean;
- Flag272 : Boolean;
- Flag273 : Boolean;
- Flag274 : Boolean;
- Flag275 : Boolean;
- Flag276 : Boolean;
- Flag277 : Boolean;
- Flag278 : Boolean;
-
- Flag279 : Boolean;
- Flag280 : Boolean;
- Flag281 : Boolean;
- Flag282 : Boolean;
- Flag283 : Boolean;
- Flag284 : Boolean;
- Flag285 : Boolean;
- Flag286 : Boolean;
- end record;
-
- pragma Pack (Flag_Word5);
- for Flag_Word5'Size use 32;
- for Flag_Word5'Alignment use 4;
-
- type Flag_Word5_Ptr is access all Flag_Word5;
-
- function To_Flag_Word5 is new
- Unchecked_Conversion (Union_Id, Flag_Word5);
-
- function To_Flag_Word5_Ptr is new
- Unchecked_Conversion (Union_Id_Ptr, Flag_Word5_Ptr);
-
--------------------------------------------------
-- Implementation of Tree Substitution Routines --
--------------------------------------------------
- -- A separate table keeps track of the mapping between rewritten nodes
- -- and their corresponding original tree nodes. Rewrite makes an entry
- -- in this table for use by Original_Node. By default, if no call is
- -- Rewrite, the entry in this table points to the original unwritten node.
+ -- A separate table keeps track of the mapping between rewritten nodes and
+ -- their corresponding original tree nodes. Rewrite makes an entry in this
+ -- table for use by Original_Node. By default the entry in this table
+ -- points to the original unwritten node. Note that if a node is rewritten
+ -- more than once, there is no easy way to get to the intermediate
+ -- rewrites; the node itself is the latest version, and the entry in this
+ -- table is the original.
- -- Note: eventually, this should be a field in the Node directly, but
- -- for now we do not want to disturb the efficiency of a power of 2
- -- for the node size. ????We are planning to get rid of power-of-2.
+ -- Note: This could be a node field.
package Orig_Nodes is new Table.Table (
Table_Component_Type => Node_Id,
Table_Index_Type => Node_Id'Base,
Table_Low_Bound => First_Node_Id,
- Table_Initial => Alloc.Nodes_Initial,
- Table_Increment => Alloc.Nodes_Increment,
- Release_Threshold => Alloc.Nodes_Release_Threshold,
+ Table_Initial => Alloc.Node_Offsets_Initial,
+ Table_Increment => Alloc.Node_Offsets_Increment,
Table_Name => "Orig_Nodes");
--------------------------
-- Paren_Count Handling --
--------------------------
- -- As noted in the spec, the paren count in a sub-expression node has
- -- four possible values 0,1,2, and 3. The value 3 really means 3 or more,
- -- and we use an auxiliary serially scanned table to record the actual
- -- count. A serial search is fine, only pathological programs will use
- -- entries in this table. Normal programs won't use it at all.
+ -- The Small_Paren_Count field has range 0 .. 3. If the Paren_Count is
+ -- in the range 0 .. 2, then it is stoed as Small_Paren_Count. Otherwise,
+ -- Small_Paren_Count = 3, and the actual Paren_Count is stored in the
+ -- Paren_Counts table.
+ --
+ -- We use linear search on the Paren_Counts table, which is plenty
+ -- efficient because only pathological programs will use it. Nobody
+ -- writes (((X + Y))).
type Paren_Count_Entry is record
Nod : Node_Id;
@@ -540,14 +134,14 @@ package body Atree is
-- Local Subprograms --
-----------------------
- function Allocate_New_Node return Node_Id;
+ function Allocate_New_Node (Kind : Node_Kind) return Node_Id;
pragma Inline (Allocate_New_Node);
-- Allocate a new node or first part of a node extension. Initialize the
-- Nodes.Table entry, Flags, Orig_Nodes, and List tables.
procedure Fix_Parents (Ref_Node, Fix_Node : Node_Id);
- -- Fix up parent pointers for the syntactic children of Fix_Node after a
- -- copy, setting them to Fix_Node when they pointed to Ref_Node.
+ -- Fix up parent pointers for the children of Fix_Node after a copy,
+ -- setting them to Fix_Node when they pointed to Ref_Node.
procedure Mark_New_Ghost_Node (N : Node_Or_Entity_Id);
-- Mark arbitrary node or entity N as Ghost when it is created within a
@@ -557,55 +151,868 @@ package body Atree is
pragma Inline (Report);
-- Invoke the reporting procedure if available
- -----------------------
- -- Allocate_New_Node --
- -----------------------
+ function Size_In_Slots (N : Node_Or_Entity_Id) return Slot_Count;
+ -- Number of slots belonging to N. This can be less than
+ -- Size_In_Slots_To_Alloc for entities.
+
+ function Size_In_Slots_To_Alloc (N : Node_Or_Entity_Id) return Slot_Count;
+ function Size_In_Slots_To_Alloc (Kind : Node_Kind) return Slot_Count;
+ -- Number of slots to allocate for a node or entity. For entities, we have
+ -- to allocate the max, because we don't know the Ekind when this is
+ -- called.
+
+ function Off_0 (N : Node_Id) return Node_Offset;
+ -- Offset of the first slot of N (offset 0) in Slots.Table
+
+ function Off_L (N : Node_Id) return Node_Offset;
+ -- Offset of the last slot of N in Slots.Table
+
+ procedure Zero_Slots (First, Last : Node_Offset) with Inline;
+ -- Set slots in the range F..L to zero
+
+ procedure Zero_Slots (N : Node_Or_Entity_Id) with Inline;
+ -- Zero the slots belonging to N
+
+ procedure Copy_Slots (From, To : Node_Offset; Num_Slots : Slot_Count)
+ with Inline;
+ -- Copy Num_Slots slots from From to To. Caller is responsible for ensuring
+ -- that the Num_Slots at To are a reasonable place to copy to.
+
+ procedure Copy_Slots (Source, Destination : Node_Id) with Inline;
+ -- Copies the slots of Source to Destination; uses the node kind to
+ -- determine the Num_Slots.
+
+ function Get_Field_Value
+ (N : Node_Id; Field : Node_Field) return Field_Size_32_Bit;
+ -- Get any field value as a Field_Size_32_Bit. If the field is smaller than
+ -- 32 bits, convert it to Field_Size_32_Bit. The Field must be present in
+ -- the Nkind of N.
+
+ procedure Set_Field_Value
+ (N : Node_Id; Field : Node_Field; Val : Field_Size_32_Bit);
+ -- Set any field value as a Field_Size_32_Bit. If the field is smaller than
+ -- 32 bits, convert it from Field_Size_32_Bit, and Val had better be small
+ -- enough. The Field must be present in the Nkind of N.
+
+ procedure Check_Vanishing_Fields
+ (Old_N : Node_Id; New_Kind : Node_Kind);
+ -- Called whenever Nkind is modified. Raises an exception if not all
+ -- vanishing fields are in their initial zero state.
+
+ function Get_Field_Value
+ (N : Entity_Id; Field : Entity_Field) return Field_Size_32_Bit;
+ procedure Set_Field_Value
+ (N : Entity_Id; Field : Entity_Field; Val : Field_Size_32_Bit);
+ procedure Check_Vanishing_Fields
+ (Old_N : Entity_Id; New_Kind : Entity_Kind);
+ -- Above are the same as the ones for nodes, but for entities
+
+ procedure Init_Nkind (N : Node_Id; Val : Node_Kind);
+ -- Initialize the Nkind field, which must not have been set already. This
+ -- cannot be used to modify an already-initialized Nkind field. See also
+ -- Mutate_Nkind.
+
+ procedure Mutate_Nkind
+ (N : Node_Id; Val : Node_Kind; Old_Size : Slot_Count);
+ -- Called by the other Mutate_Nkind to do all the work. This is needed
+ -- because the call in Change_Node, which calls this one directly, happens
+ -- after zeroing N's slots, which destroys its Nkind, which prevents us
+ -- from properly computing Old_Size.
+
+ package Field_Checking is
+ -- Functions for checking field access, used only in assertions
+
+ function Field_Present
+ (Kind : Node_Kind; Field : Node_Field) return Boolean;
+ function Field_Present
+ (Kind : Entity_Kind; Field : Entity_Field) return Boolean;
+ -- True if a node/entity of the given Kind has the given Field.
+ -- Always True if assertions are disabled.
+
+ end Field_Checking;
+
+ package body Field_Checking is
+
+ -- Tables used by Field_Present
+
+ type Node_Field_Sets is array (Node_Kind) of Node_Field_Set;
+ type Node_Field_Sets_Ptr is access all Node_Field_Sets;
+ Node_Fields_Present : Node_Field_Sets_Ptr;
+
+ type Entity_Field_Sets is array (Entity_Kind) of Entity_Field_Set;
+ type Entity_Field_Sets_Ptr is access all Entity_Field_Sets;
+ Entity_Fields_Present : Entity_Field_Sets_Ptr;
+
+ procedure Init_Tables;
+
+ function Create_Node_Fields_Present
+ (Kind : Node_Kind) return Node_Field_Set;
+ function Create_Entity_Fields_Present
+ (Kind : Entity_Kind) return Entity_Field_Set;
+ -- Computes the set of fields present in each Node/Entity Kind. Used to
+ -- initialize the above tables.
+
+ --------------------------------
+ -- Create_Node_Fields_Present --
+ --------------------------------
+
+ function Create_Node_Fields_Present
+ (Kind : Node_Kind) return Node_Field_Set
+ is
+ Result : Node_Field_Set := (others => False);
+ begin
+ for J in Node_Field_Table (Kind)'Range loop
+ Result (Node_Field_Table (Kind) (J)) := True;
+ end loop;
+
+ return Result;
+ end Create_Node_Fields_Present;
+
+ --------------------------------
+ -- Create_Entity_Fields_Present --
+ --------------------------------
+
+ function Create_Entity_Fields_Present
+ (Kind : Entity_Kind) return Entity_Field_Set
+ is
+ Result : Entity_Field_Set := (others => False);
+ begin
+ for J in Entity_Field_Table (Kind)'Range loop
+ Result (Entity_Field_Table (Kind) (J)) := True;
+ end loop;
+
+ return Result;
+ end Create_Entity_Fields_Present;
+
+ -----------------
+ -- Init_Tables --
+ -----------------
+
+ procedure Init_Tables is
+ begin
+ Node_Fields_Present := new Node_Field_Sets;
+
+ for Kind in Node_Kind loop
+ Node_Fields_Present (Kind) := Create_Node_Fields_Present (Kind);
+ end loop;
+
+ Entity_Fields_Present := new Entity_Field_Sets;
+
+ for Kind in Entity_Kind loop
+ Entity_Fields_Present (Kind) :=
+ Create_Entity_Fields_Present (Kind);
+ end loop;
+ end Init_Tables;
+
+ -- In production mode, we leave Node_Fields_Present and
+ -- Entity_Fields_Present null. Field_Present is only for
+ -- use in assertions.
+
+ pragma Debug (Init_Tables);
+
+ function Field_Present
+ (Kind : Node_Kind; Field : Node_Field) return Boolean is
+ begin
+ if Node_Fields_Present = null then
+ return True;
+ end if;
+
+ return Node_Fields_Present (Kind) (Field);
+ end Field_Present;
+
+ function Field_Present
+ (Kind : Entity_Kind; Field : Entity_Field) return Boolean is
+ begin
+ if Entity_Fields_Present = null then
+ return True;
+ end if;
+
+ return Entity_Fields_Present (Kind) (Field);
+ end Field_Present;
+
+ end Field_Checking;
+
+ ------------------------
+ -- Atree_Private_Part --
+ ------------------------
+
+ package body Atree_Private_Part is
+
+ -- The following validators are disabled in production builds, by being
+ -- called in pragma Debug. They are also disabled by default in debug
+ -- builds, by setting the flags below, because they make the compiler
+ -- very slow (10 to 20 times slower). Validate can be set True to debug
+ -- the low-level accessors.
+ --
+ -- Even if Validate is True, validation is disabled during
+ -- Validate_... calls to prevent infinite recursion
+ -- (Validate_... procedures call field getters, which call
+ -- Validate_... procedures). That's what the Enable_Validate_...
+ -- flags are for; they are toggled so that when we're inside one
+ -- of them, and enter it again, the inner call doesn't do anything.
+ -- These flags are irrelevant when Validate is False.
+
+ Validate : constant Boolean := False;
+
+ Enable_Validate_Node,
+ Enable_Validate_Node_Write,
+ Enable_Validate_Node_And_Offset,
+ Enable_Validate_Node_And_Offset_Write :
+ Boolean := Validate;
+
+ procedure Validate_Node_And_Offset
+ (N : Node_Or_Entity_Id; Offset : Field_Offset);
+ procedure Validate_Node_And_Offset_Write
+ (N : Node_Or_Entity_Id; Offset : Field_Offset);
+ -- Asserts N is OK, and the Offset in slots is within N. Note that this
+ -- does not guarantee that the offset is valid, just that it's not past
+ -- the last slot. It could be pointing at unused bits within the node,
+ -- or unused padding at the end. The "_Write" version is used when we're
+ -- about to modify the node.
+
+ procedure Validate_Node_And_Offset
+ (N : Node_Or_Entity_Id; Offset : Field_Offset) is
+ begin
+ if Enable_Validate_Node_And_Offset then
+ Enable_Validate_Node_And_Offset := False;
+
+ pragma Debug (Validate_Node (N));
+ pragma Assert (Offset'Valid);
+ pragma Assert (Offset < Size_In_Slots (N));
+
+ Enable_Validate_Node_And_Offset := True;
+ end if;
+ end Validate_Node_And_Offset;
+
+ procedure Validate_Node_And_Offset_Write
+ (N : Node_Or_Entity_Id; Offset : Field_Offset) is
+ begin
+ if Enable_Validate_Node_And_Offset_Write then
+ Enable_Validate_Node_And_Offset_Write := False;
+
+ pragma Debug (Validate_Node_Write (N));
+ pragma Assert (Offset'Valid);
+ pragma Assert (Offset < Size_In_Slots (N));
+
+ Enable_Validate_Node_And_Offset_Write := True;
+ end if;
+ end Validate_Node_And_Offset_Write;
+
+ procedure Validate_Node (N : Node_Or_Entity_Id) is
+ begin
+ if Enable_Validate_Node then
+ Enable_Validate_Node := False;
+
+ pragma Assert (N'Valid);
+ pragma Assert (N <= Node_Offsets.Last);
+ pragma Assert (Off_0 (N) <= Off_L (N));
+ pragma Assert (Off_L (N) <= Slots.Last);
+ pragma Assert (Nkind (N)'Valid);
+ pragma Assert (Nkind (N) /= N_Unused_At_End);
+
+ if Nkind (N) in N_Entity then
+ pragma Assert (Ekind (N)'Valid);
+ end if;
+
+ if Nkind (N) in
+ N_Aggregate
+ | N_Attribute_Definition_Clause
+ | N_Aspect_Specification
+ | N_Extension_Aggregate
+ | N_Freeze_Entity
+ | N_Freeze_Generic_Entity
+ | N_Has_Entity
+ | N_Selected_Component
+ | N_Use_Package_Clause
+ then
+ pragma Assert (Entity_Or_Associated_Node (N)'Valid);
+ end if;
+
+ Enable_Validate_Node := True;
+ end if;
+ end Validate_Node;
+
+ procedure Validate_Node_Write (N : Node_Or_Entity_Id) is
+ begin
+ if Enable_Validate_Node_Write then
+ Enable_Validate_Node_Write := False;
+
+ pragma Debug (Validate_Node (N));
+ pragma Assert (not Locked);
+
+ Enable_Validate_Node_Write := True;
+ end if;
+ end Validate_Node_Write;
+
+ function Is_Valid_Node (U : Union_Id) return Boolean is
+ begin
+ return Node_Id'Base (U) <= Node_Offsets.Last;
+ end Is_Valid_Node;
+
+ function Alloc_Node_Id return Node_Id is
+ begin
+ Node_Offsets.Increment_Last;
+ return Node_Offsets.Last;
+ end Alloc_Node_Id;
+
+ function Alloc_Slots (Num_Slots : Slot_Count) return Node_Offset is
+ begin
+ return Result : constant Node_Offset := Slots.Last + 1 do
+ Slots.Set_Last (Slots.Last + Num_Slots);
+ end return;
+ end Alloc_Slots;
+
+ function Get_1_Bit_Field
+ (N : Node_Or_Entity_Id; Offset : Field_Offset) return Field_Type
+ is
+ pragma Assert (Field_Type'Size = 1);
+
+ function Cast is new
+ Unchecked_Conversion (Field_Size_1_Bit, Field_Type);
+ begin
+ return Cast (Get_1_Bit_Val (N, Offset));
+ end Get_1_Bit_Field;
+
+ function Get_2_Bit_Field
+ (N : Node_Or_Entity_Id; Offset : Field_Offset) return Field_Type
+ is
+ pragma Assert (Field_Type'Size = 2);
+
+ function Cast is new
+ Unchecked_Conversion (Field_Size_2_Bit, Field_Type);
+ begin
+ return Cast (Get_2_Bit_Val (N, Offset));
+ end Get_2_Bit_Field;
+
+ function Get_4_Bit_Field
+ (N : Node_Or_Entity_Id; Offset : Field_Offset) return Field_Type
+ is
+ pragma Assert (Field_Type'Size = 4);
+
+ function Cast is new
+ Unchecked_Conversion (Field_Size_4_Bit, Field_Type);
+ begin
+ return Cast (Get_4_Bit_Val (N, Offset));
+ end Get_4_Bit_Field;
+
+ function Get_8_Bit_Field
+ (N : Node_Or_Entity_Id; Offset : Field_Offset) return Field_Type
+ is
+ pragma Assert (Field_Type'Size = 8);
+
+ function Cast is new
+ Unchecked_Conversion (Field_Size_8_Bit, Field_Type);
+ begin
+ return Cast (Get_8_Bit_Val (N, Offset));
+ end Get_8_Bit_Field;
+
+ function Get_32_Bit_Field
+ (N : Node_Or_Entity_Id; Offset : Field_Offset) return Field_Type
+ is
+ pragma Assert (Field_Type'Size = 32);
+
+ function Cast is new
+ Unchecked_Conversion (Field_Size_32_Bit, Field_Type);
+ begin
+ return Cast (Get_32_Bit_Val (N, Offset));
+ end Get_32_Bit_Field;
+
+ function Get_32_Bit_Field_With_Default
+ (N : Node_Or_Entity_Id; Offset : Field_Offset) return Field_Type
+ is
+ function Get_Field is new Get_32_Bit_Field (Field_Type) with Inline;
+ Result : Field_Type;
+ begin
+ -- If the field has not yet been set, it will be equal to zero.
+ -- That is of the "wrong" type, so we fetch it as a
+ -- Field_Size_32_Bit.
+
+ if Get_32_Bit_Val (N, Offset) = 0 then
+ Result := Default_Val;
+
+ else
+ Result := Get_Field (N, Offset);
+ end if;
+
+ return Result;
+ end Get_32_Bit_Field_With_Default;
+
+ function Get_Valid_32_Bit_Field
+ (N : Node_Or_Entity_Id; Offset : Field_Offset) return Field_Type
+ is
+ pragma Assert (Get_32_Bit_Val (N, Offset) /= 0);
+ -- If the field has not yet been set, it will be equal to zero.
+ -- This asserts that we don't call Get_ before Set_. Note that
+ -- the predicate on the Val parameter of Set_ checks for the No_...
+ -- value, so it can't possibly be (for example) No_Uint here.
+
+ function Get_Field is new Get_32_Bit_Field (Field_Type) with Inline;
+ Result : constant Field_Type := Get_Field (N, Offset);
+ begin
+ return Result;
+ end Get_Valid_32_Bit_Field;
+
+ procedure Set_1_Bit_Field
+ (N : Node_Or_Entity_Id; Offset : Field_Offset; Val : Field_Type)
+ is
+ pragma Assert (Field_Type'Size = 1);
+
+ function Cast is new
+ Unchecked_Conversion (Field_Type, Field_Size_1_Bit);
+ begin
+ Set_1_Bit_Val (N, Offset, Cast (Val));
+ end Set_1_Bit_Field;
+
+ procedure Set_2_Bit_Field
+ (N : Node_Or_Entity_Id; Offset : Field_Offset; Val : Field_Type)
+ is
+ pragma Assert (Field_Type'Size = 2);
+
+ function Cast is new
+ Unchecked_Conversion (Field_Type, Field_Size_2_Bit);
+ begin
+ Set_2_Bit_Val (N, Offset, Cast (Val));
+ end Set_2_Bit_Field;
+
+ procedure Set_4_Bit_Field
+ (N : Node_Or_Entity_Id; Offset : Field_Offset; Val : Field_Type)
+ is
+ pragma Assert (Field_Type'Size = 4);
+
+ function Cast is new
+ Unchecked_Conversion (Field_Type, Field_Size_4_Bit);
+ begin
+ Set_4_Bit_Val (N, Offset, Cast (Val));
+ end Set_4_Bit_Field;
+
+ procedure Set_8_Bit_Field
+ (N : Node_Or_Entity_Id; Offset : Field_Offset; Val : Field_Type)
+ is
+ pragma Assert (Field_Type'Size = 8);
+
+ function Cast is new
+ Unchecked_Conversion (Field_Type, Field_Size_8_Bit);
+ begin
+ Set_8_Bit_Val (N, Offset, Cast (Val));
+ end Set_8_Bit_Field;
+
+ procedure Set_32_Bit_Field
+ (N : Node_Or_Entity_Id; Offset : Field_Offset; Val : Field_Type)
+ is
+ pragma Assert (Field_Type'Size = 32);
+
+ function Cast is new
+ Unchecked_Conversion (Field_Type, Field_Size_32_Bit);
+ begin
+ Set_32_Bit_Val (N, Offset, Cast (Val));
+ end Set_32_Bit_Field;
+
+ function Get_1_Bit_Val
+ (N : Node_Or_Entity_Id; Offset : Field_Offset) return Field_Size_1_Bit
+ is
+ -- We wish we were using packed arrays, but instead we're simulating
+ -- them with modular integers. L here (and elsewhere) is the 'Length
+ -- of that simulated array.
+ L : constant Field_Offset := Slot_Size / 1;
+
+ pragma Debug (Validate_Node_And_Offset (N, Offset / L));
+
+ S : Slot renames Slots.Table (Node_Offsets.Table (N) + Offset / L);
+ V : constant Natural := Natural ((Offset mod L) * (Slot_Size / L));
+ begin
+ return Field_Size_1_Bit (Shift_Right (S, V) and 1);
+ end Get_1_Bit_Val;
+
+ function Get_2_Bit_Val
+ (N : Node_Or_Entity_Id; Offset : Field_Offset) return Field_Size_2_Bit
+ is
+ L : constant Field_Offset := Slot_Size / 2;
+
+ pragma Debug (Validate_Node_And_Offset (N, Offset / L));
+
+ S : Slot renames Slots.Table (Node_Offsets.Table (N) + Offset / L);
+ V : constant Natural := Natural ((Offset mod L) * (Slot_Size / L));
+ begin
+ return Field_Size_2_Bit (Shift_Right (S, V) and 3);
+ end Get_2_Bit_Val;
+
+ function Get_4_Bit_Val
+ (N : Node_Or_Entity_Id; Offset : Field_Offset) return Field_Size_4_Bit
+ is
+ L : constant Field_Offset := Slot_Size / 4;
+
+ pragma Debug (Validate_Node_And_Offset (N, Offset / L));
+
+ S : Slot renames Slots.Table (Node_Offsets.Table (N) + Offset / L);
+ V : constant Natural := Natural ((Offset mod L) * (Slot_Size / L));
+ begin
+ return Field_Size_4_Bit (Shift_Right (S, V) and 15);
+ end Get_4_Bit_Val;
+
+ function Get_8_Bit_Val
+ (N : Node_Or_Entity_Id; Offset : Field_Offset) return Field_Size_8_Bit
+ is
+ L : constant Field_Offset := Slot_Size / 8;
+
+ pragma Debug (Validate_Node_And_Offset (N, Offset / L));
+
+ S : Slot renames Slots.Table (Node_Offsets.Table (N) + Offset / L);
+ V : constant Natural := Natural ((Offset mod L) * (Slot_Size / L));
+ begin
+ return Field_Size_8_Bit (Shift_Right (S, V) and 255);
+ end Get_8_Bit_Val;
+
+ function Get_32_Bit_Val
+ (N : Node_Or_Entity_Id; Offset : Field_Offset) return Field_Size_32_Bit
+ is
+ pragma Debug (Validate_Node_And_Offset (N, Offset));
+
+ S : Slot renames Slots.Table (Node_Offsets.Table (N) + Offset);
+ begin
+ return Field_Size_32_Bit (S);
+ end Get_32_Bit_Val;
+
+ procedure Set_1_Bit_Val
+ (N : Node_Or_Entity_Id; Offset : Field_Offset; Val : Field_Size_1_Bit)
+ is
+ L : constant Field_Offset := Slot_Size / 1;
+
+ pragma Debug (Validate_Node_And_Offset_Write (N, Offset / L));
+
+ S : Slot renames Slots.Table (Node_Offsets.Table (N) + Offset / L);
+ V : constant Natural := Natural ((Offset mod L) * (Slot_Size / L));
+ begin
+ S := (S and not Shift_Left (1, V)) or Shift_Left (Slot (Val), V);
+ end Set_1_Bit_Val;
+
+ procedure Set_2_Bit_Val
+ (N : Node_Or_Entity_Id; Offset : Field_Offset; Val : Field_Size_2_Bit)
+ is
+ L : constant Field_Offset := Slot_Size / 2;
+
+ pragma Debug (Validate_Node_And_Offset_Write (N, Offset / L));
+
+ S : Slot renames Slots.Table (Node_Offsets.Table (N) + Offset / L);
+ V : constant Natural := Natural ((Offset mod L) * (Slot_Size / L));
+ begin
+ S := (S and not Shift_Left (3, V)) or Shift_Left (Slot (Val), V);
+ end Set_2_Bit_Val;
+
+ procedure Set_4_Bit_Val
+ (N : Node_Or_Entity_Id; Offset : Field_Offset; Val : Field_Size_4_Bit)
+ is
+ L : constant Field_Offset := Slot_Size / 4;
+
+ pragma Debug (Validate_Node_And_Offset_Write (N, Offset / L));
+
+ S : Slot renames Slots.Table (Node_Offsets.Table (N) + Offset / L);
+ V : constant Natural := Natural ((Offset mod L) * (Slot_Size / L));
+ begin
+ S := (S and not Shift_Left (15, V)) or Shift_Left (Slot (Val), V);
+ end Set_4_Bit_Val;
+
+ procedure Set_8_Bit_Val
+ (N : Node_Or_Entity_Id; Offset : Field_Offset; Val : Field_Size_8_Bit)
+ is
+ L : constant Field_Offset := Slot_Size / 8;
+
+ pragma Debug (Validate_Node_And_Offset_Write (N, Offset / L));
+
+ S : Slot renames Slots.Table (Node_Offsets.Table (N) + Offset / L);
+ V : constant Natural := Natural ((Offset mod L) * (Slot_Size / L));
+ begin
+ S := (S and not Shift_Left (255, V)) or Shift_Left (Slot (Val), V);
+ end Set_8_Bit_Val;
+
+ procedure Set_32_Bit_Val
+ (N : Node_Or_Entity_Id; Offset : Field_Offset; Val : Field_Size_32_Bit)
+ is
+ pragma Debug (Validate_Node_And_Offset_Write (N, Offset));
+
+ S : Slot renames Slots.Table (Node_Offsets.Table (N) + Offset);
+ begin
+ S := Slot (Val);
+ end Set_32_Bit_Val;
+
+ end Atree_Private_Part;
+
+ ---------------
+ -- Set_Field --
+ ---------------
+
+ function Get_Node_Field_Union is new Get_32_Bit_Field (Union_Id)
+ with Inline;
+ -- Called when we don't know whether a field is a Node_Id or a List_Id,
+ -- etc.
+
+ function Get_Field_Value
+ (N : Node_Id; Field : Node_Field) return Field_Size_32_Bit
+ is
+ pragma Assert (Field_Checking.Field_Present (Nkind (N), Field));
+ Desc : Field_Descriptor renames Node_Field_Descriptors (Field);
- function Allocate_New_Node return Node_Id is
- New_Id : Node_Id;
begin
- Nodes.Append (Default_Node);
- New_Id := Nodes.Last;
- Flags.Append (Default_Flags);
- Orig_Nodes.Append (New_Id);
- Nodes.Table (Nodes.Last).Comes_From_Source :=
- Comes_From_Source_Default;
- Allocate_List_Tables (Nodes.Last);
- Report (Target => New_Id, Source => Empty);
+ case Field_Size (Desc.Kind) is
+ when 1 => return Field_Size_32_Bit (Get_1_Bit_Val (N, Desc.Offset));
+ when 2 => return Field_Size_32_Bit (Get_2_Bit_Val (N, Desc.Offset));
+ when 4 => return Field_Size_32_Bit (Get_4_Bit_Val (N, Desc.Offset));
+ when 8 => return Field_Size_32_Bit (Get_8_Bit_Val (N, Desc.Offset));
+ when others => return Get_32_Bit_Val (N, Desc.Offset); -- 32
+ end case;
+ end Get_Field_Value;
- return New_Id;
- end Allocate_New_Node;
+ procedure Set_Field_Value
+ (N : Node_Id; Field : Node_Field; Val : Field_Size_32_Bit)
+ is
+ pragma Assert (Field_Checking.Field_Present (Nkind (N), Field));
+ Desc : Field_Descriptor renames Node_Field_Descriptors (Field);
- --------------
- -- Analyzed --
- --------------
+ begin
+ case Field_Size (Desc.Kind) is
+ when 1 => Set_1_Bit_Val (N, Desc.Offset, Field_Size_1_Bit (Val));
+ when 2 => Set_2_Bit_Val (N, Desc.Offset, Field_Size_2_Bit (Val));
+ when 4 => Set_4_Bit_Val (N, Desc.Offset, Field_Size_4_Bit (Val));
+ when 8 => Set_8_Bit_Val (N, Desc.Offset, Field_Size_8_Bit (Val));
+ when others => Set_32_Bit_Val (N, Desc.Offset, Val); -- 32
+ end case;
+ end Set_Field_Value;
- function Analyzed (N : Node_Id) return Boolean is
+ procedure Reinit_Field_To_Zero (N : Node_Id; Field : Node_Field) is
begin
- pragma Assert (N <= Nodes.Last);
- return Nodes.Table (N).Analyzed;
- end Analyzed;
+ Set_Field_Value (N, Field, 0);
+ end Reinit_Field_To_Zero;
- --------------------------
- -- Basic_Set_Convention --
- --------------------------
+ function Field_Is_Initial_Zero
+ (N : Node_Id; Field : Node_Field) return Boolean is
+ begin
+ return Get_Field_Value (N, Field) = 0;
+ end Field_Is_Initial_Zero;
- procedure Basic_Set_Convention (E : Entity_Id; Val : Convention_Id) is
+ procedure Reinit_Field_To_Zero
+ (N : Node_Id; Field : Entity_Field; Old_Ekind : Entity_Kind_Set) is
begin
- pragma Assert (Nkind (E) in N_Entity);
- To_Flag_Word_Ptr
- (Union_Id_Ptr'
- (Nodes.Table (E + 2).Field12'Unrestricted_Access)).Convention := Val;
- end Basic_Set_Convention;
+ pragma Assert (Old_Ekind (Ekind (N)), "Reinit: " & Ekind (N)'Img);
+ Reinit_Field_To_Zero (N, Field);
+ end Reinit_Field_To_Zero;
- -------------------
- -- Check_Actuals --
- -------------------
+ procedure Reinit_Field_To_Zero
+ (N : Node_Id; Field : Entity_Field; Old_Ekind : Entity_Kind) is
+ Old_Ekind_Set : Entity_Kind_Set := (others => False);
+ begin
+ Old_Ekind_Set (Old_Ekind) := True;
+ Reinit_Field_To_Zero (N, Field, Old_Ekind => Old_Ekind_Set);
+ end Reinit_Field_To_Zero;
+
+ procedure Check_Vanishing_Fields
+ (Old_N : Node_Id; New_Kind : Node_Kind)
+ is
+ Old_Kind : constant Node_Kind := Nkind (Old_N);
+
+ -- If this fails, it means you need to call Reinit_Field_To_Zero before
+ -- calling Set_Nkind.
+
+ begin
+ for J in Node_Field_Table (Old_Kind)'Range loop
+ declare
+ F : constant Node_Field := Node_Field_Table (Old_Kind) (J);
+ begin
+ if not Field_Checking.Field_Present (New_Kind, F) then
+ if not Field_Is_Initial_Zero (Old_N, F) then
+ Write_Str (Old_Kind'Img);
+ Write_Str (" --> ");
+ Write_Str (New_Kind'Img);
+ Write_Str (" Nonzero field ");
+ Write_Str (F'Img);
+ Write_Str (" is vanishing for node ");
+ Write_Int (Nat (Old_N));
+ Write_Eol;
+
+ raise Program_Error;
+ end if;
+ end if;
+ end;
+ end loop;
+ end Check_Vanishing_Fields;
+
+ function Get_Field_Value
+ (N : Entity_Id; Field : Entity_Field) return Field_Size_32_Bit
+ is
+ pragma Assert (Field_Checking.Field_Present (Ekind (N), Field));
+ Desc : Field_Descriptor renames Entity_Field_Descriptors (Field);
+ begin
+ case Field_Size (Desc.Kind) is
+ when 1 => return Field_Size_32_Bit (Get_1_Bit_Val (N, Desc.Offset));
+ when 2 => return Field_Size_32_Bit (Get_2_Bit_Val (N, Desc.Offset));
+ when 4 => return Field_Size_32_Bit (Get_4_Bit_Val (N, Desc.Offset));
+ when 8 => return Field_Size_32_Bit (Get_8_Bit_Val (N, Desc.Offset));
+ when others => return Get_32_Bit_Val (N, Desc.Offset); -- 32
+ end case;
+ end Get_Field_Value;
+
+ procedure Set_Field_Value
+ (N : Entity_Id; Field : Entity_Field; Val : Field_Size_32_Bit)
+ is
+ pragma Assert (Field_Checking.Field_Present (Ekind (N), Field));
+ Desc : Field_Descriptor renames Entity_Field_Descriptors (Field);
+ begin
+ case Field_Size (Desc.Kind) is
+ when 1 => Set_1_Bit_Val (N, Desc.Offset, Field_Size_1_Bit (Val));
+ when 2 => Set_2_Bit_Val (N, Desc.Offset, Field_Size_2_Bit (Val));
+ when 4 => Set_4_Bit_Val (N, Desc.Offset, Field_Size_4_Bit (Val));
+ when 8 => Set_8_Bit_Val (N, Desc.Offset, Field_Size_8_Bit (Val));
+ when others => Set_32_Bit_Val (N, Desc.Offset, Val); -- 32
+ end case;
+ end Set_Field_Value;
+
+ procedure Reinit_Field_To_Zero (N : Node_Id; Field : Entity_Field) is
+ begin
+ Set_Field_Value (N, Field, 0);
+ end Reinit_Field_To_Zero;
+
+ function Field_Is_Initial_Zero
+ (N : Entity_Id; Field : Entity_Field) return Boolean is
+ begin
+ return Get_Field_Value (N, Field) = 0;
+ end Field_Is_Initial_Zero;
+
+ procedure Check_Vanishing_Fields
+ (Old_N : Entity_Id; New_Kind : Entity_Kind)
+ is
+ Old_Kind : constant Entity_Kind := Ekind (Old_N);
+
+ -- If this fails, it means you need to call Reinit_Field_To_Zero before
+ -- calling Mutate_Ekind. But we have many cases where vanishing fields
+ -- are expected to reappear after converting to/from E_Void. Other cases
+ -- are more problematic; set a breakpoint on "(non-E_Void case)" below.
- function Check_Actuals (N : Node_Id) return Boolean is
begin
- return Flags.Table (N).Check_Actuals;
- end Check_Actuals;
+ for J in Entity_Field_Table (Old_Kind)'Range loop
+ declare
+ F : constant Entity_Field := Entity_Field_Table (Old_Kind) (J);
+ begin
+ if not Field_Checking.Field_Present (New_Kind, F) then
+ if not Field_Is_Initial_Zero (Old_N, F) then
+ Write_Str (Old_Kind'Img);
+ Write_Str (" --> ");
+ Write_Str (New_Kind'Img);
+ Write_Str (" Nonzero field ");
+ Write_Str (F'Img);
+ Write_Str (" is vanishing for node ");
+ Write_Int (Nat (Old_N));
+ Write_Eol;
+
+ if New_Kind = E_Void or else Old_Kind = E_Void then
+ Write_Line (" (E_Void case)");
+ else
+ Write_Line (" (non-E_Void case)");
+ end if;
+ end if;
+ end if;
+ end;
+ end loop;
+ end Check_Vanishing_Fields;
+
+ Nkind_Offset : constant Field_Offset :=
+ Node_Field_Descriptors (F_Nkind).Offset;
+
+ procedure Set_Node_Kind_Type is new Set_8_Bit_Field (Node_Kind) with Inline;
+
+ procedure Init_Nkind (N : Node_Id; Val : Node_Kind) is
+ pragma Assert (Field_Is_Initial_Zero (N, F_Nkind));
+ begin
+ Set_Node_Kind_Type (N, Nkind_Offset, Val);
+ end Init_Nkind;
+
+ procedure Mutate_Nkind
+ (N : Node_Id; Val : Node_Kind; Old_Size : Slot_Count)
+ is
+ New_Size : constant Slot_Count := Size_In_Slots_To_Alloc (Val);
+
+ All_Node_Offsets : Node_Offsets.Table_Type renames
+ Node_Offsets.Table (Node_Offsets.First .. Node_Offsets.Last);
+ begin
+ pragma Debug (Check_Vanishing_Fields (N, Val));
+
+ -- Grow the slots if necessary
+
+ if Old_Size < New_Size then
+ declare
+ Old_Last_Slot : constant Node_Offset := Slots.Last;
+ Old_Off_0 : constant Node_Offset := Off_0 (N);
+ begin
+ if Old_Last_Slot = Old_Off_0 + Old_Size - 1 then
+ -- In this case, the slots are at the end of Slots.Table, so we
+ -- don't need to move them.
+ Slots.Set_Last (Old_Last_Slot + New_Size - Old_Size);
+
+ else
+ -- Move the slots
+ All_Node_Offsets (N) := Alloc_Slots (New_Size);
+ Copy_Slots (Old_Off_0, Off_0 (N), Old_Size);
+ pragma Debug (Zero_Slots (Old_Off_0, Old_Off_0 + Old_Size - 1));
+ end if;
+ end;
+
+ Zero_Slots (Off_0 (N) + Old_Size, Slots.Last);
+ end if;
+
+ Set_Node_Kind_Type (N, Nkind_Offset, Val);
+ pragma Debug (Validate_Node_Write (N));
+ end Mutate_Nkind;
+
+ procedure Mutate_Nkind (N : Node_Id; Val : Node_Kind) is
+ begin
+ Mutate_Nkind (N, Val, Old_Size => Size_In_Slots (N));
+ end Mutate_Nkind;
+
+ Ekind_Offset : constant Field_Offset :=
+ Entity_Field_Descriptors (F_Ekind).Offset;
+
+ procedure Set_Entity_Kind_Type is new Set_8_Bit_Field (Entity_Kind)
+ with Inline;
+
+ procedure Mutate_Ekind
+ (N : Entity_Id; Val : Entity_Kind)
+ is
+ begin
+ if Ekind (N) = Val then
+ return;
+ end if;
+
+ if Debug_Flag_Underscore_V then
+ pragma Debug (Check_Vanishing_Fields (N, Val));
+ end if;
+
+ -- For now, we are allocating all entities with the same size, so we
+ -- don't need to reallocate slots here.
+
+ Set_Entity_Kind_Type (N, Ekind_Offset, Val);
+ pragma Debug (Validate_Node_Write (N));
+ end Mutate_Ekind;
+
+ -----------------------
+ -- Allocate_New_Node --
+ -----------------------
+
+ function Allocate_New_Node (Kind : Node_Kind) return Node_Id is
+ begin
+ return Result : constant Node_Id := Alloc_Node_Id do
+ declare
+ Sz : constant Slot_Count := Size_In_Slots_To_Alloc (Kind);
+ Sl : constant Node_Offset := Alloc_Slots (Sz);
+ begin
+ Node_Offsets.Table (Result) := Sl;
+ Zero_Slots (Sl, Sl + Sz - 1);
+ end;
+
+ Init_Nkind (Result, Kind);
+
+ Orig_Nodes.Append (Result);
+ Set_Comes_From_Source (Result, Comes_From_Source_Default);
+ Allocate_List_Tables (Result);
+ Report (Target => Result, Source => Empty);
+ end return;
+ end Allocate_New_Node;
--------------------------
-- Check_Error_Detected --
@@ -628,20 +1035,21 @@ package body Atree is
-- Change_Node --
-----------------
- procedure Change_Node (N : Node_Id; New_Node_Kind : Node_Kind) is
-
- -- Flags table attributes
+ procedure Change_Node (N : Node_Id; New_Kind : Node_Kind) is
+ pragma Debug (Validate_Node_Write (N));
+ pragma Assert (Nkind (N) not in N_Entity);
+ pragma Assert (New_Kind not in N_Entity);
- Save_CA : constant Boolean := Flags.Table (N).Check_Actuals;
- Save_Is_IGN : constant Boolean := Flags.Table (N).Is_Ignored_Ghost_Node;
+ Old_Size : constant Slot_Count := Size_In_Slots (N);
+ New_Size : constant Slot_Count := Size_In_Slots_To_Alloc (New_Kind);
- -- Nodes table attributes
-
- Save_CFS : constant Boolean := Nodes.Table (N).Comes_From_Source;
- Save_In_List : constant Boolean := Nodes.Table (N).In_List;
- Save_Link : constant Union_Id := Nodes.Table (N).Link;
- Save_Posted : constant Boolean := Nodes.Table (N).Error_Posted;
Save_Sloc : constant Source_Ptr := Sloc (N);
+ Save_In_List : constant Boolean := In_List (N);
+ Save_CFS : constant Boolean := Comes_From_Source (N);
+ Save_Posted : constant Boolean := Error_Posted (N);
+ Save_CA : constant Boolean := Check_Actuals (N);
+ Save_Is_IGN : constant Boolean := Is_Ignored_Ghost_Node (N);
+ Save_Link : constant Union_Id := Link (N);
Par_Count : Nat := 0;
@@ -650,73 +1058,104 @@ package body Atree is
Par_Count := Paren_Count (N);
end if;
- Nodes.Table (N) := Default_Node;
- Nodes.Table (N).Sloc := Save_Sloc;
- Nodes.Table (N).In_List := Save_In_List;
- Nodes.Table (N).Link := Save_Link;
- Nodes.Table (N).Comes_From_Source := Save_CFS;
- Nodes.Table (N).Nkind := New_Node_Kind;
- Nodes.Table (N).Error_Posted := Save_Posted;
+ if New_Size > Old_Size then
+ declare
+ New_Offset : constant Field_Offset := Alloc_Slots (New_Size);
+ begin
+ pragma Debug (Zero_Slots (N));
+ Node_Offsets.Table (N) := New_Offset;
+ Zero_Slots (New_Offset, New_Offset + New_Size - 1);
+ end;
+
+ else
+ Zero_Slots (N);
+ end if;
+
+ Mutate_Nkind (N, New_Kind, Old_Size);
- Flags.Table (N) := Default_Flags;
- Flags.Table (N).Check_Actuals := Save_CA;
- Flags.Table (N).Is_Ignored_Ghost_Node := Save_Is_IGN;
+ Set_Sloc (N, Save_Sloc);
+ Set_In_List (N, Save_In_List);
+ Set_Comes_From_Source (N, Save_CFS);
+ Set_Error_Posted (N, Save_Posted);
+ Set_Check_Actuals (N, Save_CA);
+ Set_Is_Ignored_Ghost_Node (N, Save_Is_IGN);
+ Set_Link (N, Save_Link);
- if New_Node_Kind in N_Subexpr then
+ if New_Kind in N_Subexpr then
Set_Paren_Count (N, Par_Count);
end if;
end Change_Node;
- -----------------------
- -- Comes_From_Source --
- -----------------------
+ ----------------
+ -- Copy_Slots --
+ ----------------
+
+ procedure Copy_Slots (From, To : Node_Offset; Num_Slots : Slot_Count) is
+ pragma Assert (From /= To);
+
+ All_Slots : Slots.Table_Type renames
+ Slots.Table (Slots.First .. Slots.Last);
+
+ Source_Slots : Slots.Table_Type renames
+ All_Slots (From .. From + Num_Slots - 1);
+
+ Destination_Slots : Slots.Table_Type renames
+ All_Slots (To .. To + Num_Slots - 1);
- function Comes_From_Source (N : Node_Id) return Boolean is
begin
- pragma Assert (N <= Nodes.Last);
- return Nodes.Table (N).Comes_From_Source;
- end Comes_From_Source;
+ Destination_Slots := Source_Slots;
+ end Copy_Slots;
- ----------------
- -- Convention --
- ----------------
+ procedure Copy_Slots (Source, Destination : Node_Id) is
+ pragma Debug (Validate_Node (Source));
+ pragma Debug (Validate_Node_Write (Destination));
+ pragma Assert (Source /= Destination);
+
+ S_Size : constant Slot_Count := Size_In_Slots (Source);
+
+ All_Node_Offsets : Node_Offsets.Table_Type renames
+ Node_Offsets.Table (Node_Offsets.First .. Node_Offsets.Last);
- function Convention (E : Entity_Id) return Convention_Id is
begin
- pragma Assert (Nkind (E) in N_Entity);
- return To_Flag_Word (Nodes.Table (E + 2).Field12).Convention;
- end Convention;
+ Copy_Slots
+ (All_Node_Offsets (Source), All_Node_Offsets (Destination), S_Size);
+ end Copy_Slots;
---------------
-- Copy_Node --
---------------
- procedure Copy_Node (Source : Node_Id; Destination : Node_Id) is
- Save_In_List : constant Boolean := Nodes.Table (Destination).In_List;
- Save_Link : constant Union_Id := Nodes.Table (Destination).Link;
+ procedure Copy_Node (Source, Destination : Node_Or_Entity_Id) is
+ pragma Assert (Source /= Destination);
+
+ Save_In_List : constant Boolean := In_List (Destination);
+ Save_Link : constant Union_Id := Link (Destination);
+
+ S_Size : constant Slot_Count := Size_In_Slots_To_Alloc (Source);
+ D_Size : constant Slot_Count := Size_In_Slots_To_Alloc (Destination);
begin
- pragma Debug (New_Node_Debugging_Output (Source));
- pragma Debug (New_Node_Debugging_Output (Destination));
+ New_Node_Debugging_Output (Source);
+ New_Node_Debugging_Output (Destination);
- Nodes.Table (Destination) := Nodes.Table (Source);
- Nodes.Table (Destination).In_List := Save_In_List;
- Nodes.Table (Destination).Link := Save_Link;
+ -- Currently all entities are allocated the same number of slots.
+ -- Hopefully that won't always be the case, but if it is, the following
+ -- is suboptimal if D_Size < S_Size, because in fact the Destination was
+ -- allocated the max.
- Flags.Table (Destination) := Flags.Table (Source);
+ -- If Source doesn't fit in Destination, we need to allocate
- Set_Paren_Count_Of_Copy (Target => Destination, Source => Source);
+ if D_Size < S_Size then
+ pragma Debug (Zero_Slots (Destination)); -- destroy old slots
+ Node_Offsets.Table (Destination) := Alloc_Slots (S_Size);
+ end if;
- -- Deal with copying extension nodes if present. No need to copy flags
- -- table entries, since they are always zero for extending components.
+ Copy_Slots (Source, Destination);
- pragma Assert (Has_Extension (Source) = Has_Extension (Destination));
+ Set_In_List (Destination, Save_In_List);
+ Set_Link (Destination, Save_Link);
- if Has_Extension (Source) then
- for J in 1 .. Num_Extension_Nodes loop
- Nodes.Table (Destination + J) := Nodes.Table (Source + J);
- end loop;
- end if;
+ Set_Paren_Count_Of_Copy (Target => Destination, Source => Source);
end Copy_Node;
------------------------
@@ -725,10 +1164,9 @@ package body Atree is
function Copy_Separate_List (Source : List_Id) return List_Id is
Result : constant List_Id := New_List;
- Nod : Node_Id;
+ Nod : Node_Id := First (Source);
begin
- Nod := First (Source);
while Present (Nod) loop
Append (Copy_Separate_Tree (Nod), Result);
Next (Nod);
@@ -742,10 +1180,13 @@ package body Atree is
------------------------
function Copy_Separate_Tree (Source : Node_Id) return Node_Id is
+
+ pragma Debug (Validate_Node (Source));
+
New_Id : Node_Id;
function Copy_Entity (E : Entity_Id) return Entity_Id;
- -- Copy Entity, copying only the Ekind and Chars fields
+ -- Copy Entity, copying only Chars field
function Copy_List (List : List_Id) return List_Id;
-- Copy list
@@ -759,25 +1200,13 @@ package body Atree is
-----------------
function Copy_Entity (E : Entity_Id) return Entity_Id is
- New_Ent : Entity_Id;
-
begin
- -- Build appropriate node
-
- case N_Entity (Nkind (E)) is
- when N_Defining_Identifier =>
- New_Ent := New_Entity (N_Defining_Identifier, Sloc (E));
-
- when N_Defining_Character_Literal =>
- New_Ent := New_Entity (N_Defining_Character_Literal, Sloc (E));
+ pragma Assert (Nkind (E) in N_Entity);
- when N_Defining_Operator_Symbol =>
- New_Ent := New_Entity (N_Defining_Operator_Symbol, Sloc (E));
- end case;
-
- Set_Chars (New_Ent, Chars (E));
- -- Set_Comes_From_Source (New_Ent, Comes_From_Source (E));
- return New_Ent;
+ return Result : constant Entity_Id := New_Entity (Nkind (E), Sloc (E))
+ do
+ Set_Chars (Result, Chars (E));
+ end return;
end Copy_Entity;
---------------
@@ -797,7 +1226,7 @@ package body Atree is
E := First (List);
while Present (E) loop
- if Has_Extension (E) then
+ if Is_Entity (E) then
Append (Copy_Entity (E), NL);
else
Append (Copy_Separate_Tree (E), NL);
@@ -821,7 +1250,9 @@ package body Atree is
if Field in Node_Range then
New_N := Union_Id (Copy_Separate_Tree (Node_Id (Field)));
- if Parent (Node_Id (Field)) = Source then
+ if Present (Node_Id (Field))
+ and then Parent (Node_Id (Field)) = Source
+ then
Set_Parent (Node_Id (New_N), New_Id);
end if;
@@ -841,25 +1272,21 @@ package body Atree is
end if;
end Possible_Copy;
+ procedure Walk is new Walk_Sinfo_Fields_Pairwise (Possible_Copy);
+
-- Start of processing for Copy_Separate_Tree
begin
if Source <= Empty_Or_Error then
return Source;
- elsif Has_Extension (Source) then
+ elsif Is_Entity (Source) then
return Copy_Entity (Source);
else
New_Id := New_Copy (Source);
- -- Recursively copy descendants
-
- Set_Field1 (New_Id, Possible_Copy (Field1 (New_Id)));
- Set_Field2 (New_Id, Possible_Copy (Field2 (New_Id)));
- Set_Field3 (New_Id, Possible_Copy (Field3 (New_Id)));
- Set_Field4 (New_Id, Possible_Copy (Field4 (New_Id)));
- Set_Field5 (New_Id, Possible_Copy (Field5 (New_Id)));
+ Walk (New_Id, Source);
-- Explicitly copy the aspect specifications as those do not reside
-- in a node field.
@@ -902,18 +1329,24 @@ package body Atree is
-- 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
- -- of Atree.Unchecked_Access is at least all in the family.
+ -- Consequently we have no choice but to hold our noses and do the
+ -- change manually. At least we are Atree, so this is at least all
+ -- in the family.
- -- Change the node type
+ -- Clear the Chars field which is not present in a selected
+ -- component node, so we don't want a junk value around. Note that
+ -- we can't just call Set_Chars, because Empty is of the wrong
+ -- type, and is outside the range of Name_Id.
- Atree.Unchecked_Access.Set_Nkind (New_Id, N_Selected_Component);
+ Reinit_Field_To_Zero (New_Id, F_Chars);
+ Reinit_Field_To_Zero (New_Id, F_Has_Private_View);
+ Reinit_Field_To_Zero (New_Id, F_Is_Elaboration_Checks_OK_Node);
+ Reinit_Field_To_Zero (New_Id, F_Is_Elaboration_Warnings_OK_Node);
+ Reinit_Field_To_Zero (New_Id, F_Is_SPARK_Mode_On_Node);
- -- Clear the Chars field which is not present in a selected
- -- component node, so we don't want a junk value around.
+ -- Change the node type
- Set_Node1 (New_Id, Empty);
+ Mutate_Nkind (New_Id, N_Selected_Component);
end if;
-- All done, return copied node
@@ -922,58 +1355,22 @@ package body Atree is
end if;
end Copy_Separate_Tree;
- -----------
- -- Ekind --
- -----------
-
- function Ekind (E : Entity_Id) return Entity_Kind is
- begin
- pragma Assert (Nkind (E) in N_Entity);
- return N_To_E (Nodes.Table (E + 1).Nkind);
- end Ekind;
-
- ------------------
- -- Error_Posted --
- ------------------
-
- function Error_Posted (N : Node_Id) return Boolean is
- begin
- pragma Assert (N <= Nodes.Last);
- return Nodes.Table (N).Error_Posted;
- end Error_Posted;
-
-----------------------
-- Exchange_Entities --
-----------------------
procedure Exchange_Entities (E1 : Entity_Id; E2 : Entity_Id) is
- Temp_Ent : Node_Record;
- Temp_Flg : Flags_Byte;
-
- begin
- pragma Debug (New_Node_Debugging_Output (E1));
- pragma Debug (New_Node_Debugging_Output (E2));
-
- pragma Assert (True
- and then Has_Extension (E1)
- and then Has_Extension (E2)
- and then not Nodes.Table (E1).In_List
- and then not Nodes.Table (E2).In_List);
-
- -- Exchange the contents of the two entities
-
- for J in 0 .. Num_Extension_Nodes loop
- Temp_Ent := Nodes.Table (E1 + J);
- Nodes.Table (E1 + J) := Nodes.Table (E2 + J);
- Nodes.Table (E2 + J) := Temp_Ent;
- end loop;
+ pragma Debug (Validate_Node_Write (E1));
+ pragma Debug (Validate_Node_Write (E2));
+ pragma Assert
+ (Is_Entity (E1) and then Is_Entity (E2)
+ and then not In_List (E1) and then not In_List (E2));
- -- Exchange flag bytes for first component. No need to do the exchange
- -- for the other components, since the flag bytes are always zero.
+ Old_E1 : constant Node_Offset := Node_Offsets.Table (E1);
- Temp_Flg := Flags.Table (E1);
- Flags.Table (E1) := Flags.Table (E2);
- Flags.Table (E2) := Temp_Flg;
+ begin
+ Node_Offsets.Table (E1) := Node_Offsets.Table (E2);
+ Node_Offsets.Table (E2) := Old_E1;
-- That exchange exchanged the parent pointers as well, which is what
-- we want, but we need to patch up the defining identifier pointers
@@ -982,79 +1379,42 @@ package body Atree is
-- case we don't do anything otherwise we won't be able to revert back
-- to the original situation.
- -- Shouldn't this use Is_Itype instead of the Parent test
+ -- Shouldn't this use Is_Itype instead of the Parent test???
if Present (Parent (E1)) and then Present (Parent (E2)) then
Set_Defining_Identifier (Parent (E1), E1);
Set_Defining_Identifier (Parent (E2), E2);
end if;
+
+ New_Node_Debugging_Output (E1);
+ New_Node_Debugging_Output (E2);
end Exchange_Entities;
-----------------
-- Extend_Node --
-----------------
- function Extend_Node (Source : Node_Id) return Entity_Id is
+ procedure Extend_Node (Source : Node_Id) is
pragma Assert (Present (Source));
- pragma Assert (not Has_Extension (Source));
- New_Id : Entity_Id;
-
- procedure Debug_Extend_Node;
- pragma Inline (Debug_Extend_Node);
- -- Debug routine for -gnatdn
-
- -----------------------
- -- Debug_Extend_Node --
- -----------------------
-
- procedure Debug_Extend_Node is
- begin
- if Debug_Flag_N then
- Write_Str ("Extend node ");
- Write_Int (Int (Source));
-
- if New_Id = Source then
- Write_Str (" in place");
- else
- Write_Str (" copied to ");
- Write_Int (Int (New_Id));
- end if;
-
- -- Write_Eol;
- end if;
- end Debug_Extend_Node;
+ pragma Assert (not Is_Entity (Source));
+
+ Old_Kind : constant Node_Kind := Nkind (Source);
+ New_Kind : constant Node_Kind :=
+ (case Old_Kind is
+ when N_Character_Literal => N_Defining_Character_Literal,
+ when N_Identifier => N_Defining_Identifier,
+ when N_Operator_Symbol => N_Defining_Operator_Symbol,
+ when others => N_Unused_At_Start); -- can't happen
+ -- The new NKind, which is the appropriate value of N_Entity based on
+ -- the old Nkind. N_xxx is mapped to N_Defining_xxx.
+ pragma Assert (New_Kind in N_Entity);
-- Start of processing for Extend_Node
begin
- -- Optimize the case where Source happens to be the last node; in that
- -- case, we don't need to move it.
-
- if Source = Nodes.Last then
- New_Id := Source;
- else
- Nodes.Append (Nodes.Table (Source));
- Flags.Append (Flags.Table (Source));
- New_Id := Nodes.Last;
- Orig_Nodes.Append (New_Id);
- end if;
-
- Set_Check_Actuals (New_Id, False);
-
- -- Set extension nodes
-
- for J in 1 .. Num_Extension_Nodes loop
- Nodes.Append (Default_Node_Extension);
- Flags.Append (Default_Flags);
- end loop;
-
- Orig_Nodes.Set_Last (Nodes.Last);
- Allocate_List_Tables (Nodes.Last);
- Report (Target => New_Id, Source => Source);
-
- pragma Debug (Debug_Extend_Node);
-
- return New_Id;
+ Set_Check_Actuals (Source, False);
+ Mutate_Nkind (Source, New_Kind);
+ Report (Target => Source, Source => Source);
end Extend_Node;
-----------------
@@ -1081,7 +1441,7 @@ package body Atree is
if Field in Node_Range
and then Present (Node_Id (Field))
- and then not Nodes.Table (Node_Id (Field)).In_List
+ and then not In_List (Node_Id (Field))
and then Parent (Node_Id (Field)) = Ref_Node
then
Set_Parent (Node_Id (Field), Fix_Node);
@@ -1096,25 +1456,24 @@ package body Atree is
end if;
end Fix_Parent;
+ Fields : Node_Field_Array renames
+ Node_Field_Table (Nkind (Fix_Node)).all;
+
-- Start of processing for Fix_Parents
begin
- Fix_Parent (Field1 (Fix_Node));
- Fix_Parent (Field2 (Fix_Node));
- Fix_Parent (Field3 (Fix_Node));
- Fix_Parent (Field4 (Fix_Node));
- Fix_Parent (Field5 (Fix_Node));
+ for J in Fields'Range loop
+ declare
+ Desc : Field_Descriptor renames
+ Node_Field_Descriptors (Fields (J));
+ begin
+ if Desc.Kind in Node_Id_Field | List_Id_Field then
+ Fix_Parent (Get_Node_Field_Union (Fix_Node, Desc.Offset));
+ end if;
+ end;
+ end loop;
end Fix_Parents;
- -------------------
- -- Flags_Address --
- -------------------
-
- function Flags_Address return System.Address is
- begin
- return Flags.Table (First_Node_Id)'Address;
- end Flags_Address;
-
-----------------------------------
-- Get_Comes_From_Source_Default --
-----------------------------------
@@ -1124,24 +1483,14 @@ package body Atree is
return Comes_From_Source_Default;
end Get_Comes_From_Source_Default;
- -----------------
- -- Has_Aspects --
- -----------------
-
- function Has_Aspects (N : Node_Id) return Boolean is
- begin
- pragma Assert (N <= Nodes.Last);
- return Nodes.Table (N).Has_Aspects;
- end Has_Aspects;
-
- -------------------
- -- Has_Extension --
- -------------------
+ ---------------
+ -- Is_Entity --
+ ---------------
- function Has_Extension (N : Node_Id) return Boolean is
+ function Is_Entity (N : Node_Or_Entity_Id) return Boolean is
begin
- return N < Nodes.Last and then Nodes.Table (N + 1).Is_Extension;
- end Has_Extension;
+ return Nkind (N) in N_Entity;
+ end Is_Entity;
----------------
-- Initialize --
@@ -1152,40 +1501,28 @@ package body Atree is
pragma Warnings (Off, Dummy);
begin
- Atree_Private_Part.Nodes.Init;
- Atree_Private_Part.Flags.Init;
- Orig_Nodes.Init;
- Paren_Counts.Init;
-
-- Allocate Empty node
Dummy := New_Node (N_Empty, No_Location);
- Set_Name1 (Empty, No_Name);
+ Set_Chars (Empty, No_Name);
+ pragma Assert (Dummy = Empty);
-- Allocate Error node, and set Error_Posted, since we certainly
-- only generate an Error node if we do post some kind of error.
Dummy := New_Node (N_Error, No_Location);
- Set_Name1 (Error, Error_Name);
+ Set_Chars (Error, Error_Name);
Set_Error_Posted (Error, True);
+ pragma Assert (Dummy = Error);
end Initialize;
- ---------------------------
- -- Is_Ignored_Ghost_Node --
- ---------------------------
-
- function Is_Ignored_Ghost_Node (N : Node_Id) return Boolean is
- begin
- return Flags.Table (N).Is_Ignored_Ghost_Node;
- end Is_Ignored_Ghost_Node;
-
--------------------------
-- Is_Rewrite_Insertion --
--------------------------
function Is_Rewrite_Insertion (Node : Node_Id) return Boolean is
begin
- return Nodes.Table (Node).Rewrite_Ins;
+ return Rewrite_Ins (Node);
end Is_Rewrite_Insertion;
-----------------------------
@@ -1203,7 +1540,7 @@ package body Atree is
function Last_Node_Id return Node_Id is
begin
- return Nodes.Last;
+ return Node_Offsets.Last;
end Last_Node_Id;
----------
@@ -1212,14 +1549,6 @@ package body Atree is
procedure Lock is
begin
- -- We used to Release the tables, as in the comments below, but that is
- -- a waste of time. We're only wasting virtual memory here, and the
- -- release calls copy large amounts of data.
- -- ???Get rid of Release?
-
- -- Flags.Release;
- Flags.Locked := True;
- -- Orig_Nodes.Release;
Orig_Nodes.Locked := True;
end Lock;
@@ -1239,6 +1568,8 @@ package body Atree is
procedure Mark_New_Ghost_Node (N : Node_Or_Entity_Id) is
begin
+ pragma Debug (Validate_Node_Write (N));
+
-- The Ghost node is created within a Ghost region
if Ghost_Mode = Check then
@@ -1268,7 +1599,7 @@ package body Atree is
procedure Mark_Rewrite_Insertion (New_Node : Node_Id) is
begin
- Nodes.Table (New_Node).Rewrite_Ins := True;
+ Set_Rewrite_Ins (New_Node);
end Mark_Rewrite_Insertion;
--------------
@@ -1276,61 +1607,52 @@ package body Atree is
--------------
function New_Copy (Source : Node_Id) return Node_Id is
- New_Id : Node_Id;
+ pragma Debug (Validate_Node (Source));
+ S_Size : constant Slot_Count := Size_In_Slots_To_Alloc (Source);
begin
if Source <= Empty_Or_Error then
return Source;
end if;
- Nodes.Append (Nodes.Table (Source));
- Flags.Append (Flags.Table (Source));
- New_Id := Nodes.Last;
- Orig_Nodes.Append (New_Id);
- Set_Check_Actuals (New_Id, False);
- Set_Paren_Count_Of_Copy (Target => New_Id, Source => Source);
+ return New_Id : constant Node_Id := Alloc_Node_Id do
+ Node_Offsets.Table (New_Id) := Alloc_Slots (S_Size);
+ Orig_Nodes.Append (New_Id);
+ Copy_Slots (Source, New_Id);
- -- Set extension nodes if required
+ Set_Check_Actuals (New_Id, False);
+ Set_Paren_Count_Of_Copy (Target => New_Id, Source => Source);
- if Has_Extension (Source) then
- for J in 1 .. Num_Extension_Nodes loop
- Nodes.Append (Nodes.Table (Source + J));
- Flags.Append (Flags.Table (Source + J));
- end loop;
- Orig_Nodes.Set_Last (Nodes.Last);
- else
- pragma Assert (Orig_Nodes.Table (Orig_Nodes.Last) = Nodes.Last);
- end if;
+ Allocate_List_Tables (New_Id);
+ Report (Target => New_Id, Source => Source);
- Allocate_List_Tables (Nodes.Last);
- Report (Target => New_Id, Source => Source);
+ Set_In_List (New_Id, False);
+ Set_Link (New_Id, Empty_List_Or_Node);
- Nodes.Table (New_Id).In_List := False;
- Nodes.Table (New_Id).Link := Empty_List_Or_Node;
+ -- If the original is marked as a rewrite insertion, then unmark the
+ -- copy, since we inserted the original, not the copy.
- -- If the original is marked as a rewrite insertion, then unmark the
- -- copy, since we inserted the original, not the copy.
+ Set_Rewrite_Ins (New_Id, False);
- Nodes.Table (New_Id).Rewrite_Ins := False;
- pragma Debug (New_Node_Debugging_Output (New_Id));
+ -- Clear Is_Overloaded since we cannot have semantic interpretations
+ -- of this new node.
- -- Clear Is_Overloaded since we cannot have semantic interpretations
- -- of this new node.
+ if Nkind (Source) in N_Subexpr then
+ Set_Is_Overloaded (New_Id, False);
+ end if;
- if Nkind (Source) in N_Subexpr then
- Set_Is_Overloaded (New_Id, False);
- end if;
+ -- Always clear Has_Aspects, the caller must take care of copying
+ -- aspects if this is required for the particular situation.
- -- Always clear Has_Aspects, the caller must take care of copying
- -- aspects if this is required for the particular situation.
+ Set_Has_Aspects (New_Id, False);
- Set_Has_Aspects (New_Id, False);
+ -- Mark the copy as Ghost depending on the current Ghost region
- -- Mark the copy as Ghost depending on the current Ghost region
+ Mark_New_Ghost_Node (New_Id);
- Mark_New_Ghost_Node (New_Id);
+ New_Node_Debugging_Output (New_Id);
- pragma Assert (New_Id /= Source);
- return New_Id;
+ pragma Assert (New_Id /= Source);
+ end return;
end New_Copy;
----------------
@@ -1342,17 +1664,9 @@ package body Atree is
New_Sloc : Source_Ptr) return Entity_Id
is
pragma Assert (New_Node_Kind in N_Entity);
- New_Id : constant Entity_Id := Allocate_New_Node;
+ New_Id : constant Entity_Id := Allocate_New_Node (New_Node_Kind);
+ pragma Assert (Original_Node (Node_Offsets.Last) = Node_Offsets.Last);
begin
- -- Set extension nodes
-
- for J in 1 .. Num_Extension_Nodes loop
- Nodes.Append (Default_Node_Extension);
- Flags.Append (Default_Flags);
- end loop;
-
- Orig_Nodes.Set_Last (Nodes.Last);
-
-- If this is a node with a real location and we are generating
-- source nodes, then reset Current_Error_Node. This is useful
-- if we bomb during parsing to get a error location for the bomb.
@@ -1361,14 +1675,14 @@ package body Atree is
Current_Error_Node := New_Id;
end if;
- Nodes.Table (New_Id).Nkind := New_Node_Kind;
- Nodes.Table (New_Id).Sloc := New_Sloc;
- pragma Debug (New_Node_Debugging_Output (New_Id));
+ Set_Sloc (New_Id, New_Sloc);
-- Mark the new entity as Ghost depending on the current Ghost region
Mark_New_Ghost_Node (New_Id);
+ New_Node_Debugging_Output (New_Id);
+
return New_Id;
end New_Entity;
@@ -1381,12 +1695,10 @@ package body Atree is
New_Sloc : Source_Ptr) return Node_Id
is
pragma Assert (New_Node_Kind not in N_Entity);
- New_Id : constant Node_Id := Allocate_New_Node;
- pragma Assert (Orig_Nodes.Table (Orig_Nodes.Last) = Nodes.Last);
+ New_Id : constant Node_Id := Allocate_New_Node (New_Node_Kind);
+ pragma Assert (Original_Node (Node_Offsets.Last) = Node_Offsets.Last);
begin
- Nodes.Table (New_Id).Nkind := New_Node_Kind;
- Nodes.Table (New_Id).Sloc := New_Sloc;
- pragma Debug (New_Node_Debugging_Output (New_Id));
+ Set_Sloc (New_Id, New_Sloc);
-- If this is a node with a real location and we are generating source
-- nodes, then reset Current_Error_Node. This is useful if we bomb
@@ -1400,46 +1712,11 @@ package body Atree is
Mark_New_Ghost_Node (New_Id);
+ New_Node_Debugging_Output (New_Id);
+
return New_Id;
end New_Node;
- -------------------------
- -- New_Node_Breakpoint --
- -------------------------
-
- procedure nn is
- begin
- Write_Str ("Watched node ");
- Write_Int (Int (Watch_Node));
- Write_Eol;
- end nn;
-
- -------------------------------
- -- New_Node_Debugging_Output --
- -------------------------------
-
- procedure nnd (N : Node_Id) is
- Node_Is_Watched : constant Boolean := N = Watch_Node;
-
- begin
- if Debug_Flag_N or else Node_Is_Watched then
- Node_Debug_Output ("Node", N);
-
- if Node_Is_Watched then
- New_Node_Breakpoint;
- end if;
- end if;
- end nnd;
-
- -----------
- -- Nkind --
- -----------
-
- function Nkind (N : Node_Id) return Node_Kind is
- begin
- return Nodes.Table (N).Nkind;
- end Nkind;
-
--------
-- No --
--------
@@ -1449,37 +1726,26 @@ package body Atree is
return N = Empty;
end No;
- -----------------------
- -- Node_Debug_Output --
- -----------------------
-
- procedure Node_Debug_Output (Op : String; N : Node_Id) is
- begin
- Write_Str (Op);
-
- if Nkind (N) in N_Entity then
- Write_Str (" entity");
- else
- Write_Str (" node");
- end if;
-
- Write_Str (" Id = ");
- Write_Int (Int (N));
- Write_Str (" ");
- Write_Location (Sloc (N));
- Write_Str (" ");
- Write_Str (Node_Kind'Image (Nkind (N)));
- Write_Eol;
- end Node_Debug_Output;
-
-------------------
-- Nodes_Address --
-------------------
- function Nodes_Address return System.Address is
+ function Node_Offsets_Address return System.Address is
begin
- return Nodes.Table (First_Node_Id)'Address;
- end Nodes_Address;
+ return Node_Offsets.Table (First_Node_Id)'Address;
+ end Node_Offsets_Address;
+
+ function Slots_Address return System.Address is
+ Slot_Byte_Size : constant := 4;
+ pragma Assert (Slot_Byte_Size * 8 = Slot'Size);
+ Extra : constant := Slots_Low_Bound * Slot_Byte_Size;
+ -- Slots does not start at 0, so we need to subtract off the extra
+ -- amount. We are returning Slots.Table (0)'Address, except that
+ -- that component does not exist.
+ use System.Storage_Elements;
+ begin
+ return Slots.Table (Slots_Low_Bound)'Address - Extra;
+ end Slots_Address;
-----------------------------------
-- Approx_Num_Nodes_And_Entities --
@@ -1487,19 +1753,43 @@ package body Atree is
function Approx_Num_Nodes_And_Entities return Nat is
begin
- -- This is an overestimate, because entities take up more space, but
- -- that really doesn't matter; it's not worth subtracting out the
- -- "extra".
-
- return Nat (Nodes.Last - First_Node_Id);
+ return Nat (Node_Offsets.Last - First_Node_Id);
end Approx_Num_Nodes_And_Entities;
+ -----------
+ -- Off_0 --
+ -----------
+
+ function Off_0 (N : Node_Id) return Node_Offset is
+ pragma Debug (Validate_Node (N));
+
+ All_Node_Offsets : Node_Offsets.Table_Type renames
+ Node_Offsets.Table (Node_Offsets.First .. Node_Offsets.Last);
+ begin
+ return All_Node_Offsets (N);
+ end Off_0;
+
+ -----------
+ -- Off_L --
+ -----------
+
+ function Off_L (N : Node_Id) return Node_Offset is
+ pragma Debug (Validate_Node (N));
+
+ All_Node_Offsets : Node_Offsets.Table_Type renames
+ Node_Offsets.Table (Node_Offsets.First .. Node_Offsets.Last);
+ begin
+ return All_Node_Offsets (N) + Size_In_Slots (N) - 1;
+ end Off_L;
+
-------------------
-- Original_Node --
-------------------
function Original_Node (Node : Node_Id) return Node_Id is
begin
+ pragma Debug (Validate_Node (Node));
+
return Orig_Nodes.Table (Node);
end Original_Node;
@@ -1508,19 +1798,11 @@ package body Atree is
-----------------
function Paren_Count (N : Node_Id) return Nat is
- C : Nat := 0;
-
- begin
- pragma Assert (N <= Nodes.Last);
+ pragma Debug (Validate_Node (N));
- if Nodes.Table (N).Pflag1 then
- C := C + 1;
- end if;
-
- if Nodes.Table (N).Pflag2 then
- C := C + 2;
- end if;
+ C : constant Small_Paren_Count_Type := Small_Paren_Count (N);
+ begin
-- Value of 0,1,2 returned as is
if C <= 2 then
@@ -1539,16 +1821,14 @@ package body Atree is
end if;
end Paren_Count;
- ------------
- -- Parent --
- ------------
-
- function Parent (N : Node_Id) return Node_Id is
+ function Parent (N : Node_Or_Entity_Id) return Node_Or_Entity_Id is
begin
+ pragma Assert (Atree.Present (N));
+
if Is_List_Member (N) then
return Parent (List_Containing (N));
else
- return Node_Id (Nodes.Table (N).Link);
+ return Node_Or_Entity_Id (Link (N));
end if;
end Parent;
@@ -1571,112 +1851,26 @@ package body Atree is
end Preserve_Comes_From_Source;
----------------------
- -- Print_Statistics --
+ -- Print_Atree_Info --
----------------------
- procedure Print_Statistics is
- N_Count : constant Natural := Natural (Nodes.Last - First_Node_Id + 1);
- E_Count : Natural := 0;
-
+ procedure Print_Atree_Info (N : Node_Or_Entity_Id) is
+ function Cast is new Unchecked_Conversion (Slot, Int);
begin
- Write_Str ("Number of entities: ");
- Write_Eol;
-
- declare
- function CP_Lt (Op1, Op2 : Natural) return Boolean;
- -- Compare routine for Sort
-
- procedure CP_Move (From : Natural; To : Natural);
- -- Move routine for Sort
+ Write_Int (Int (Size_In_Slots (N)));
+ Write_Str (" slots (");
+ Write_Int (Int (Off_0 (N)));
+ Write_Str (" .. ");
+ Write_Int (Int (Off_L (N)));
+ Write_Str ("):");
- Kind_Count : array (Node_Kind) of Natural := (others => 0);
- -- Array of occurrence count per node kind
-
- Kind_Max : constant Natural := Node_Kind'Pos (N_Unused_At_End) - 1;
- -- The index of the largest (interesting) node kind
-
- Ranking : array (0 .. Kind_Max) of Node_Kind;
- -- Ranking array for node kinds (index 0 is used for the temporary)
-
- package Sorting is new GNAT.Heap_Sort_G (CP_Move, CP_Lt);
-
- function CP_Lt (Op1, Op2 : Natural) return Boolean is
- begin
- return Kind_Count (Ranking (Op2)) < Kind_Count (Ranking (Op1));
- end CP_Lt;
-
- procedure CP_Move (From : Natural; To : Natural) is
- begin
- Ranking (To) := Ranking (From);
- end CP_Move;
-
- begin
- -- Count the number of occurrences of each node kind
-
- for I in First_Node_Id .. Nodes.Last loop
- declare
- Nkind : constant Node_Kind := Nodes.Table (I).Nkind;
- begin
- if not Nodes.Table (I).Is_Extension then
- Kind_Count (Nkind) := Kind_Count (Nkind) + 1;
- end if;
- end;
- end loop;
-
- -- Sort the node kinds by number of occurrences
-
- for N in 1 .. Kind_Max loop
- Ranking (N) := Node_Kind'Val (N);
- end loop;
-
- Sorting.Sort (Kind_Max);
-
- -- Print the list in descending order
-
- for N in 1 .. Kind_Max loop
- declare
- Count : constant Natural := Kind_Count (Ranking (N));
- begin
- if Count > 0 then
- Write_Str (" ");
- Write_Str (Node_Kind'Image (Ranking (N)));
- Write_Str (": ");
- Write_Int (Int (Count));
- Write_Eol;
-
- E_Count := E_Count + Count;
- end if;
- end;
- end loop;
- end;
-
- Write_Str ("Total number of entities: ");
- Write_Int (Int (E_Count));
- Write_Eol;
-
- Write_Str ("Maximum number of nodes per entity: ");
- Write_Int (Int (Num_Extension_Nodes + 1));
- Write_Eol;
-
- Write_Str ("Number of allocated nodes: ");
- Write_Int (Int (N_Count));
- Write_Eol;
-
- Write_Str ("Ratio allocated nodes/entities: ");
- Write_Int (Int (Long_Long_Integer (N_Count) * 100 /
- Long_Long_Integer (E_Count)));
- Write_Str ("/100");
- Write_Eol;
-
- Write_Str ("Size of a node in bytes: ");
- Write_Int (Int (Node_Record'Size) / Storage_Unit);
- Write_Eol;
+ for Off in Off_0 (N) .. Off_L (N) loop
+ Write_Str (" ");
+ Write_Int (Cast (Slots.Table (Off)));
+ end loop;
- Write_Str ("Memory consumption in bytes: ");
- Write_Int (Int (Long_Long_Integer (N_Count) *
- (Node_Record'Size / Storage_Unit)));
Write_Eol;
- end Print_Statistics;
+ end Print_Atree_Info;
-------------------
-- Relocate_Node --
@@ -1706,7 +1900,7 @@ package body Atree is
-- then the relocated node has the same original node.
if Is_Rewrite_Substitution (Source) then
- Orig_Nodes.Table (New_Node) := Orig_Nodes.Table (Source);
+ Set_Original_Node (New_Node, Original_Node (Source));
end if;
return New_Node;
@@ -1717,35 +1911,47 @@ package body Atree is
-------------
procedure Replace (Old_Node, New_Node : Node_Id) is
- Old_Post : constant Boolean := Nodes.Table (Old_Node).Error_Posted;
- Old_HasA : constant Boolean := Nodes.Table (Old_Node).Has_Aspects;
- Old_CFS : constant Boolean := Nodes.Table (Old_Node).Comes_From_Source;
+ Old_Post : constant Boolean := Error_Posted (Old_Node);
+ Old_HasA : constant Boolean := Has_Aspects (Old_Node);
+ Old_CFS : constant Boolean := Comes_From_Source (Old_Node);
+
+ procedure Destroy_New_Node;
+ -- Overwrite New_Node data with junk, for debugging purposes
+
+ procedure Destroy_New_Node is
+ begin
+ Zero_Slots (New_Node);
+ Node_Offsets.Table (New_Node) := Field_Offset'Base'Last;
+ end Destroy_New_Node;
begin
- pragma Assert
- (not Has_Extension (Old_Node)
- and not Has_Extension (New_Node)
- and not Nodes.Table (New_Node).In_List);
+ New_Node_Debugging_Output (Old_Node);
+ New_Node_Debugging_Output (New_Node);
- pragma Debug (New_Node_Debugging_Output (Old_Node));
- pragma Debug (New_Node_Debugging_Output (New_Node));
+ pragma Assert
+ (not Is_Entity (Old_Node)
+ and not Is_Entity (New_Node)
+ and not In_List (New_Node)
+ and Old_Node /= New_Node);
-- Do copy, preserving link and in list status and required flags
Copy_Node (Source => New_Node, Destination => Old_Node);
- Nodes.Table (Old_Node).Comes_From_Source := Old_CFS;
- Nodes.Table (Old_Node).Error_Posted := Old_Post;
- Nodes.Table (Old_Node).Has_Aspects := Old_HasA;
+ Set_Comes_From_Source (Old_Node, Old_CFS);
+ Set_Error_Posted (Old_Node, Old_Post);
+ Set_Has_Aspects (Old_Node, Old_HasA);
-- Fix parents of substituted node, since it has changed identity
Fix_Parents (Ref_Node => New_Node, Fix_Node => Old_Node);
+ pragma Debug (Destroy_New_Node);
+
-- Since we are doing a replace, we assume that the original node
-- is intended to become the new replaced node. The call would be
-- to Rewrite if there were an intention to save the original node.
- Orig_Nodes.Table (Old_Node) := Old_Node;
+ Set_Original_Node (Old_Node, Old_Node);
-- Invoke the reporting procedure (if available)
@@ -1770,24 +1976,22 @@ package body Atree is
-------------
procedure Rewrite (Old_Node, New_Node : Node_Id) is
-
- -- Flags table attributes
-
- Old_CA : constant Boolean := Flags.Table (Old_Node).Check_Actuals;
- Old_Is_IGN : constant Boolean :=
- Flags.Table (Old_Node).Is_Ignored_Ghost_Node;
-
- -- Nodes table attributes
-
+ Old_CA : constant Boolean := Check_Actuals (Old_Node);
+ Old_Is_IGN : constant Boolean := Is_Ignored_Ghost_Node (Old_Node);
Old_Error_Posted : constant Boolean :=
- Nodes.Table (Old_Node).Error_Posted;
+ Error_Posted (Old_Node);
Old_Has_Aspects : constant Boolean :=
- Nodes.Table (Old_Node).Has_Aspects;
+ Has_Aspects (Old_Node);
- Old_Must_Not_Freeze : Boolean;
- Old_Paren_Count : Nat;
+ Old_Must_Not_Freeze : constant Boolean :=
+ (if Nkind (Old_Node) in N_Subexpr then Must_Not_Freeze (Old_Node)
+ else False);
+ Old_Paren_Count : constant Nat :=
+ (if Nkind (Old_Node) in N_Subexpr then Paren_Count (Old_Node) else 0);
-- These fields are preserved in the new node only if the new node and
- -- the old node are both subexpression nodes.
+ -- the old node are both subexpression nodes. We might be changing Nkind
+ -- (Old_Node) from not N_Subexpr to N_Subexpr, so we need a value
+ -- (False/0) even if Old_Noed is not a N_Subexpr.
-- Note: it is a violation of abstraction levels for Must_Not_Freeze
-- to be referenced like this. ???
@@ -1795,21 +1999,13 @@ package body Atree is
Sav_Node : Node_Id;
begin
- pragma Assert
- (not Has_Extension (Old_Node)
- and not Has_Extension (New_Node)
- and not Nodes.Table (New_Node).In_List);
-
- pragma Debug (New_Node_Debugging_Output (Old_Node));
- pragma Debug (New_Node_Debugging_Output (New_Node));
+ New_Node_Debugging_Output (Old_Node);
+ New_Node_Debugging_Output (New_Node);
- if Nkind (Old_Node) in N_Subexpr then
- Old_Must_Not_Freeze := Must_Not_Freeze (Old_Node);
- Old_Paren_Count := Paren_Count (Old_Node);
- else
- Old_Must_Not_Freeze := False;
- Old_Paren_Count := 0;
- end if;
+ pragma Assert
+ (not Is_Entity (Old_Node)
+ and not Is_Entity (New_Node)
+ and not In_List (New_Node));
-- Allocate a new node, to be used to preserve the original contents
-- of the Old_Node, for possible later retrival by Original_Node and
@@ -1817,10 +2013,10 @@ package body Atree is
-- not already rewritten the node, as indicated by an Orig_Nodes entry
-- that does not reference the Old_Node.
- if Orig_Nodes.Table (Old_Node) = Old_Node then
+ if Original_Node (Old_Node) = Old_Node then
Sav_Node := New_Copy (Old_Node);
- Orig_Nodes.Table (Sav_Node) := Sav_Node;
- Orig_Nodes.Table (Old_Node) := Sav_Node;
+ Set_Original_Node (Sav_Node, Sav_Node);
+ Set_Original_Node (Old_Node, Sav_Node);
-- Both the old and new copies of the node will share the same list
-- of aspect specifications if aspect specifications are present.
@@ -1834,11 +2030,11 @@ package body Atree is
-- Copy substitute node into place, preserving old fields as required
Copy_Node (Source => New_Node, Destination => Old_Node);
- Nodes.Table (Old_Node).Error_Posted := Old_Error_Posted;
- Nodes.Table (Old_Node).Has_Aspects := Old_Has_Aspects;
+ Set_Error_Posted (Old_Node, Old_Error_Posted);
+ Set_Has_Aspects (Old_Node, Old_Has_Aspects);
- Flags.Table (Old_Node).Check_Actuals := Old_CA;
- Flags.Table (Old_Node).Is_Ignored_Ghost_Node := Old_Is_IGN;
+ Set_Check_Actuals (Old_Node, Old_CA);
+ Set_Is_Ignored_Ghost_Node (Old_Node, Old_Is_IGN);
if Nkind (New_Node) in N_Subexpr then
Set_Paren_Count (Old_Node, Old_Paren_Count);
@@ -1860,37 +2056,6 @@ package body Atree is
end if;
end Rewrite;
- ------------------
- -- Set_Analyzed --
- ------------------
-
- procedure Set_Analyzed (N : Node_Id; Val : Boolean := True) is
- begin
- pragma Assert (not Locked);
- Nodes.Table (N).Analyzed := Val;
- end Set_Analyzed;
-
- -----------------------
- -- Set_Check_Actuals --
- -----------------------
-
- procedure Set_Check_Actuals (N : Node_Id; Val : Boolean := True) is
- begin
- pragma Assert (not Locked);
- Flags.Table (N).Check_Actuals := Val;
- end Set_Check_Actuals;
-
- ---------------------------
- -- Set_Comes_From_Source --
- ---------------------------
-
- procedure Set_Comes_From_Source (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (N <= Nodes.Last);
- Nodes.Table (N).Comes_From_Source := Val;
- end Set_Comes_From_Source;
-
-----------------------------------
-- Set_Comes_From_Source_Default --
-----------------------------------
@@ -1900,38 +2065,6 @@ package body Atree is
Comes_From_Source_Default := Default;
end Set_Comes_From_Source_Default;
- ---------------
- -- Set_Ekind --
- ---------------
-
- procedure Set_Ekind (E : Entity_Id; Val : Entity_Kind) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (E) in N_Entity);
- Nodes.Table (E + 1).Nkind := E_To_N (Val);
- end Set_Ekind;
-
- ----------------------
- -- Set_Error_Posted --
- ----------------------
-
- procedure Set_Error_Posted (N : Node_Id; Val : Boolean := True) is
- begin
- pragma Assert (not Locked);
- Nodes.Table (N).Error_Posted := Val;
- end Set_Error_Posted;
-
- ---------------------
- -- Set_Has_Aspects --
- ---------------------
-
- procedure Set_Has_Aspects (N : Node_Id; Val : Boolean := True) is
- begin
- pragma Assert (not Locked);
- pragma Assert (N <= Nodes.Last);
- Nodes.Table (N).Has_Aspects := Val;
- end Set_Has_Aspects;
-
--------------------------------------
-- Set_Ignored_Ghost_Recording_Proc --
--------------------------------------
@@ -1944,23 +2077,14 @@ package body Atree is
Ignored_Ghost_Recording_Proc := Proc;
end Set_Ignored_Ghost_Recording_Proc;
- -------------------------------
- -- Set_Is_Ignored_Ghost_Node --
- -------------------------------
-
- procedure Set_Is_Ignored_Ghost_Node (N : Node_Id; Val : Boolean := True) is
- begin
- pragma Assert (not Locked);
- Flags.Table (N).Is_Ignored_Ghost_Node := Val;
- end Set_Is_Ignored_Ghost_Node;
-
-----------------------
-- Set_Original_Node --
-----------------------
procedure Set_Original_Node (N : Node_Id; Val : Node_Id) is
begin
- pragma Assert (not Locked);
+ pragma Debug (Validate_Node_Write (N));
+
Orig_Nodes.Table (N) := Val;
end Set_Original_Node;
@@ -1970,20 +2094,18 @@ package body Atree is
procedure Set_Paren_Count (N : Node_Id; Val : Nat) is
begin
- pragma Assert (not Locked);
+ pragma Debug (Validate_Node_Write (N));
pragma Assert (Nkind (N) in N_Subexpr);
-- Value of 0,1,2 stored as is
if Val <= 2 then
- Nodes.Table (N).Pflag1 := (Val mod 2 /= 0);
- Nodes.Table (N).Pflag2 := (Val = 2);
+ Set_Small_Paren_Count (N, Val);
-- Value of 3 or greater stores 3 in node and makes table entry
else
- Nodes.Table (N).Pflag1 := True;
- Nodes.Table (N).Pflag2 := True;
+ Set_Small_Paren_Count (N, 3);
-- Search for existing table entry
@@ -2006,11 +2128,11 @@ package body Atree is
procedure Set_Paren_Count_Of_Copy (Target, Source : Node_Id) is
begin
- -- We already copied the two Pflags. We need to update the Paren_Counts
- -- table only if greater than 2.
+ -- We already copied the Small_Paren_Count. We need to update the
+ -- Paren_Counts table only if greater than 2.
if Nkind (Source) in N_Subexpr
- and then Paren_Count (Source) > 2
+ and then Small_Paren_Count (Source) = 3
then
Set_Paren_Count (Target, Paren_Count (Source));
end if;
@@ -2022,11 +2144,11 @@ package body Atree is
-- Set_Parent --
----------------
- procedure Set_Parent (N : Node_Id; Val : Node_Id) is
+ procedure Set_Parent (N : Node_Or_Entity_Id; Val : Node_Or_Entity_Id) is
begin
- pragma Assert (not Locked);
- pragma Assert (not Nodes.Table (N).In_List);
- Nodes.Table (N).Link := Union_Id (Val);
+ pragma Assert (Atree.Present (N));
+ pragma Assert (not In_List (N));
+ Set_Link (N, Union_Id (Val));
end Set_Parent;
------------------------
@@ -2039,16 +2161,6 @@ package body Atree is
Reporting_Proc := Proc;
end Set_Reporting_Proc;
- --------------
- -- Set_Sloc --
- --------------
-
- procedure Set_Sloc (N : Node_Id; Val : Source_Ptr) is
- begin
- pragma Assert (not Locked);
- Nodes.Table (N).Sloc := Val;
- end Set_Sloc;
-
------------------------
-- Set_Rewriting_Proc --
------------------------
@@ -2059,91 +2171,75 @@ package body Atree is
Rewriting_Proc := Proc;
end Set_Rewriting_Proc;
- ----------
- -- Sloc --
- ----------
+ function Size_In_Slots_To_Alloc (Kind : Node_Kind) return Slot_Count is
+ begin
+ return
+ (if Kind in N_Entity then Einfo.Entities.Max_Entity_Size
+ else Sinfo.Nodes.Size (Kind));
+ -- Unfortunately, we don't know the Entity_Kind, so we have to use the
+ -- max.
+ end Size_In_Slots_To_Alloc;
- function Sloc (N : Node_Id) return Source_Ptr is
+ function Size_In_Slots_To_Alloc
+ (N : Node_Or_Entity_Id) return Slot_Count is
begin
- return Nodes.Table (N).Sloc;
- end Sloc;
+ return Size_In_Slots_To_Alloc (Nkind (N));
+ end Size_In_Slots_To_Alloc;
+
+ function Size_In_Slots (N : Node_Or_Entity_Id) return Slot_Count is
+ begin
+ pragma Assert (Nkind (N) /= N_Unused_At_Start);
+ return
+ (if Nkind (N) in N_Entity then Einfo.Entities.Max_Entity_Size
+ else Sinfo.Nodes.Size (Nkind (N)));
+ end Size_In_Slots;
-------------------
-- Traverse_Func --
-------------------
function Traverse_Func (Node : Node_Id) return Traverse_Final_Result is
+ pragma Debug (Validate_Node (Node));
- function Traverse_Field
- (Nod : Node_Id;
- Fld : Union_Id;
- FN : Field_Num) return Traverse_Final_Result;
- -- Fld is one of the fields of Nod. If the field points to syntactic
- -- node or list, then this node or list is traversed, and the result is
- -- the result of this traversal. Otherwise a value of True is returned
- -- with no processing. FN is the number of the field (1 .. 5).
+ function Traverse_Field (Fld : Union_Id) return Traverse_Final_Result;
+ -- Fld is one of the Traversed fields of Nod, which is necessarily a
+ -- Node_Id or List_Id. It is traversed, and the result is the result of
+ -- this traversal.
--------------------
-- Traverse_Field --
--------------------
- function Traverse_Field
- (Nod : Node_Id;
- Fld : Union_Id;
- FN : Field_Num) return Traverse_Final_Result
- is
+ function Traverse_Field (Fld : Union_Id) return Traverse_Final_Result is
begin
- if Fld = Union_Id (Empty) then
- return OK;
-
- -- Descendant is a node
+ if Fld /= Union_Id (Empty) then
- elsif Fld in Node_Range then
+ -- Descendant is a node
- -- Traverse descendant that is syntactic subtree node
-
- if Is_Syntactic_Field (Nkind (Nod), FN) then
+ if Fld in Node_Range then
return Traverse_Func (Node_Id (Fld));
- -- Node that is not a syntactic subtree
-
- else
- return OK;
- end if;
-
- -- Descendant is a list
+ -- Descendant is a list
- elsif Fld in List_Range then
-
- -- Traverse descendant that is a syntactic subtree list
-
- if Is_Syntactic_Field (Nkind (Nod), FN) then
+ elsif Fld in List_Range then
declare
Elmt : Node_Id := First (List_Id (Fld));
-
begin
while Present (Elmt) loop
if Traverse_Func (Elmt) = Abandon then
return Abandon;
- else
- Next (Elmt);
end if;
- end loop;
- return OK;
+ Next (Elmt);
+ end loop;
end;
- -- List that is not a syntactic subtree
-
else
- return OK;
+ raise Program_Error;
end if;
-
- -- Field was not a node or a list
-
- else
- return OK;
end if;
+
+ return OK;
end Traverse_Field;
Cur_Node : Node_Id := Node;
@@ -2151,12 +2247,19 @@ package body Atree is
-- Start of processing for Traverse_Func
begin
- -- We walk Field2 last, and if it is a node, we eliminate the tail
- -- recursion by jumping back to this label. This is because Field2 is
- -- where the Left_Opnd field of N_Op_Concat is stored, and in practice
- -- concatenations are sometimes deeply nested, as in X1&X2&...&XN. This
- -- trick prevents us from running out of memory in that case. We don't
- -- bother eliminating the tail recursion if Field2 is a list.
+ -- If the last field is a node, we eliminate the tail recursion by
+ -- jumping back to this label. This is because concatenations are
+ -- sometimes deeply nested, as in X1&X2&...&Xn. Gen_IL ensures that the
+ -- Left_Opnd field of N_Op_Concat comes last in Traversed_Fields, so the
+ -- tail recursion is eliminated in that case. This trick prevents us
+ -- from running out of stack memory in that case. We don't bother
+ -- eliminating the tail recursion if the last field is a list.
+ --
+ -- (To check, look in the body of Sinfo.Nodes, search for the Left_Opnd
+ -- getter, and note the offset of Left_Opnd. Then look in the spec of
+ -- Sinfo.Nodes, look at the Traversed_Fields table, search for the
+ -- N_Op_Concat component. The offset of Left_Opnd should be the last
+ -- component before the No_Field_Offset sentinels.)
<<Tail_Recurse>>
@@ -2174,30 +2277,51 @@ package body Atree is
Cur_Node := Original_Node (Cur_Node);
end case;
- if Traverse_Field (Cur_Node, Field1 (Cur_Node), 1) = Abandon
- or else -- skip Field2 here
- Traverse_Field (Cur_Node, Field3 (Cur_Node), 3) = Abandon
- or else
- Traverse_Field (Cur_Node, Field4 (Cur_Node), 4) = Abandon
- or else
- Traverse_Field (Cur_Node, Field5 (Cur_Node), 5) = Abandon
- then
- return Abandon;
- end if;
+ -- Check for empty Traversed_Fields before entering loop below, so the
+ -- tail recursive step won't go past the end.
+
+ declare
+ Cur_Field : Offset_Array_Index := Traversed_Offset_Array'First;
+ Offsets : Traversed_Offset_Array renames
+ Traversed_Fields (Nkind (Cur_Node));
- if Field2 (Cur_Node) not in Node_Range then
- return Traverse_Field (Cur_Node, Field2 (Cur_Node), 2);
+ begin
+ if Offsets (Traversed_Offset_Array'First) /= No_Field_Offset then
+ while Offsets (Cur_Field + 1) /= No_Field_Offset loop
+ declare
+ F : constant Union_Id :=
+ Get_Node_Field_Union (Cur_Node, Offsets (Cur_Field));
- elsif Is_Syntactic_Field (Nkind (Cur_Node), 2)
- and then Field2 (Cur_Node) /= Empty_List_Or_Node
- then
- -- Here is the tail recursion step, we reset Cur_Node and jump back
- -- to the start of the procedure, which has the same semantic effect
- -- as a call.
+ begin
+ if Traverse_Field (F) = Abandon then
+ return Abandon;
+ end if;
+ end;
- Cur_Node := Node_Id (Field2 (Cur_Node));
- goto Tail_Recurse;
- end if;
+ Cur_Field := Cur_Field + 1;
+ end loop;
+
+ declare
+ F : constant Union_Id :=
+ Get_Node_Field_Union (Cur_Node, Offsets (Cur_Field));
+
+ begin
+ if F not in Node_Range then
+ if Traverse_Field (F) = Abandon then
+ return Abandon;
+ end if;
+
+ elsif F /= Empty_List_Or_Node then
+ -- Here is the tail recursion step, we reset Cur_Node and
+ -- jump back to the start of the procedure, which has the
+ -- same semantic effect as a call.
+
+ Cur_Node := Node_Id (F);
+ goto Tail_Recurse;
+ end if;
+ end;
+ end if;
+ end;
return OK;
end Traverse_Func;
@@ -2214,6573 +2338,12 @@ package body Atree is
Discard := Traverse (Node);
end Traverse_Proc;
- ------------------------------
- -- Unchecked Access Package --
- ------------------------------
-
- package body Unchecked_Access is
-
- function Field1 (N : Node_Id) return Union_Id is
- begin
- pragma Assert (N <= Nodes.Last);
- return Nodes.Table (N).Field1;
- end Field1;
-
- function Field2 (N : Node_Id) return Union_Id is
- begin
- pragma Assert (N <= Nodes.Last);
- return Nodes.Table (N).Field2;
- end Field2;
-
- function Field3 (N : Node_Id) return Union_Id is
- begin
- pragma Assert (N <= Nodes.Last);
- return Nodes.Table (N).Field3;
- end Field3;
-
- function Field4 (N : Node_Id) return Union_Id is
- begin
- pragma Assert (N <= Nodes.Last);
- return Nodes.Table (N).Field4;
- end Field4;
-
- function Field5 (N : Node_Id) return Union_Id is
- begin
- pragma Assert (N <= Nodes.Last);
- return Nodes.Table (N).Field5;
- end Field5;
-
- function Field6 (N : Node_Id) return Union_Id is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return Nodes.Table (N + 1).Field6;
- end Field6;
-
- function Field7 (N : Node_Id) return Union_Id is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return Nodes.Table (N + 1).Field7;
- end Field7;
-
- function Field8 (N : Node_Id) return Union_Id is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return Nodes.Table (N + 1).Field8;
- end Field8;
-
- function Field9 (N : Node_Id) return Union_Id is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return Nodes.Table (N + 1).Field9;
- end Field9;
-
- function Field10 (N : Node_Id) return Union_Id is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return Nodes.Table (N + 1).Field10;
- end Field10;
-
- function Field11 (N : Node_Id) return Union_Id is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return Nodes.Table (N + 1).Field11;
- end Field11;
-
- function Field12 (N : Node_Id) return Union_Id is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return Nodes.Table (N + 1).Field12;
- end Field12;
-
- function Field13 (N : Node_Id) return Union_Id is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return Nodes.Table (N + 2).Field6;
- end Field13;
-
- function Field14 (N : Node_Id) return Union_Id is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return Nodes.Table (N + 2).Field7;
- end Field14;
-
- function Field15 (N : Node_Id) return Union_Id is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return Nodes.Table (N + 2).Field8;
- end Field15;
-
- function Field16 (N : Node_Id) return Union_Id is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return Nodes.Table (N + 2).Field9;
- end Field16;
-
- function Field17 (N : Node_Id) return Union_Id is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return Nodes.Table (N + 2).Field10;
- end Field17;
-
- function Field18 (N : Node_Id) return Union_Id is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return Nodes.Table (N + 2).Field11;
- end Field18;
-
- function Field19 (N : Node_Id) return Union_Id is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return Nodes.Table (N + 3).Field6;
- end Field19;
-
- function Field20 (N : Node_Id) return Union_Id is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return Nodes.Table (N + 3).Field7;
- end Field20;
-
- function Field21 (N : Node_Id) return Union_Id is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return Nodes.Table (N + 3).Field8;
- end Field21;
-
- function Field22 (N : Node_Id) return Union_Id is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return Nodes.Table (N + 3).Field9;
- end Field22;
-
- function Field23 (N : Node_Id) return Union_Id is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return Nodes.Table (N + 3).Field10;
- end Field23;
-
- function Field24 (N : Node_Id) return Union_Id is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return Nodes.Table (N + 4).Field6;
- end Field24;
-
- function Field25 (N : Node_Id) return Union_Id is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return Nodes.Table (N + 4).Field7;
- end Field25;
-
- function Field26 (N : Node_Id) return Union_Id is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return Nodes.Table (N + 4).Field8;
- end Field26;
-
- function Field27 (N : Node_Id) return Union_Id is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return Nodes.Table (N + 4).Field9;
- end Field27;
-
- function Field28 (N : Node_Id) return Union_Id is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return Nodes.Table (N + 4).Field10;
- end Field28;
-
- function Field29 (N : Node_Id) return Union_Id is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return Nodes.Table (N + 4).Field11;
- end Field29;
-
- function Field30 (N : Node_Id) return Union_Id is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return Nodes.Table (N + 5).Field6;
- end Field30;
-
- function Field31 (N : Node_Id) return Union_Id is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return Nodes.Table (N + 5).Field7;
- end Field31;
-
- function Field32 (N : Node_Id) return Union_Id is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return Nodes.Table (N + 5).Field8;
- end Field32;
-
- function Field33 (N : Node_Id) return Union_Id is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return Nodes.Table (N + 5).Field9;
- end Field33;
-
- function Field34 (N : Node_Id) return Union_Id is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return Nodes.Table (N + 5).Field10;
- end Field34;
-
- function Field35 (N : Node_Id) return Union_Id is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return Nodes.Table (N + 5).Field11;
- end Field35;
-
- function Field36 (N : Node_Id) return Union_Id is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return Nodes.Table (N + 6).Field6;
- end Field36;
-
- function Field37 (N : Node_Id) return Union_Id is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return Nodes.Table (N + 6).Field7;
- end Field37;
-
- function Field38 (N : Node_Id) return Union_Id is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return Nodes.Table (N + 6).Field8;
- end Field38;
-
- function Field39 (N : Node_Id) return Union_Id is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return Nodes.Table (N + 6).Field9;
- end Field39;
-
- function Field40 (N : Node_Id) return Union_Id is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return Nodes.Table (N + 6).Field10;
- end Field40;
-
- function Field41 (N : Node_Id) return Union_Id is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return Nodes.Table (N + 6).Field11;
- end Field41;
-
- function Node1 (N : Node_Id) return Node_Id is
- begin
- pragma Assert (N <= Nodes.Last);
- return Node_Id (Nodes.Table (N).Field1);
- end Node1;
-
- function Node2 (N : Node_Id) return Node_Id is
- begin
- pragma Assert (N <= Nodes.Last);
- return Node_Id (Nodes.Table (N).Field2);
- end Node2;
-
- function Node3 (N : Node_Id) return Node_Id is
- begin
- pragma Assert (N <= Nodes.Last);
- return Node_Id (Nodes.Table (N).Field3);
- end Node3;
-
- function Node4 (N : Node_Id) return Node_Id is
- begin
- pragma Assert (N <= Nodes.Last);
- return Node_Id (Nodes.Table (N).Field4);
- end Node4;
-
- function Node5 (N : Node_Id) return Node_Id is
- begin
- pragma Assert (N <= Nodes.Last);
- return Node_Id (Nodes.Table (N).Field5);
- end Node5;
-
- function Node6 (N : Node_Id) return Node_Id is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return Node_Id (Nodes.Table (N + 1).Field6);
- end Node6;
-
- function Node7 (N : Node_Id) return Node_Id is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return Node_Id (Nodes.Table (N + 1).Field7);
- end Node7;
-
- function Node8 (N : Node_Id) return Node_Id is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return Node_Id (Nodes.Table (N + 1).Field8);
- end Node8;
-
- function Node9 (N : Node_Id) return Node_Id is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return Node_Id (Nodes.Table (N + 1).Field9);
- end Node9;
-
- function Node10 (N : Node_Id) return Node_Id is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return Node_Id (Nodes.Table (N + 1).Field10);
- end Node10;
-
- function Node11 (N : Node_Id) return Node_Id is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return Node_Id (Nodes.Table (N + 1).Field11);
- end Node11;
-
- function Node12 (N : Node_Id) return Node_Id is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return Node_Id (Nodes.Table (N + 1).Field12);
- end Node12;
-
- function Node13 (N : Node_Id) return Node_Id is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return Node_Id (Nodes.Table (N + 2).Field6);
- end Node13;
-
- function Node14 (N : Node_Id) return Node_Id is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return Node_Id (Nodes.Table (N + 2).Field7);
- end Node14;
-
- function Node15 (N : Node_Id) return Node_Id is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return Node_Id (Nodes.Table (N + 2).Field8);
- end Node15;
-
- function Node16 (N : Node_Id) return Node_Id is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return Node_Id (Nodes.Table (N + 2).Field9);
- end Node16;
-
- function Node17 (N : Node_Id) return Node_Id is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return Node_Id (Nodes.Table (N + 2).Field10);
- end Node17;
-
- function Node18 (N : Node_Id) return Node_Id is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return Node_Id (Nodes.Table (N + 2).Field11);
- end Node18;
-
- function Node19 (N : Node_Id) return Node_Id is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return Node_Id (Nodes.Table (N + 3).Field6);
- end Node19;
-
- function Node20 (N : Node_Id) return Node_Id is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return Node_Id (Nodes.Table (N + 3).Field7);
- end Node20;
-
- function Node21 (N : Node_Id) return Node_Id is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return Node_Id (Nodes.Table (N + 3).Field8);
- end Node21;
-
- function Node22 (N : Node_Id) return Node_Id is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return Node_Id (Nodes.Table (N + 3).Field9);
- end Node22;
-
- function Node23 (N : Node_Id) return Node_Id is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return Node_Id (Nodes.Table (N + 3).Field10);
- end Node23;
-
- function Node24 (N : Node_Id) return Node_Id is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return Node_Id (Nodes.Table (N + 4).Field6);
- end Node24;
-
- function Node25 (N : Node_Id) return Node_Id is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return Node_Id (Nodes.Table (N + 4).Field7);
- end Node25;
-
- function Node26 (N : Node_Id) return Node_Id is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return Node_Id (Nodes.Table (N + 4).Field8);
- end Node26;
-
- function Node27 (N : Node_Id) return Node_Id is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return Node_Id (Nodes.Table (N + 4).Field9);
- end Node27;
-
- function Node28 (N : Node_Id) return Node_Id is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return Node_Id (Nodes.Table (N + 4).Field10);
- end Node28;
-
- function Node29 (N : Node_Id) return Node_Id is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return Node_Id (Nodes.Table (N + 4).Field11);
- end Node29;
-
- function Node30 (N : Node_Id) return Node_Id is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return Node_Id (Nodes.Table (N + 5).Field6);
- end Node30;
-
- function Node31 (N : Node_Id) return Node_Id is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return Node_Id (Nodes.Table (N + 5).Field7);
- end Node31;
-
- function Node32 (N : Node_Id) return Node_Id is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return Node_Id (Nodes.Table (N + 5).Field8);
- end Node32;
-
- function Node33 (N : Node_Id) return Node_Id is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return Node_Id (Nodes.Table (N + 5).Field9);
- end Node33;
-
- function Node34 (N : Node_Id) return Node_Id is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return Node_Id (Nodes.Table (N + 5).Field10);
- end Node34;
-
- function Node35 (N : Node_Id) return Node_Id is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return Node_Id (Nodes.Table (N + 5).Field11);
- end Node35;
-
- function Node36 (N : Node_Id) return Node_Id is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return Node_Id (Nodes.Table (N + 6).Field6);
- end Node36;
-
- function Node37 (N : Node_Id) return Node_Id is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return Node_Id (Nodes.Table (N + 6).Field7);
- end Node37;
-
- function Node38 (N : Node_Id) return Node_Id is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return Node_Id (Nodes.Table (N + 6).Field8);
- end Node38;
-
- function Node39 (N : Node_Id) return Node_Id is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return Node_Id (Nodes.Table (N + 6).Field9);
- end Node39;
-
- function Node40 (N : Node_Id) return Node_Id is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return Node_Id (Nodes.Table (N + 6).Field10);
- end Node40;
-
- function Node41 (N : Node_Id) return Node_Id is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return Node_Id (Nodes.Table (N + 6).Field11);
- end Node41;
-
- function List1 (N : Node_Id) return List_Id is
- begin
- pragma Assert (N <= Nodes.Last);
- return List_Id (Nodes.Table (N).Field1);
- end List1;
-
- function List2 (N : Node_Id) return List_Id is
- begin
- pragma Assert (N <= Nodes.Last);
- return List_Id (Nodes.Table (N).Field2);
- end List2;
-
- function List3 (N : Node_Id) return List_Id is
- begin
- pragma Assert (N <= Nodes.Last);
- return List_Id (Nodes.Table (N).Field3);
- end List3;
-
- function List4 (N : Node_Id) return List_Id is
- begin
- pragma Assert (N <= Nodes.Last);
- return List_Id (Nodes.Table (N).Field4);
- end List4;
-
- function List5 (N : Node_Id) return List_Id is
- begin
- pragma Assert (N <= Nodes.Last);
- return List_Id (Nodes.Table (N).Field5);
- end List5;
-
- function List10 (N : Node_Id) return List_Id is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return List_Id (Nodes.Table (N + 1).Field10);
- end List10;
-
- function List14 (N : Node_Id) return List_Id is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return List_Id (Nodes.Table (N + 2).Field7);
- end List14;
-
- function List25 (N : Node_Id) return List_Id is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return List_Id (Nodes.Table (N + 4).Field7);
- end List25;
-
- function List38 (N : Node_Id) return List_Id is
- begin
- return List_Id (Nodes.Table (N + 6).Field8);
- end List38;
-
- function List39 (N : Node_Id) return List_Id is
- begin
- return List_Id (Nodes.Table (N + 6).Field9);
- end List39;
-
- function Elist1 (N : Node_Id) return Elist_Id is
- pragma Assert (N <= Nodes.Last);
- Value : constant Union_Id := Nodes.Table (N).Field1;
- begin
- if Value = 0 then
- return No_Elist;
- else
- return Elist_Id (Value);
- end if;
- end Elist1;
-
- function Elist2 (N : Node_Id) return Elist_Id is
- pragma Assert (N <= Nodes.Last);
- Value : constant Union_Id := Nodes.Table (N).Field2;
- begin
- if Value = 0 then
- return No_Elist;
- else
- return Elist_Id (Value);
- end if;
- end Elist2;
-
- function Elist3 (N : Node_Id) return Elist_Id is
- pragma Assert (N <= Nodes.Last);
- Value : constant Union_Id := Nodes.Table (N).Field3;
- begin
- if Value = 0 then
- return No_Elist;
- else
- return Elist_Id (Value);
- end if;
- end Elist3;
-
- function Elist4 (N : Node_Id) return Elist_Id is
- pragma Assert (N <= Nodes.Last);
- Value : constant Union_Id := Nodes.Table (N).Field4;
- begin
- if Value = 0 then
- return No_Elist;
- else
- return Elist_Id (Value);
- end if;
- end Elist4;
-
- function Elist5 (N : Node_Id) return Elist_Id is
- pragma Assert (N <= Nodes.Last);
- Value : constant Union_Id := Nodes.Table (N).Field5;
- begin
- if Value = 0 then
- return No_Elist;
- else
- return Elist_Id (Value);
- end if;
- end Elist5;
-
- function Elist8 (N : Node_Id) return Elist_Id is
- pragma Assert (Nkind (N) in N_Entity);
- Value : constant Union_Id := Nodes.Table (N + 1).Field8;
- begin
- if Value = 0 then
- return No_Elist;
- else
- return Elist_Id (Value);
- end if;
- end Elist8;
-
- function Elist9 (N : Node_Id) return Elist_Id is
- pragma Assert (Nkind (N) in N_Entity);
- Value : constant Union_Id := Nodes.Table (N + 1).Field9;
- begin
- if Value = 0 then
- return No_Elist;
- else
- return Elist_Id (Value);
- end if;
- end Elist9;
-
- function Elist10 (N : Node_Id) return Elist_Id is
- pragma Assert (Nkind (N) in N_Entity);
- Value : constant Union_Id := Nodes.Table (N + 1).Field10;
- begin
- if Value = 0 then
- return No_Elist;
- else
- return Elist_Id (Value);
- end if;
- end Elist10;
-
- function Elist11 (N : Node_Id) return Elist_Id is
- pragma Assert (Nkind (N) in N_Entity);
- Value : constant Union_Id := Nodes.Table (N + 1).Field11;
- begin
- if Value = 0 then
- return No_Elist;
- else
- return Elist_Id (Value);
- end if;
- end Elist11;
-
- function Elist13 (N : Node_Id) return Elist_Id is
- pragma Assert (Nkind (N) in N_Entity);
- Value : constant Union_Id := Nodes.Table (N + 2).Field6;
- begin
- if Value = 0 then
- return No_Elist;
- else
- return Elist_Id (Value);
- end if;
- end Elist13;
-
- function Elist15 (N : Node_Id) return Elist_Id is
- pragma Assert (Nkind (N) in N_Entity);
- Value : constant Union_Id := Nodes.Table (N + 2).Field8;
- begin
- if Value = 0 then
- return No_Elist;
- else
- return Elist_Id (Value);
- end if;
- end Elist15;
-
- function Elist16 (N : Node_Id) return Elist_Id is
- pragma Assert (Nkind (N) in N_Entity);
- Value : constant Union_Id := Nodes.Table (N + 2).Field9;
- begin
- if Value = 0 then
- return No_Elist;
- else
- return Elist_Id (Value);
- end if;
- end Elist16;
-
- function Elist18 (N : Node_Id) return Elist_Id is
- pragma Assert (Nkind (N) in N_Entity);
- Value : constant Union_Id := Nodes.Table (N + 2).Field11;
- begin
- if Value = 0 then
- return No_Elist;
- else
- return Elist_Id (Value);
- end if;
- end Elist18;
-
- function Elist21 (N : Node_Id) return Elist_Id is
- pragma Assert (Nkind (N) in N_Entity);
- Value : constant Union_Id := Nodes.Table (N + 3).Field8;
- begin
- if Value = 0 then
- return No_Elist;
- else
- return Elist_Id (Value);
- end if;
- end Elist21;
-
- function Elist23 (N : Node_Id) return Elist_Id is
- pragma Assert (Nkind (N) in N_Entity);
- Value : constant Union_Id := Nodes.Table (N + 3).Field10;
- begin
- if Value = 0 then
- return No_Elist;
- else
- return Elist_Id (Value);
- end if;
- end Elist23;
-
- function Elist24 (N : Node_Id) return Elist_Id is
- pragma Assert (Nkind (N) in N_Entity);
- Value : constant Union_Id := Nodes.Table (N + 4).Field6;
- begin
- if Value = 0 then
- return No_Elist;
- else
- return Elist_Id (Value);
- end if;
- end Elist24;
-
- function Elist25 (N : Node_Id) return Elist_Id is
- pragma Assert (Nkind (N) in N_Entity);
- Value : constant Union_Id := Nodes.Table (N + 4).Field7;
- begin
- if Value = 0 then
- return No_Elist;
- else
- return Elist_Id (Value);
- end if;
- end Elist25;
-
- function Elist26 (N : Node_Id) return Elist_Id is
- pragma Assert (Nkind (N) in N_Entity);
- Value : constant Union_Id := Nodes.Table (N + 4).Field8;
- begin
- if Value = 0 then
- return No_Elist;
- else
- return Elist_Id (Value);
- end if;
- end Elist26;
-
- function Elist29 (N : Node_Id) return Elist_Id is
- pragma Assert (Nkind (N) in N_Entity);
- Value : constant Union_Id := Nodes.Table (N + 4).Field11;
- begin
- if Value = 0 then
- return No_Elist;
- else
- return Elist_Id (Value);
- end if;
- end Elist29;
-
- function Elist30 (N : Node_Id) return Elist_Id is
- pragma Assert (Nkind (N) in N_Entity);
- Value : constant Union_Id := Nodes.Table (N + 5).Field6;
- begin
- if Value = 0 then
- return No_Elist;
- else
- return Elist_Id (Value);
- end if;
- end Elist30;
-
- function Elist36 (N : Node_Id) return Elist_Id is
- pragma Assert (Nkind (N) in N_Entity);
- Value : constant Union_Id := Nodes.Table (N + 6).Field6;
- begin
- if Value = 0 then
- return No_Elist;
- else
- return Elist_Id (Value);
- end if;
- end Elist36;
-
- function Name1 (N : Node_Id) return Name_Id is
- begin
- pragma Assert (N <= Nodes.Last);
- return Name_Id (Nodes.Table (N).Field1);
- end Name1;
-
- function Name2 (N : Node_Id) return Name_Id is
- begin
- pragma Assert (N <= Nodes.Last);
- return Name_Id (Nodes.Table (N).Field2);
- end Name2;
-
- function Str3 (N : Node_Id) return String_Id is
- begin
- pragma Assert (N <= Nodes.Last);
- return String_Id (Nodes.Table (N).Field3);
- end Str3;
-
- function Uint2 (N : Node_Id) return Uint is
- pragma Assert (N <= Nodes.Last);
- U : constant Union_Id := Nodes.Table (N).Field2;
- begin
- if U = 0 then
- return Uint_0;
- else
- return From_Union (U);
- end if;
- end Uint2;
-
- function Uint3 (N : Node_Id) return Uint is
- pragma Assert (N <= Nodes.Last);
- U : constant Union_Id := Nodes.Table (N).Field3;
- begin
- if U = 0 then
- return Uint_0;
- else
- return From_Union (U);
- end if;
- end Uint3;
-
- function Uint4 (N : Node_Id) return Uint is
- pragma Assert (N <= Nodes.Last);
- U : constant Union_Id := Nodes.Table (N).Field4;
- begin
- if U = 0 then
- return Uint_0;
- else
- return From_Union (U);
- end if;
- end Uint4;
-
- function Uint5 (N : Node_Id) return Uint is
- pragma Assert (N <= Nodes.Last);
- U : constant Union_Id := Nodes.Table (N).Field5;
- begin
- if U = 0 then
- return Uint_0;
- else
- return From_Union (U);
- end if;
- end Uint5;
-
- function Uint8 (N : Node_Id) return Uint is
- pragma Assert (Nkind (N) in N_Entity);
- U : constant Union_Id := Nodes.Table (N + 1).Field8;
- begin
- if U = 0 then
- return Uint_0;
- else
- return From_Union (U);
- end if;
- end Uint8;
-
- function Uint9 (N : Node_Id) return Uint is
- pragma Assert (Nkind (N) in N_Entity);
- U : constant Union_Id := Nodes.Table (N + 1).Field9;
- begin
- if U = 0 then
- return Uint_0;
- else
- return From_Union (U);
- end if;
- end Uint9;
-
- function Uint10 (N : Node_Id) return Uint is
- pragma Assert (Nkind (N) in N_Entity);
- U : constant Union_Id := Nodes.Table (N + 1).Field10;
- begin
- if U = 0 then
- return Uint_0;
- else
- return From_Union (U);
- end if;
- end Uint10;
-
- function Uint11 (N : Node_Id) return Uint is
- pragma Assert (Nkind (N) in N_Entity);
- U : constant Union_Id := Nodes.Table (N + 1).Field11;
- begin
- if U = 0 then
- return Uint_0;
- else
- return From_Union (U);
- end if;
- end Uint11;
-
- function Uint12 (N : Node_Id) return Uint is
- pragma Assert (Nkind (N) in N_Entity);
- U : constant Union_Id := Nodes.Table (N + 1).Field12;
- begin
- if U = 0 then
- return Uint_0;
- else
- return From_Union (U);
- end if;
- end Uint12;
-
- function Uint13 (N : Node_Id) return Uint is
- pragma Assert (Nkind (N) in N_Entity);
- U : constant Union_Id := Nodes.Table (N + 2).Field6;
- begin
- if U = 0 then
- return Uint_0;
- else
- return From_Union (U);
- end if;
- end Uint13;
-
- function Uint14 (N : Node_Id) return Uint is
- pragma Assert (Nkind (N) in N_Entity);
- U : constant Union_Id := Nodes.Table (N + 2).Field7;
- begin
- if U = 0 then
- return Uint_0;
- else
- return From_Union (U);
- end if;
- end Uint14;
-
- function Uint15 (N : Node_Id) return Uint is
- pragma Assert (Nkind (N) in N_Entity);
- U : constant Union_Id := Nodes.Table (N + 2).Field8;
- begin
- if U = 0 then
- return Uint_0;
- else
- return From_Union (U);
- end if;
- end Uint15;
-
- function Uint16 (N : Node_Id) return Uint is
- pragma Assert (Nkind (N) in N_Entity);
- U : constant Union_Id := Nodes.Table (N + 2).Field9;
- begin
- if U = 0 then
- return Uint_0;
- else
- return From_Union (U);
- end if;
- end Uint16;
-
- function Uint17 (N : Node_Id) return Uint is
- pragma Assert (Nkind (N) in N_Entity);
- U : constant Union_Id := Nodes.Table (N + 2).Field10;
- begin
- if U = 0 then
- return Uint_0;
- else
- return From_Union (U);
- end if;
- end Uint17;
-
- function Uint22 (N : Node_Id) return Uint is
- pragma Assert (Nkind (N) in N_Entity);
- U : constant Union_Id := Nodes.Table (N + 3).Field9;
- begin
- if U = 0 then
- return Uint_0;
- else
- return From_Union (U);
- end if;
- end Uint22;
-
- function Uint24 (N : Node_Id) return Uint is
- pragma Assert (Nkind (N) in N_Entity);
- U : constant Union_Id := Nodes.Table (N + 4).Field6;
- begin
- if U = 0 then
- return Uint_0;
- else
- return From_Union (U);
- end if;
- end Uint24;
-
- function Ureal3 (N : Node_Id) return Ureal is
- begin
- pragma Assert (N <= Nodes.Last);
- return From_Union (Nodes.Table (N).Field3);
- end Ureal3;
-
- function Ureal18 (N : Node_Id) return Ureal is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return From_Union (Nodes.Table (N + 2).Field11);
- end Ureal18;
-
- function Ureal21 (N : Node_Id) return Ureal is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return From_Union (Nodes.Table (N + 3).Field8);
- end Ureal21;
-
- function Flag0 (N : Node_Id) return Boolean is
- begin
- pragma Assert (N <= Nodes.Last);
- return Flags.Table (N).Flag0;
- end Flag0;
-
- function Flag1 (N : Node_Id) return Boolean is
- begin
- pragma Assert (N <= Nodes.Last);
- return Flags.Table (N).Flag1;
- end Flag1;
-
- function Flag2 (N : Node_Id) return Boolean is
- begin
- pragma Assert (N <= Nodes.Last);
- return Flags.Table (N).Flag2;
- end Flag2;
-
- function Flag3 (N : Node_Id) return Boolean is
- begin
- pragma Assert (N <= Nodes.Last);
- return Flags.Table (N).Flag3;
- end Flag3;
-
- function Flag4 (N : Node_Id) return Boolean is
- begin
- pragma Assert (N <= Nodes.Last);
- return Nodes.Table (N).Flag4;
- end Flag4;
-
- function Flag5 (N : Node_Id) return Boolean is
- begin
- pragma Assert (N <= Nodes.Last);
- return Nodes.Table (N).Flag5;
- end Flag5;
-
- function Flag6 (N : Node_Id) return Boolean is
- begin
- pragma Assert (N <= Nodes.Last);
- return Nodes.Table (N).Flag6;
- end Flag6;
-
- function Flag7 (N : Node_Id) return Boolean is
- begin
- pragma Assert (N <= Nodes.Last);
- return Nodes.Table (N).Flag7;
- end Flag7;
-
- function Flag8 (N : Node_Id) return Boolean is
- begin
- pragma Assert (N <= Nodes.Last);
- return Nodes.Table (N).Flag8;
- end Flag8;
-
- function Flag9 (N : Node_Id) return Boolean is
- begin
- pragma Assert (N <= Nodes.Last);
- return Nodes.Table (N).Flag9;
- end Flag9;
-
- function Flag10 (N : Node_Id) return Boolean is
- begin
- pragma Assert (N <= Nodes.Last);
- return Nodes.Table (N).Flag10;
- end Flag10;
-
- function Flag11 (N : Node_Id) return Boolean is
- begin
- pragma Assert (N <= Nodes.Last);
- return Nodes.Table (N).Flag11;
- end Flag11;
-
- function Flag12 (N : Node_Id) return Boolean is
- begin
- pragma Assert (N <= Nodes.Last);
- return Nodes.Table (N).Flag12;
- end Flag12;
-
- function Flag13 (N : Node_Id) return Boolean is
- begin
- pragma Assert (N <= Nodes.Last);
- return Nodes.Table (N).Flag13;
- end Flag13;
-
- function Flag14 (N : Node_Id) return Boolean is
- begin
- pragma Assert (N <= Nodes.Last);
- return Nodes.Table (N).Flag14;
- end Flag14;
-
- function Flag15 (N : Node_Id) return Boolean is
- begin
- pragma Assert (N <= Nodes.Last);
- return Nodes.Table (N).Flag15;
- end Flag15;
-
- function Flag16 (N : Node_Id) return Boolean is
- begin
- pragma Assert (N <= Nodes.Last);
- return Nodes.Table (N).Flag16;
- end Flag16;
-
- function Flag17 (N : Node_Id) return Boolean is
- begin
- pragma Assert (N <= Nodes.Last);
- return Nodes.Table (N).Flag17;
- end Flag17;
-
- function Flag18 (N : Node_Id) return Boolean is
- begin
- pragma Assert (N <= Nodes.Last);
- return Nodes.Table (N).Flag18;
- end Flag18;
-
- function Flag19 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return Nodes.Table (N + 1).In_List;
- end Flag19;
-
- function Flag20 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return Nodes.Table (N + 1).Has_Aspects;
- end Flag20;
-
- function Flag21 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return Nodes.Table (N + 1).Rewrite_Ins;
- end Flag21;
-
- function Flag22 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return Nodes.Table (N + 1).Analyzed;
- end Flag22;
-
- function Flag23 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return Nodes.Table (N + 1).Comes_From_Source;
- end Flag23;
-
- function Flag24 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return Nodes.Table (N + 1).Error_Posted;
- end Flag24;
-
- function Flag25 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return Nodes.Table (N + 1).Flag4;
- end Flag25;
-
- function Flag26 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return Nodes.Table (N + 1).Flag5;
- end Flag26;
-
- function Flag27 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return Nodes.Table (N + 1).Flag6;
- end Flag27;
-
- function Flag28 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return Nodes.Table (N + 1).Flag7;
- end Flag28;
-
- function Flag29 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return Nodes.Table (N + 1).Flag8;
- end Flag29;
-
- function Flag30 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return Nodes.Table (N + 1).Flag9;
- end Flag30;
-
- function Flag31 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return Nodes.Table (N + 1).Flag10;
- end Flag31;
-
- function Flag32 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return Nodes.Table (N + 1).Flag11;
- end Flag32;
-
- function Flag33 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return Nodes.Table (N + 1).Flag12;
- end Flag33;
-
- function Flag34 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return Nodes.Table (N + 1).Flag13;
- end Flag34;
-
- function Flag35 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return Nodes.Table (N + 1).Flag14;
- end Flag35;
-
- function Flag36 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return Nodes.Table (N + 1).Flag15;
- end Flag36;
-
- function Flag37 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return Nodes.Table (N + 1).Flag16;
- end Flag37;
-
- function Flag38 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return Nodes.Table (N + 1).Flag17;
- end Flag38;
-
- function Flag39 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return Nodes.Table (N + 1).Flag18;
- end Flag39;
-
- function Flag40 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return Nodes.Table (N + 2).In_List;
- end Flag40;
-
- function Flag41 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return Nodes.Table (N + 2).Has_Aspects;
- end Flag41;
-
- function Flag42 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return Nodes.Table (N + 2).Rewrite_Ins;
- end Flag42;
-
- function Flag43 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return Nodes.Table (N + 2).Analyzed;
- end Flag43;
-
- function Flag44 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return Nodes.Table (N + 2).Comes_From_Source;
- end Flag44;
-
- function Flag45 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return Nodes.Table (N + 2).Error_Posted;
- end Flag45;
-
- function Flag46 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return Nodes.Table (N + 2).Flag4;
- end Flag46;
-
- function Flag47 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return Nodes.Table (N + 2).Flag5;
- end Flag47;
-
- function Flag48 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return Nodes.Table (N + 2).Flag6;
- end Flag48;
-
- function Flag49 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return Nodes.Table (N + 2).Flag7;
- end Flag49;
-
- function Flag50 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return Nodes.Table (N + 2).Flag8;
- end Flag50;
-
- function Flag51 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return Nodes.Table (N + 2).Flag9;
- end Flag51;
-
- function Flag52 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return Nodes.Table (N + 2).Flag10;
- end Flag52;
-
- function Flag53 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return Nodes.Table (N + 2).Flag11;
- end Flag53;
-
- function Flag54 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return Nodes.Table (N + 2).Flag12;
- end Flag54;
-
- function Flag55 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return Nodes.Table (N + 2).Flag13;
- end Flag55;
-
- function Flag56 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return Nodes.Table (N + 2).Flag14;
- end Flag56;
-
- function Flag57 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return Nodes.Table (N + 2).Flag15;
- end Flag57;
-
- function Flag58 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return Nodes.Table (N + 2).Flag16;
- end Flag58;
-
- function Flag59 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return Nodes.Table (N + 2).Flag17;
- end Flag59;
-
- function Flag60 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return Nodes.Table (N + 2).Flag18;
- end Flag60;
-
- function Flag61 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return Nodes.Table (N + 1).Pflag1;
- end Flag61;
-
- function Flag62 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return Nodes.Table (N + 1).Pflag2;
- end Flag62;
-
- function Flag63 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return Nodes.Table (N + 2).Pflag1;
- end Flag63;
-
- function Flag64 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return Nodes.Table (N + 2).Pflag2;
- end Flag64;
-
- function Flag65 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return To_Flag_Byte (Nodes.Table (N + 2).Nkind).Flag65;
- end Flag65;
-
- function Flag66 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return To_Flag_Byte (Nodes.Table (N + 2).Nkind).Flag66;
- end Flag66;
-
- function Flag67 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return To_Flag_Byte (Nodes.Table (N + 2).Nkind).Flag67;
- end Flag67;
-
- function Flag68 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return To_Flag_Byte (Nodes.Table (N + 2).Nkind).Flag68;
- end Flag68;
-
- function Flag69 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return To_Flag_Byte (Nodes.Table (N + 2).Nkind).Flag69;
- end Flag69;
-
- function Flag70 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return To_Flag_Byte (Nodes.Table (N + 2).Nkind).Flag70;
- end Flag70;
-
- function Flag71 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return To_Flag_Byte (Nodes.Table (N + 2).Nkind).Flag71;
- end Flag71;
-
- function Flag72 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return To_Flag_Byte (Nodes.Table (N + 2).Nkind).Flag72;
- end Flag72;
-
- function Flag73 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return To_Flag_Word (Nodes.Table (N + 2).Field12).Flag73;
- end Flag73;
-
- function Flag74 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return To_Flag_Word (Nodes.Table (N + 2).Field12).Flag74;
- end Flag74;
-
- function Flag75 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return To_Flag_Word (Nodes.Table (N + 2).Field12).Flag75;
- end Flag75;
-
- function Flag76 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return To_Flag_Word (Nodes.Table (N + 2).Field12).Flag76;
- end Flag76;
-
- function Flag77 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return To_Flag_Word (Nodes.Table (N + 2).Field12).Flag77;
- end Flag77;
-
- function Flag78 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return To_Flag_Word (Nodes.Table (N + 2).Field12).Flag78;
- end Flag78;
-
- function Flag79 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return To_Flag_Word (Nodes.Table (N + 2).Field12).Flag79;
- end Flag79;
-
- function Flag80 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return To_Flag_Word (Nodes.Table (N + 2).Field12).Flag80;
- end Flag80;
-
- function Flag81 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return To_Flag_Word (Nodes.Table (N + 2).Field12).Flag81;
- end Flag81;
-
- function Flag82 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return To_Flag_Word (Nodes.Table (N + 2).Field12).Flag82;
- end Flag82;
-
- function Flag83 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return To_Flag_Word (Nodes.Table (N + 2).Field12).Flag83;
- end Flag83;
-
- function Flag84 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return To_Flag_Word (Nodes.Table (N + 2).Field12).Flag84;
- end Flag84;
-
- function Flag85 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return To_Flag_Word (Nodes.Table (N + 2).Field12).Flag85;
- end Flag85;
-
- function Flag86 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return To_Flag_Word (Nodes.Table (N + 2).Field12).Flag86;
- end Flag86;
-
- function Flag87 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return To_Flag_Word (Nodes.Table (N + 2).Field12).Flag87;
- end Flag87;
-
- function Flag88 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return To_Flag_Word (Nodes.Table (N + 2).Field12).Flag88;
- end Flag88;
-
- function Flag89 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return To_Flag_Word (Nodes.Table (N + 2).Field12).Flag89;
- end Flag89;
-
- function Flag90 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return To_Flag_Word (Nodes.Table (N + 2).Field12).Flag90;
- end Flag90;
-
- function Flag91 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return To_Flag_Word (Nodes.Table (N + 2).Field12).Flag91;
- end Flag91;
-
- function Flag92 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return To_Flag_Word (Nodes.Table (N + 2).Field12).Flag92;
- end Flag92;
-
- function Flag93 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return To_Flag_Word (Nodes.Table (N + 2).Field12).Flag93;
- end Flag93;
-
- function Flag94 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return To_Flag_Word (Nodes.Table (N + 2).Field12).Flag94;
- end Flag94;
-
- function Flag95 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return To_Flag_Word (Nodes.Table (N + 2).Field12).Flag95;
- end Flag95;
-
- function Flag96 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return To_Flag_Word (Nodes.Table (N + 2).Field12).Flag96;
- end Flag96;
-
- function Flag97 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return To_Flag_Word2 (Nodes.Table (N + 3).Field12).Flag97;
- end Flag97;
-
- function Flag98 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return To_Flag_Word2 (Nodes.Table (N + 3).Field12).Flag98;
- end Flag98;
-
- function Flag99 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return To_Flag_Word2 (Nodes.Table (N + 3).Field12).Flag99;
- end Flag99;
-
- function Flag100 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return To_Flag_Word2 (Nodes.Table (N + 3).Field12).Flag100;
- end Flag100;
-
- function Flag101 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return To_Flag_Word2 (Nodes.Table (N + 3).Field12).Flag101;
- end Flag101;
-
- function Flag102 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return To_Flag_Word2 (Nodes.Table (N + 3).Field12).Flag102;
- end Flag102;
-
- function Flag103 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return To_Flag_Word2 (Nodes.Table (N + 3).Field12).Flag103;
- end Flag103;
-
- function Flag104 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return To_Flag_Word2 (Nodes.Table (N + 3).Field12).Flag104;
- end Flag104;
-
- function Flag105 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return To_Flag_Word2 (Nodes.Table (N + 3).Field12).Flag105;
- end Flag105;
-
- function Flag106 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return To_Flag_Word2 (Nodes.Table (N + 3).Field12).Flag106;
- end Flag106;
-
- function Flag107 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return To_Flag_Word2 (Nodes.Table (N + 3).Field12).Flag107;
- end Flag107;
-
- function Flag108 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return To_Flag_Word2 (Nodes.Table (N + 3).Field12).Flag108;
- end Flag108;
-
- function Flag109 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return To_Flag_Word2 (Nodes.Table (N + 3).Field12).Flag109;
- end Flag109;
-
- function Flag110 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return To_Flag_Word2 (Nodes.Table (N + 3).Field12).Flag110;
- end Flag110;
-
- function Flag111 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return To_Flag_Word2 (Nodes.Table (N + 3).Field12).Flag111;
- end Flag111;
-
- function Flag112 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return To_Flag_Word2 (Nodes.Table (N + 3).Field12).Flag112;
- end Flag112;
-
- function Flag113 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return To_Flag_Word2 (Nodes.Table (N + 3).Field12).Flag113;
- end Flag113;
-
- function Flag114 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return To_Flag_Word2 (Nodes.Table (N + 3).Field12).Flag114;
- end Flag114;
-
- function Flag115 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return To_Flag_Word2 (Nodes.Table (N + 3).Field12).Flag115;
- end Flag115;
-
- function Flag116 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return To_Flag_Word2 (Nodes.Table (N + 3).Field12).Flag116;
- end Flag116;
-
- function Flag117 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return To_Flag_Word2 (Nodes.Table (N + 3).Field12).Flag117;
- end Flag117;
-
- function Flag118 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return To_Flag_Word2 (Nodes.Table (N + 3).Field12).Flag118;
- end Flag118;
-
- function Flag119 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return To_Flag_Word2 (Nodes.Table (N + 3).Field12).Flag119;
- end Flag119;
-
- function Flag120 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return To_Flag_Word2 (Nodes.Table (N + 3).Field12).Flag120;
- end Flag120;
-
- function Flag121 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return To_Flag_Word2 (Nodes.Table (N + 3).Field12).Flag121;
- end Flag121;
-
- function Flag122 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return To_Flag_Word2 (Nodes.Table (N + 3).Field12).Flag122;
- end Flag122;
-
- function Flag123 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return To_Flag_Word2 (Nodes.Table (N + 3).Field12).Flag123;
- end Flag123;
-
- function Flag124 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return To_Flag_Word2 (Nodes.Table (N + 3).Field12).Flag124;
- end Flag124;
-
- function Flag125 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return To_Flag_Word2 (Nodes.Table (N + 3).Field12).Flag125;
- end Flag125;
-
- function Flag126 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return To_Flag_Word2 (Nodes.Table (N + 3).Field12).Flag126;
- end Flag126;
-
- function Flag127 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return To_Flag_Word2 (Nodes.Table (N + 3).Field12).Flag127;
- end Flag127;
-
- function Flag128 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return To_Flag_Word2 (Nodes.Table (N + 3).Field12).Flag128;
- end Flag128;
-
- function Flag129 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return Nodes.Table (N + 3).In_List;
- end Flag129;
-
- function Flag130 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return Nodes.Table (N + 3).Has_Aspects;
- end Flag130;
-
- function Flag131 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return Nodes.Table (N + 3).Rewrite_Ins;
- end Flag131;
-
- function Flag132 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return Nodes.Table (N + 3).Analyzed;
- end Flag132;
-
- function Flag133 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return Nodes.Table (N + 3).Comes_From_Source;
- end Flag133;
-
- function Flag134 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return Nodes.Table (N + 3).Error_Posted;
- end Flag134;
-
- function Flag135 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return Nodes.Table (N + 3).Flag4;
- end Flag135;
-
- function Flag136 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return Nodes.Table (N + 3).Flag5;
- end Flag136;
-
- function Flag137 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return Nodes.Table (N + 3).Flag6;
- end Flag137;
-
- function Flag138 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return Nodes.Table (N + 3).Flag7;
- end Flag138;
-
- function Flag139 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return Nodes.Table (N + 3).Flag8;
- end Flag139;
-
- function Flag140 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return Nodes.Table (N + 3).Flag9;
- end Flag140;
-
- function Flag141 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return Nodes.Table (N + 3).Flag10;
- end Flag141;
-
- function Flag142 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return Nodes.Table (N + 3).Flag11;
- end Flag142;
-
- function Flag143 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return Nodes.Table (N + 3).Flag12;
- end Flag143;
-
- function Flag144 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return Nodes.Table (N + 3).Flag13;
- end Flag144;
-
- function Flag145 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return Nodes.Table (N + 3).Flag14;
- end Flag145;
-
- function Flag146 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return Nodes.Table (N + 3).Flag15;
- end Flag146;
-
- function Flag147 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return Nodes.Table (N + 3).Flag16;
- end Flag147;
-
- function Flag148 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return Nodes.Table (N + 3).Flag17;
- end Flag148;
-
- function Flag149 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return Nodes.Table (N + 3).Flag18;
- end Flag149;
-
- function Flag150 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return Nodes.Table (N + 3).Pflag1;
- end Flag150;
-
- function Flag151 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return Nodes.Table (N + 3).Pflag2;
- end Flag151;
-
- function Flag152 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return To_Flag_Word3 (Nodes.Table (N + 3).Field11).Flag152;
- end Flag152;
-
- function Flag153 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return To_Flag_Word3 (Nodes.Table (N + 3).Field11).Flag153;
- end Flag153;
-
- function Flag154 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return To_Flag_Word3 (Nodes.Table (N + 3).Field11).Flag154;
- end Flag154;
-
- function Flag155 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return To_Flag_Word3 (Nodes.Table (N + 3).Field11).Flag155;
- end Flag155;
-
- function Flag156 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return To_Flag_Word3 (Nodes.Table (N + 3).Field11).Flag156;
- end Flag156;
-
- function Flag157 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return To_Flag_Word3 (Nodes.Table (N + 3).Field11).Flag157;
- end Flag157;
-
- function Flag158 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return To_Flag_Word3 (Nodes.Table (N + 3).Field11).Flag158;
- end Flag158;
-
- function Flag159 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return To_Flag_Word3 (Nodes.Table (N + 3).Field11).Flag159;
- end Flag159;
-
- function Flag160 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return To_Flag_Word3 (Nodes.Table (N + 3).Field11).Flag160;
- end Flag160;
-
- function Flag161 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return To_Flag_Word3 (Nodes.Table (N + 3).Field11).Flag161;
- end Flag161;
-
- function Flag162 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return To_Flag_Word3 (Nodes.Table (N + 3).Field11).Flag162;
- end Flag162;
-
- function Flag163 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return To_Flag_Word3 (Nodes.Table (N + 3).Field11).Flag163;
- end Flag163;
-
- function Flag164 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return To_Flag_Word3 (Nodes.Table (N + 3).Field11).Flag164;
- end Flag164;
-
- function Flag165 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return To_Flag_Word3 (Nodes.Table (N + 3).Field11).Flag165;
- end Flag165;
-
- function Flag166 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return To_Flag_Word3 (Nodes.Table (N + 3).Field11).Flag166;
- end Flag166;
-
- function Flag167 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return To_Flag_Word3 (Nodes.Table (N + 3).Field11).Flag167;
- end Flag167;
-
- function Flag168 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return To_Flag_Word3 (Nodes.Table (N + 3).Field11).Flag168;
- end Flag168;
-
- function Flag169 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return To_Flag_Word3 (Nodes.Table (N + 3).Field11).Flag169;
- end Flag169;
-
- function Flag170 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return To_Flag_Word3 (Nodes.Table (N + 3).Field11).Flag170;
- end Flag170;
-
- function Flag171 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return To_Flag_Word3 (Nodes.Table (N + 3).Field11).Flag171;
- end Flag171;
-
- function Flag172 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return To_Flag_Word3 (Nodes.Table (N + 3).Field11).Flag172;
- end Flag172;
-
- function Flag173 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return To_Flag_Word3 (Nodes.Table (N + 3).Field11).Flag173;
- end Flag173;
-
- function Flag174 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return To_Flag_Word3 (Nodes.Table (N + 3).Field11).Flag174;
- end Flag174;
-
- function Flag175 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return To_Flag_Word3 (Nodes.Table (N + 3).Field11).Flag175;
- end Flag175;
-
- function Flag176 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return To_Flag_Word3 (Nodes.Table (N + 3).Field11).Flag176;
- end Flag176;
-
- function Flag177 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return To_Flag_Word3 (Nodes.Table (N + 3).Field11).Flag177;
- end Flag177;
-
- function Flag178 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return To_Flag_Word3 (Nodes.Table (N + 3).Field11).Flag178;
- end Flag178;
-
- function Flag179 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return To_Flag_Word3 (Nodes.Table (N + 3).Field11).Flag179;
- end Flag179;
-
- function Flag180 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return To_Flag_Word3 (Nodes.Table (N + 3).Field11).Flag180;
- end Flag180;
-
- function Flag181 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return To_Flag_Word3 (Nodes.Table (N + 3).Field11).Flag181;
- end Flag181;
-
- function Flag182 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return To_Flag_Word3 (Nodes.Table (N + 3).Field11).Flag182;
- end Flag182;
-
- function Flag183 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return To_Flag_Word3 (Nodes.Table (N + 3).Field11).Flag183;
- end Flag183;
-
- function Flag184 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return To_Flag_Word4 (Nodes.Table (N + 4).Field12).Flag184;
- end Flag184;
-
- function Flag185 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return To_Flag_Word4 (Nodes.Table (N + 4).Field12).Flag185;
- end Flag185;
-
- function Flag186 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return To_Flag_Word4 (Nodes.Table (N + 4).Field12).Flag186;
- end Flag186;
-
- function Flag187 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return To_Flag_Word4 (Nodes.Table (N + 4).Field12).Flag187;
- end Flag187;
-
- function Flag188 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return To_Flag_Word4 (Nodes.Table (N + 4).Field12).Flag188;
- end Flag188;
-
- function Flag189 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return To_Flag_Word4 (Nodes.Table (N + 4).Field12).Flag189;
- end Flag189;
-
- function Flag190 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return To_Flag_Word4 (Nodes.Table (N + 4).Field12).Flag190;
- end Flag190;
-
- function Flag191 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return To_Flag_Word4 (Nodes.Table (N + 4).Field12).Flag191;
- end Flag191;
-
- function Flag192 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return To_Flag_Word4 (Nodes.Table (N + 4).Field12).Flag192;
- end Flag192;
-
- function Flag193 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return To_Flag_Word4 (Nodes.Table (N + 4).Field12).Flag193;
- end Flag193;
-
- function Flag194 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return To_Flag_Word4 (Nodes.Table (N + 4).Field12).Flag194;
- end Flag194;
-
- function Flag195 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return To_Flag_Word4 (Nodes.Table (N + 4).Field12).Flag195;
- end Flag195;
-
- function Flag196 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return To_Flag_Word4 (Nodes.Table (N + 4).Field12).Flag196;
- end Flag196;
-
- function Flag197 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return To_Flag_Word4 (Nodes.Table (N + 4).Field12).Flag197;
- end Flag197;
-
- function Flag198 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return To_Flag_Word4 (Nodes.Table (N + 4).Field12).Flag198;
- end Flag198;
-
- function Flag199 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return To_Flag_Word4 (Nodes.Table (N + 4).Field12).Flag199;
- end Flag199;
-
- function Flag200 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return To_Flag_Word4 (Nodes.Table (N + 4).Field12).Flag200;
- end Flag200;
-
- function Flag201 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return To_Flag_Word4 (Nodes.Table (N + 4).Field12).Flag201;
- end Flag201;
-
- function Flag202 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return To_Flag_Word4 (Nodes.Table (N + 4).Field12).Flag202;
- end Flag202;
-
- function Flag203 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return To_Flag_Word4 (Nodes.Table (N + 4).Field12).Flag203;
- end Flag203;
-
- function Flag204 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return To_Flag_Word4 (Nodes.Table (N + 4).Field12).Flag204;
- end Flag204;
-
- function Flag205 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return To_Flag_Word4 (Nodes.Table (N + 4).Field12).Flag205;
- end Flag205;
-
- function Flag206 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return To_Flag_Word4 (Nodes.Table (N + 4).Field12).Flag206;
- end Flag206;
-
- function Flag207 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return To_Flag_Word4 (Nodes.Table (N + 4).Field12).Flag207;
- end Flag207;
-
- function Flag208 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return To_Flag_Word4 (Nodes.Table (N + 4).Field12).Flag208;
- end Flag208;
-
- function Flag209 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return To_Flag_Word4 (Nodes.Table (N + 4).Field12).Flag209;
- end Flag209;
-
- function Flag210 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return To_Flag_Word4 (Nodes.Table (N + 4).Field12).Flag210;
- end Flag210;
-
- function Flag211 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return To_Flag_Word4 (Nodes.Table (N + 4).Field12).Flag211;
- end Flag211;
-
- function Flag212 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return To_Flag_Word4 (Nodes.Table (N + 4).Field12).Flag212;
- end Flag212;
-
- function Flag213 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return To_Flag_Word4 (Nodes.Table (N + 4).Field12).Flag213;
- end Flag213;
-
- function Flag214 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return To_Flag_Word4 (Nodes.Table (N + 4).Field12).Flag214;
- end Flag214;
-
- function Flag215 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return To_Flag_Word4 (Nodes.Table (N + 4).Field12).Flag215;
- end Flag215;
-
- function Flag216 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return Nodes.Table (N + 4).In_List;
- end Flag216;
-
- function Flag217 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return Nodes.Table (N + 4).Has_Aspects;
- end Flag217;
-
- function Flag218 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return Nodes.Table (N + 4).Rewrite_Ins;
- end Flag218;
-
- function Flag219 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return Nodes.Table (N + 4).Analyzed;
- end Flag219;
-
- function Flag220 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return Nodes.Table (N + 4).Comes_From_Source;
- end Flag220;
-
- function Flag221 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return Nodes.Table (N + 4).Error_Posted;
- end Flag221;
-
- function Flag222 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return Nodes.Table (N + 4).Flag4;
- end Flag222;
-
- function Flag223 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return Nodes.Table (N + 4).Flag5;
- end Flag223;
-
- function Flag224 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return Nodes.Table (N + 4).Flag6;
- end Flag224;
-
- function Flag225 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return Nodes.Table (N + 4).Flag7;
- end Flag225;
-
- function Flag226 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return Nodes.Table (N + 4).Flag8;
- end Flag226;
-
- function Flag227 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return Nodes.Table (N + 4).Flag9;
- end Flag227;
-
- function Flag228 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return Nodes.Table (N + 4).Flag10;
- end Flag228;
-
- function Flag229 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return Nodes.Table (N + 4).Flag11;
- end Flag229;
-
- function Flag230 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return Nodes.Table (N + 4).Flag12;
- end Flag230;
-
- function Flag231 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return Nodes.Table (N + 4).Flag13;
- end Flag231;
-
- function Flag232 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return Nodes.Table (N + 4).Flag14;
- end Flag232;
-
- function Flag233 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return Nodes.Table (N + 4).Flag15;
- end Flag233;
-
- function Flag234 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return Nodes.Table (N + 4).Flag16;
- end Flag234;
-
- function Flag235 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return Nodes.Table (N + 4).Flag17;
- end Flag235;
-
- function Flag236 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return Nodes.Table (N + 4).Flag18;
- end Flag236;
-
- function Flag237 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return Nodes.Table (N + 4).Pflag1;
- end Flag237;
-
- function Flag238 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return Nodes.Table (N + 4).Pflag2;
- end Flag238;
-
- function Flag239 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return To_Flag_Byte2 (Nodes.Table (N + 3).Nkind).Flag239;
- end Flag239;
-
- function Flag240 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return To_Flag_Byte2 (Nodes.Table (N + 3).Nkind).Flag240;
- end Flag240;
-
- function Flag241 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return To_Flag_Byte2 (Nodes.Table (N + 3).Nkind).Flag241;
- end Flag241;
-
- function Flag242 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return To_Flag_Byte2 (Nodes.Table (N + 3).Nkind).Flag242;
- end Flag242;
-
- function Flag243 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return To_Flag_Byte2 (Nodes.Table (N + 3).Nkind).Flag243;
- end Flag243;
-
- function Flag244 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return To_Flag_Byte2 (Nodes.Table (N + 3).Nkind).Flag244;
- end Flag244;
-
- function Flag245 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return To_Flag_Byte2 (Nodes.Table (N + 3).Nkind).Flag245;
- end Flag245;
-
- function Flag246 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return To_Flag_Byte2 (Nodes.Table (N + 3).Nkind).Flag246;
- end Flag246;
-
- function Flag247 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return To_Flag_Byte3 (Nodes.Table (N + 4).Nkind).Flag247;
- end Flag247;
-
- function Flag248 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return To_Flag_Byte3 (Nodes.Table (N + 4).Nkind).Flag248;
- end Flag248;
-
- function Flag249 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return To_Flag_Byte3 (Nodes.Table (N + 4).Nkind).Flag249;
- end Flag249;
-
- function Flag250 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return To_Flag_Byte3 (Nodes.Table (N + 4).Nkind).Flag250;
- end Flag250;
-
- function Flag251 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return To_Flag_Byte3 (Nodes.Table (N + 4).Nkind).Flag251;
- end Flag251;
-
- function Flag252 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return To_Flag_Byte3 (Nodes.Table (N + 4).Nkind).Flag252;
- end Flag252;
-
- function Flag253 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return To_Flag_Byte3 (Nodes.Table (N + 4).Nkind).Flag253;
- end Flag253;
-
- function Flag254 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return To_Flag_Byte3 (Nodes.Table (N + 4).Nkind).Flag254;
- end Flag254;
-
- function Flag255 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return To_Flag_Word5 (Nodes.Table (N + 5).Field12).Flag255;
- end Flag255;
-
- function Flag256 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return To_Flag_Word5 (Nodes.Table (N + 5).Field12).Flag256;
- end Flag256;
-
- function Flag257 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return To_Flag_Word5 (Nodes.Table (N + 5).Field12).Flag257;
- end Flag257;
-
- function Flag258 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return To_Flag_Word5 (Nodes.Table (N + 5).Field12).Flag258;
- end Flag258;
-
- function Flag259 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return To_Flag_Word5 (Nodes.Table (N + 5).Field12).Flag259;
- end Flag259;
-
- function Flag260 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return To_Flag_Word5 (Nodes.Table (N + 5).Field12).Flag260;
- end Flag260;
-
- function Flag261 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return To_Flag_Word5 (Nodes.Table (N + 5).Field12).Flag261;
- end Flag261;
-
- function Flag262 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return To_Flag_Word5 (Nodes.Table (N + 5).Field12).Flag262;
- end Flag262;
-
- function Flag263 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return To_Flag_Word5 (Nodes.Table (N + 5).Field12).Flag263;
- end Flag263;
-
- function Flag264 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return To_Flag_Word5 (Nodes.Table (N + 5).Field12).Flag264;
- end Flag264;
-
- function Flag265 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return To_Flag_Word5 (Nodes.Table (N + 5).Field12).Flag265;
- end Flag265;
-
- function Flag266 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return To_Flag_Word5 (Nodes.Table (N + 5).Field12).Flag266;
- end Flag266;
-
- function Flag267 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return To_Flag_Word5 (Nodes.Table (N + 5).Field12).Flag267;
- end Flag267;
-
- function Flag268 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return To_Flag_Word5 (Nodes.Table (N + 5).Field12).Flag268;
- end Flag268;
-
- function Flag269 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return To_Flag_Word5 (Nodes.Table (N + 5).Field12).Flag269;
- end Flag269;
-
- function Flag270 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return To_Flag_Word5 (Nodes.Table (N + 5).Field12).Flag270;
- end Flag270;
-
- function Flag271 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return To_Flag_Word5 (Nodes.Table (N + 5).Field12).Flag271;
- end Flag271;
-
- function Flag272 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return To_Flag_Word5 (Nodes.Table (N + 5).Field12).Flag272;
- end Flag272;
-
- function Flag273 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return To_Flag_Word5 (Nodes.Table (N + 5).Field12).Flag273;
- end Flag273;
-
- function Flag274 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return To_Flag_Word5 (Nodes.Table (N + 5).Field12).Flag274;
- end Flag274;
-
- function Flag275 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return To_Flag_Word5 (Nodes.Table (N + 5).Field12).Flag275;
- end Flag275;
-
- function Flag276 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return To_Flag_Word5 (Nodes.Table (N + 5).Field12).Flag276;
- end Flag276;
-
- function Flag277 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return To_Flag_Word5 (Nodes.Table (N + 5).Field12).Flag277;
- end Flag277;
-
- function Flag278 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return To_Flag_Word5 (Nodes.Table (N + 5).Field12).Flag278;
- end Flag278;
-
- function Flag279 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return To_Flag_Word5 (Nodes.Table (N + 5).Field12).Flag279;
- end Flag279;
-
- function Flag280 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return To_Flag_Word5 (Nodes.Table (N + 5).Field12).Flag280;
- end Flag280;
-
- function Flag281 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return To_Flag_Word5 (Nodes.Table (N + 5).Field12).Flag281;
- end Flag281;
-
- function Flag282 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return To_Flag_Word5 (Nodes.Table (N + 5).Field12).Flag282;
- end Flag282;
-
- function Flag283 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return To_Flag_Word5 (Nodes.Table (N + 5).Field12).Flag283;
- end Flag283;
-
- function Flag284 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return To_Flag_Word5 (Nodes.Table (N + 5).Field12).Flag284;
- end Flag284;
-
- function Flag285 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return To_Flag_Word5 (Nodes.Table (N + 5).Field12).Flag285;
- end Flag285;
-
- function Flag286 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return To_Flag_Word5 (Nodes.Table (N + 5).Field12).Flag286;
- end Flag286;
-
- function Flag287 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return Nodes.Table (N + 5).In_List;
- end Flag287;
-
- function Flag288 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return Nodes.Table (N + 5).Has_Aspects;
- end Flag288;
-
- function Flag289 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return Nodes.Table (N + 5).Rewrite_Ins;
- end Flag289;
-
- function Flag290 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return Nodes.Table (N + 5).Analyzed;
- end Flag290;
-
- function Flag291 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return Nodes.Table (N + 5).Comes_From_Source;
- end Flag291;
-
- function Flag292 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return Nodes.Table (N + 5).Error_Posted;
- end Flag292;
-
- function Flag293 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return Nodes.Table (N + 5).Flag4;
- end Flag293;
-
- function Flag294 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return Nodes.Table (N + 5).Flag5;
- end Flag294;
-
- function Flag295 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return Nodes.Table (N + 5).Flag6;
- end Flag295;
-
- function Flag296 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return Nodes.Table (N + 5).Flag7;
- end Flag296;
-
- function Flag297 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return Nodes.Table (N + 5).Flag8;
- end Flag297;
-
- function Flag298 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return Nodes.Table (N + 5).Flag9;
- end Flag298;
-
- function Flag299 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return Nodes.Table (N + 5).Flag10;
- end Flag299;
-
- function Flag300 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return Nodes.Table (N + 5).Flag11;
- end Flag300;
-
- function Flag301 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return Nodes.Table (N + 5).Flag12;
- end Flag301;
-
- function Flag302 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return Nodes.Table (N + 5).Flag13;
- end Flag302;
-
- function Flag303 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return Nodes.Table (N + 5).Flag14;
- end Flag303;
-
- function Flag304 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return Nodes.Table (N + 5).Flag15;
- end Flag304;
-
- function Flag305 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return Nodes.Table (N + 5).Flag16;
- end Flag305;
-
- function Flag306 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return Nodes.Table (N + 5).Flag17;
- end Flag306;
-
- function Flag307 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return Nodes.Table (N + 5).Flag18;
- end Flag307;
-
- function Flag308 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return Nodes.Table (N + 5).Pflag1;
- end Flag308;
-
- function Flag309 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return Nodes.Table (N + 5).Pflag2;
- end Flag309;
-
- function Flag310 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return To_Flag_Byte4 (Nodes.Table (N + 5).Nkind).Flag310;
- end Flag310;
-
- function Flag311 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return To_Flag_Byte4 (Nodes.Table (N + 5).Nkind).Flag311;
- end Flag311;
-
- function Flag312 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return To_Flag_Byte4 (Nodes.Table (N + 5).Nkind).Flag312;
- end Flag312;
-
- function Flag313 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return To_Flag_Byte4 (Nodes.Table (N + 5).Nkind).Flag313;
- end Flag313;
-
- function Flag314 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return To_Flag_Byte4 (Nodes.Table (N + 5).Nkind).Flag314;
- end Flag314;
-
- function Flag315 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return To_Flag_Byte4 (Nodes.Table (N + 5).Nkind).Flag315;
- end Flag315;
-
- function Flag316 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return To_Flag_Byte4 (Nodes.Table (N + 5).Nkind).Flag316;
- end Flag316;
-
- function Flag317 (N : Node_Id) return Boolean is
- begin
- pragma Assert (Nkind (N) in N_Entity);
- return To_Flag_Byte4 (Nodes.Table (N + 5).Nkind).Flag317;
- end Flag317;
-
- procedure Set_Nkind (N : Node_Id; Val : Node_Kind) is
- begin
- pragma Assert (not Locked);
- pragma Assert (N <= Nodes.Last);
- Nodes.Table (N).Nkind := Val;
- end Set_Nkind;
-
- procedure Set_Field1 (N : Node_Id; Val : Union_Id) is
- begin
- pragma Assert (not Locked);
- pragma Assert (N <= Nodes.Last);
- Nodes.Table (N).Field1 := Val;
- end Set_Field1;
-
- procedure Set_Field2 (N : Node_Id; Val : Union_Id) is
- begin
- pragma Assert (not Locked);
- pragma Assert (N <= Nodes.Last);
- Nodes.Table (N).Field2 := Val;
- end Set_Field2;
-
- procedure Set_Field3 (N : Node_Id; Val : Union_Id) is
- begin
- pragma Assert (not Locked);
- pragma Assert (N <= Nodes.Last);
- Nodes.Table (N).Field3 := Val;
- end Set_Field3;
-
- procedure Set_Field4 (N : Node_Id; Val : Union_Id) is
- begin
- pragma Assert (not Locked);
- pragma Assert (N <= Nodes.Last);
- Nodes.Table (N).Field4 := Val;
- end Set_Field4;
-
- procedure Set_Field5 (N : Node_Id; Val : Union_Id) is
- begin
- pragma Assert (not Locked);
- pragma Assert (N <= Nodes.Last);
- Nodes.Table (N).Field5 := Val;
- end Set_Field5;
-
- procedure Set_Field6 (N : Node_Id; Val : Union_Id) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- Nodes.Table (N + 1).Field6 := Val;
- end Set_Field6;
-
- procedure Set_Field7 (N : Node_Id; Val : Union_Id) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- Nodes.Table (N + 1).Field7 := Val;
- end Set_Field7;
-
- procedure Set_Field8 (N : Node_Id; Val : Union_Id) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- Nodes.Table (N + 1).Field8 := Val;
- end Set_Field8;
-
- procedure Set_Field9 (N : Node_Id; Val : Union_Id) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- Nodes.Table (N + 1).Field9 := Val;
- end Set_Field9;
-
- procedure Set_Field10 (N : Node_Id; Val : Union_Id) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- Nodes.Table (N + 1).Field10 := Val;
- end Set_Field10;
-
- procedure Set_Field11 (N : Node_Id; Val : Union_Id) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- Nodes.Table (N + 1).Field11 := Val;
- end Set_Field11;
-
- procedure Set_Field12 (N : Node_Id; Val : Union_Id) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- Nodes.Table (N + 1).Field12 := Val;
- end Set_Field12;
-
- procedure Set_Field13 (N : Node_Id; Val : Union_Id) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- Nodes.Table (N + 2).Field6 := Val;
- end Set_Field13;
-
- procedure Set_Field14 (N : Node_Id; Val : Union_Id) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- Nodes.Table (N + 2).Field7 := Val;
- end Set_Field14;
-
- procedure Set_Field15 (N : Node_Id; Val : Union_Id) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- Nodes.Table (N + 2).Field8 := Val;
- end Set_Field15;
-
- procedure Set_Field16 (N : Node_Id; Val : Union_Id) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- Nodes.Table (N + 2).Field9 := Val;
- end Set_Field16;
-
- procedure Set_Field17 (N : Node_Id; Val : Union_Id) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- Nodes.Table (N + 2).Field10 := Val;
- end Set_Field17;
-
- procedure Set_Field18 (N : Node_Id; Val : Union_Id) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- Nodes.Table (N + 2).Field11 := Val;
- end Set_Field18;
-
- procedure Set_Field19 (N : Node_Id; Val : Union_Id) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- Nodes.Table (N + 3).Field6 := Val;
- end Set_Field19;
-
- procedure Set_Field20 (N : Node_Id; Val : Union_Id) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- Nodes.Table (N + 3).Field7 := Val;
- end Set_Field20;
-
- procedure Set_Field21 (N : Node_Id; Val : Union_Id) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- Nodes.Table (N + 3).Field8 := Val;
- end Set_Field21;
-
- procedure Set_Field22 (N : Node_Id; Val : Union_Id) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- Nodes.Table (N + 3).Field9 := Val;
- end Set_Field22;
-
- procedure Set_Field23 (N : Node_Id; Val : Union_Id) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- Nodes.Table (N + 3).Field10 := Val;
- end Set_Field23;
-
- procedure Set_Field24 (N : Node_Id; Val : Union_Id) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- Nodes.Table (N + 4).Field6 := Val;
- end Set_Field24;
-
- procedure Set_Field25 (N : Node_Id; Val : Union_Id) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- Nodes.Table (N + 4).Field7 := Val;
- end Set_Field25;
-
- procedure Set_Field26 (N : Node_Id; Val : Union_Id) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- Nodes.Table (N + 4).Field8 := Val;
- end Set_Field26;
-
- procedure Set_Field27 (N : Node_Id; Val : Union_Id) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- Nodes.Table (N + 4).Field9 := Val;
- end Set_Field27;
-
- procedure Set_Field28 (N : Node_Id; Val : Union_Id) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- Nodes.Table (N + 4).Field10 := Val;
- end Set_Field28;
-
- procedure Set_Field29 (N : Node_Id; Val : Union_Id) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- Nodes.Table (N + 4).Field11 := Val;
- end Set_Field29;
-
- procedure Set_Field30 (N : Node_Id; Val : Union_Id) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- Nodes.Table (N + 5).Field6 := Val;
- end Set_Field30;
-
- procedure Set_Field31 (N : Node_Id; Val : Union_Id) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- Nodes.Table (N + 5).Field7 := Val;
- end Set_Field31;
-
- procedure Set_Field32 (N : Node_Id; Val : Union_Id) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- Nodes.Table (N + 5).Field8 := Val;
- end Set_Field32;
-
- procedure Set_Field33 (N : Node_Id; Val : Union_Id) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- Nodes.Table (N + 5).Field9 := Val;
- end Set_Field33;
-
- procedure Set_Field34 (N : Node_Id; Val : Union_Id) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- Nodes.Table (N + 5).Field10 := Val;
- end Set_Field34;
-
- procedure Set_Field35 (N : Node_Id; Val : Union_Id) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- Nodes.Table (N + 5).Field11 := Val;
- end Set_Field35;
-
- procedure Set_Field36 (N : Node_Id; Val : Union_Id) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- Nodes.Table (N + 6).Field6 := Val;
- end Set_Field36;
-
- procedure Set_Field37 (N : Node_Id; Val : Union_Id) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- Nodes.Table (N + 6).Field7 := Val;
- end Set_Field37;
-
- procedure Set_Field38 (N : Node_Id; Val : Union_Id) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- Nodes.Table (N + 6).Field8 := Val;
- end Set_Field38;
-
- procedure Set_Field39 (N : Node_Id; Val : Union_Id) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- Nodes.Table (N + 6).Field9 := Val;
- end Set_Field39;
-
- procedure Set_Field40 (N : Node_Id; Val : Union_Id) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- Nodes.Table (N + 6).Field10 := Val;
- end Set_Field40;
-
- procedure Set_Field41 (N : Node_Id; Val : Union_Id) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- Nodes.Table (N + 6).Field11 := Val;
- end Set_Field41;
-
- procedure Set_Node1 (N : Node_Id; Val : Node_Id) is
- begin
- pragma Assert (not Locked);
- pragma Assert (N <= Nodes.Last);
- Nodes.Table (N).Field1 := Union_Id (Val);
- end Set_Node1;
-
- procedure Set_Node2 (N : Node_Id; Val : Node_Id) is
- begin
- pragma Assert (not Locked);
- pragma Assert (N <= Nodes.Last);
- Nodes.Table (N).Field2 := Union_Id (Val);
- end Set_Node2;
-
- procedure Set_Node3 (N : Node_Id; Val : Node_Id) is
- begin
- pragma Assert (not Locked);
- pragma Assert (N <= Nodes.Last);
- Nodes.Table (N).Field3 := Union_Id (Val);
- end Set_Node3;
-
- procedure Set_Node4 (N : Node_Id; Val : Node_Id) is
- begin
- pragma Assert (not Locked);
- pragma Assert (N <= Nodes.Last);
- Nodes.Table (N).Field4 := Union_Id (Val);
- end Set_Node4;
-
- procedure Set_Node5 (N : Node_Id; Val : Node_Id) is
- begin
- pragma Assert (not Locked);
- pragma Assert (N <= Nodes.Last);
- Nodes.Table (N).Field5 := Union_Id (Val);
- end Set_Node5;
-
- procedure Set_Node6 (N : Node_Id; Val : Node_Id) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- Nodes.Table (N + 1).Field6 := Union_Id (Val);
- end Set_Node6;
-
- procedure Set_Node7 (N : Node_Id; Val : Node_Id) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- Nodes.Table (N + 1).Field7 := Union_Id (Val);
- end Set_Node7;
-
- procedure Set_Node8 (N : Node_Id; Val : Node_Id) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- Nodes.Table (N + 1).Field8 := Union_Id (Val);
- end Set_Node8;
-
- procedure Set_Node9 (N : Node_Id; Val : Node_Id) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- Nodes.Table (N + 1).Field9 := Union_Id (Val);
- end Set_Node9;
-
- procedure Set_Node10 (N : Node_Id; Val : Node_Id) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- Nodes.Table (N + 1).Field10 := Union_Id (Val);
- end Set_Node10;
-
- procedure Set_Node11 (N : Node_Id; Val : Node_Id) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- Nodes.Table (N + 1).Field11 := Union_Id (Val);
- end Set_Node11;
-
- procedure Set_Node12 (N : Node_Id; Val : Node_Id) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- Nodes.Table (N + 1).Field12 := Union_Id (Val);
- end Set_Node12;
-
- procedure Set_Node13 (N : Node_Id; Val : Node_Id) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- Nodes.Table (N + 2).Field6 := Union_Id (Val);
- end Set_Node13;
-
- procedure Set_Node14 (N : Node_Id; Val : Node_Id) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- Nodes.Table (N + 2).Field7 := Union_Id (Val);
- end Set_Node14;
-
- procedure Set_Node15 (N : Node_Id; Val : Node_Id) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- Nodes.Table (N + 2).Field8 := Union_Id (Val);
- end Set_Node15;
-
- procedure Set_Node16 (N : Node_Id; Val : Node_Id) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- Nodes.Table (N + 2).Field9 := Union_Id (Val);
- end Set_Node16;
-
- procedure Set_Node17 (N : Node_Id; Val : Node_Id) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- Nodes.Table (N + 2).Field10 := Union_Id (Val);
- end Set_Node17;
-
- procedure Set_Node18 (N : Node_Id; Val : Node_Id) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- Nodes.Table (N + 2).Field11 := Union_Id (Val);
- end Set_Node18;
-
- procedure Set_Node19 (N : Node_Id; Val : Node_Id) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- Nodes.Table (N + 3).Field6 := Union_Id (Val);
- end Set_Node19;
-
- procedure Set_Node20 (N : Node_Id; Val : Node_Id) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- Nodes.Table (N + 3).Field7 := Union_Id (Val);
- end Set_Node20;
-
- procedure Set_Node21 (N : Node_Id; Val : Node_Id) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- Nodes.Table (N + 3).Field8 := Union_Id (Val);
- end Set_Node21;
-
- procedure Set_Node22 (N : Node_Id; Val : Node_Id) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- Nodes.Table (N + 3).Field9 := Union_Id (Val);
- end Set_Node22;
-
- procedure Set_Node23 (N : Node_Id; Val : Node_Id) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- Nodes.Table (N + 3).Field10 := Union_Id (Val);
- end Set_Node23;
-
- procedure Set_Node24 (N : Node_Id; Val : Node_Id) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- Nodes.Table (N + 4).Field6 := Union_Id (Val);
- end Set_Node24;
-
- procedure Set_Node25 (N : Node_Id; Val : Node_Id) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- Nodes.Table (N + 4).Field7 := Union_Id (Val);
- end Set_Node25;
-
- procedure Set_Node26 (N : Node_Id; Val : Node_Id) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- Nodes.Table (N + 4).Field8 := Union_Id (Val);
- end Set_Node26;
-
- procedure Set_Node27 (N : Node_Id; Val : Node_Id) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- Nodes.Table (N + 4).Field9 := Union_Id (Val);
- end Set_Node27;
-
- procedure Set_Node28 (N : Node_Id; Val : Node_Id) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- Nodes.Table (N + 4).Field10 := Union_Id (Val);
- end Set_Node28;
-
- procedure Set_Node29 (N : Node_Id; Val : Node_Id) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- Nodes.Table (N + 4).Field11 := Union_Id (Val);
- end Set_Node29;
-
- procedure Set_Node30 (N : Node_Id; Val : Node_Id) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- Nodes.Table (N + 5).Field6 := Union_Id (Val);
- end Set_Node30;
-
- procedure Set_Node31 (N : Node_Id; Val : Node_Id) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- Nodes.Table (N + 5).Field7 := Union_Id (Val);
- end Set_Node31;
-
- procedure Set_Node32 (N : Node_Id; Val : Node_Id) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- Nodes.Table (N + 5).Field8 := Union_Id (Val);
- end Set_Node32;
-
- procedure Set_Node33 (N : Node_Id; Val : Node_Id) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- Nodes.Table (N + 5).Field9 := Union_Id (Val);
- end Set_Node33;
-
- procedure Set_Node34 (N : Node_Id; Val : Node_Id) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- Nodes.Table (N + 5).Field10 := Union_Id (Val);
- end Set_Node34;
-
- procedure Set_Node35 (N : Node_Id; Val : Node_Id) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- Nodes.Table (N + 5).Field11 := Union_Id (Val);
- end Set_Node35;
-
- procedure Set_Node36 (N : Node_Id; Val : Node_Id) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- Nodes.Table (N + 6).Field6 := Union_Id (Val);
- end Set_Node36;
-
- procedure Set_Node37 (N : Node_Id; Val : Node_Id) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- Nodes.Table (N + 6).Field7 := Union_Id (Val);
- end Set_Node37;
-
- procedure Set_Node38 (N : Node_Id; Val : Node_Id) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- Nodes.Table (N + 6).Field8 := Union_Id (Val);
- end Set_Node38;
-
- procedure Set_Node39 (N : Node_Id; Val : Node_Id) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- Nodes.Table (N + 6).Field9 := Union_Id (Val);
- end Set_Node39;
-
- procedure Set_Node40 (N : Node_Id; Val : Node_Id) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- Nodes.Table (N + 6).Field10 := Union_Id (Val);
- end Set_Node40;
-
- procedure Set_Node41 (N : Node_Id; Val : Node_Id) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- Nodes.Table (N + 6).Field11 := Union_Id (Val);
- end Set_Node41;
-
- procedure Set_List1 (N : Node_Id; Val : List_Id) is
- begin
- pragma Assert (not Locked);
- pragma Assert (N <= Nodes.Last);
- Nodes.Table (N).Field1 := Union_Id (Val);
- end Set_List1;
-
- procedure Set_List2 (N : Node_Id; Val : List_Id) is
- begin
- pragma Assert (not Locked);
- pragma Assert (N <= Nodes.Last);
- Nodes.Table (N).Field2 := Union_Id (Val);
- end Set_List2;
-
- procedure Set_List3 (N : Node_Id; Val : List_Id) is
- begin
- pragma Assert (not Locked);
- pragma Assert (N <= Nodes.Last);
- Nodes.Table (N).Field3 := Union_Id (Val);
- end Set_List3;
-
- procedure Set_List4 (N : Node_Id; Val : List_Id) is
- begin
- pragma Assert (not Locked);
- pragma Assert (N <= Nodes.Last);
- Nodes.Table (N).Field4 := Union_Id (Val);
- end Set_List4;
-
- procedure Set_List5 (N : Node_Id; Val : List_Id) is
- begin
- pragma Assert (not Locked);
- pragma Assert (N <= Nodes.Last);
- Nodes.Table (N).Field5 := Union_Id (Val);
- end Set_List5;
-
- procedure Set_List10 (N : Node_Id; Val : List_Id) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- Nodes.Table (N + 1).Field10 := Union_Id (Val);
- end Set_List10;
-
- procedure Set_List14 (N : Node_Id; Val : List_Id) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- Nodes.Table (N + 2).Field7 := Union_Id (Val);
- end Set_List14;
-
- procedure Set_List25 (N : Node_Id; Val : List_Id) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- Nodes.Table (N + 4).Field7 := Union_Id (Val);
- end Set_List25;
-
- procedure Set_List38 (N : Node_Id; Val : List_Id) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- Nodes.Table (N + 6).Field8 := Union_Id (Val);
- end Set_List38;
-
- procedure Set_List39 (N : Node_Id; Val : List_Id) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- Nodes.Table (N + 6).Field9 := Union_Id (Val);
- end Set_List39;
-
- procedure Set_Elist1 (N : Node_Id; Val : Elist_Id) is
- begin
- pragma Assert (not Locked);
- Nodes.Table (N).Field1 := Union_Id (Val);
- end Set_Elist1;
-
- procedure Set_Elist2 (N : Node_Id; Val : Elist_Id) is
- begin
- pragma Assert (not Locked);
- Nodes.Table (N).Field2 := Union_Id (Val);
- end Set_Elist2;
-
- procedure Set_Elist3 (N : Node_Id; Val : Elist_Id) is
- begin
- pragma Assert (not Locked);
- Nodes.Table (N).Field3 := Union_Id (Val);
- end Set_Elist3;
-
- procedure Set_Elist4 (N : Node_Id; Val : Elist_Id) is
- begin
- pragma Assert (not Locked);
- Nodes.Table (N).Field4 := Union_Id (Val);
- end Set_Elist4;
-
- procedure Set_Elist5 (N : Node_Id; Val : Elist_Id) is
- begin
- pragma Assert (not Locked);
- Nodes.Table (N).Field5 := Union_Id (Val);
- end Set_Elist5;
-
- procedure Set_Elist8 (N : Node_Id; Val : Elist_Id) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- Nodes.Table (N + 1).Field8 := Union_Id (Val);
- end Set_Elist8;
-
- procedure Set_Elist9 (N : Node_Id; Val : Elist_Id) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- Nodes.Table (N + 1).Field9 := Union_Id (Val);
- end Set_Elist9;
-
- procedure Set_Elist10 (N : Node_Id; Val : Elist_Id) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- Nodes.Table (N + 1).Field10 := Union_Id (Val);
- end Set_Elist10;
-
- procedure Set_Elist11 (N : Node_Id; Val : Elist_Id) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- Nodes.Table (N + 1).Field11 := Union_Id (Val);
- end Set_Elist11;
-
- procedure Set_Elist13 (N : Node_Id; Val : Elist_Id) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- Nodes.Table (N + 2).Field6 := Union_Id (Val);
- end Set_Elist13;
-
- procedure Set_Elist15 (N : Node_Id; Val : Elist_Id) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- Nodes.Table (N + 2).Field8 := Union_Id (Val);
- end Set_Elist15;
-
- procedure Set_Elist16 (N : Node_Id; Val : Elist_Id) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- Nodes.Table (N + 2).Field9 := Union_Id (Val);
- end Set_Elist16;
-
- procedure Set_Elist18 (N : Node_Id; Val : Elist_Id) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- Nodes.Table (N + 2).Field11 := Union_Id (Val);
- end Set_Elist18;
-
- procedure Set_Elist21 (N : Node_Id; Val : Elist_Id) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- Nodes.Table (N + 3).Field8 := Union_Id (Val);
- end Set_Elist21;
-
- procedure Set_Elist23 (N : Node_Id; Val : Elist_Id) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- Nodes.Table (N + 3).Field10 := Union_Id (Val);
- end Set_Elist23;
-
- procedure Set_Elist24 (N : Node_Id; Val : Elist_Id) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- Nodes.Table (N + 4).Field6 := Union_Id (Val);
- end Set_Elist24;
-
- procedure Set_Elist25 (N : Node_Id; Val : Elist_Id) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- Nodes.Table (N + 4).Field7 := Union_Id (Val);
- end Set_Elist25;
-
- procedure Set_Elist26 (N : Node_Id; Val : Elist_Id) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- Nodes.Table (N + 4).Field8 := Union_Id (Val);
- end Set_Elist26;
-
- procedure Set_Elist29 (N : Node_Id; Val : Elist_Id) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- Nodes.Table (N + 4).Field11 := Union_Id (Val);
- end Set_Elist29;
-
- procedure Set_Elist30 (N : Node_Id; Val : Elist_Id) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- Nodes.Table (N + 5).Field6 := Union_Id (Val);
- end Set_Elist30;
-
- procedure Set_Elist36 (N : Node_Id; Val : Elist_Id) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- Nodes.Table (N + 6).Field6 := Union_Id (Val);
- end Set_Elist36;
-
- procedure Set_Name1 (N : Node_Id; Val : Name_Id) is
- begin
- pragma Assert (not Locked);
- pragma Assert (N <= Nodes.Last);
- Nodes.Table (N).Field1 := Union_Id (Val);
- end Set_Name1;
-
- procedure Set_Name2 (N : Node_Id; Val : Name_Id) is
- begin
- pragma Assert (not Locked);
- pragma Assert (N <= Nodes.Last);
- Nodes.Table (N).Field2 := Union_Id (Val);
- end Set_Name2;
-
- procedure Set_Str3 (N : Node_Id; Val : String_Id) is
- begin
- pragma Assert (not Locked);
- pragma Assert (N <= Nodes.Last);
- Nodes.Table (N).Field3 := Union_Id (Val);
- end Set_Str3;
-
- procedure Set_Uint2 (N : Node_Id; Val : Uint) is
- begin
- pragma Assert (not Locked);
- pragma Assert (N <= Nodes.Last);
- Nodes.Table (N).Field2 := To_Union (Val);
- end Set_Uint2;
-
- procedure Set_Uint3 (N : Node_Id; Val : Uint) is
- begin
- pragma Assert (not Locked);
- pragma Assert (N <= Nodes.Last);
- Nodes.Table (N).Field3 := To_Union (Val);
- end Set_Uint3;
-
- procedure Set_Uint4 (N : Node_Id; Val : Uint) is
- begin
- pragma Assert (not Locked);
- pragma Assert (N <= Nodes.Last);
- Nodes.Table (N).Field4 := To_Union (Val);
- end Set_Uint4;
-
- procedure Set_Uint5 (N : Node_Id; Val : Uint) is
- begin
- pragma Assert (not Locked);
- pragma Assert (N <= Nodes.Last);
- Nodes.Table (N).Field5 := To_Union (Val);
- end Set_Uint5;
-
- procedure Set_Uint8 (N : Node_Id; Val : Uint) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- Nodes.Table (N + 1).Field8 := To_Union (Val);
- end Set_Uint8;
-
- procedure Set_Uint9 (N : Node_Id; Val : Uint) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- Nodes.Table (N + 1).Field9 := To_Union (Val);
- end Set_Uint9;
-
- procedure Set_Uint10 (N : Node_Id; Val : Uint) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- Nodes.Table (N + 1).Field10 := To_Union (Val);
- end Set_Uint10;
-
- procedure Set_Uint11 (N : Node_Id; Val : Uint) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- Nodes.Table (N + 1).Field11 := To_Union (Val);
- end Set_Uint11;
-
- procedure Set_Uint12 (N : Node_Id; Val : Uint) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- Nodes.Table (N + 1).Field12 := To_Union (Val);
- end Set_Uint12;
-
- procedure Set_Uint13 (N : Node_Id; Val : Uint) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- Nodes.Table (N + 2).Field6 := To_Union (Val);
- end Set_Uint13;
-
- procedure Set_Uint14 (N : Node_Id; Val : Uint) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- Nodes.Table (N + 2).Field7 := To_Union (Val);
- end Set_Uint14;
-
- procedure Set_Uint15 (N : Node_Id; Val : Uint) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- Nodes.Table (N + 2).Field8 := To_Union (Val);
- end Set_Uint15;
-
- procedure Set_Uint16 (N : Node_Id; Val : Uint) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- Nodes.Table (N + 2).Field9 := To_Union (Val);
- end Set_Uint16;
-
- procedure Set_Uint17 (N : Node_Id; Val : Uint) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- Nodes.Table (N + 2).Field10 := To_Union (Val);
- end Set_Uint17;
-
- procedure Set_Uint22 (N : Node_Id; Val : Uint) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- Nodes.Table (N + 3).Field9 := To_Union (Val);
- end Set_Uint22;
-
- procedure Set_Uint24 (N : Node_Id; Val : Uint) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- Nodes.Table (N + 4).Field6 := To_Union (Val);
- end Set_Uint24;
-
- procedure Set_Ureal3 (N : Node_Id; Val : Ureal) is
- begin
- pragma Assert (not Locked);
- pragma Assert (N <= Nodes.Last);
- Nodes.Table (N).Field3 := To_Union (Val);
- end Set_Ureal3;
-
- procedure Set_Ureal18 (N : Node_Id; Val : Ureal) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- Nodes.Table (N + 2).Field11 := To_Union (Val);
- end Set_Ureal18;
-
- procedure Set_Ureal21 (N : Node_Id; Val : Ureal) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- Nodes.Table (N + 3).Field8 := To_Union (Val);
- end Set_Ureal21;
-
- procedure Set_Flag0 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (N <= Nodes.Last);
- Flags.Table (N).Flag0 := Val;
- end Set_Flag0;
-
- procedure Set_Flag1 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (N <= Nodes.Last);
- Flags.Table (N).Flag1 := Val;
- end Set_Flag1;
-
- procedure Set_Flag2 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (N <= Nodes.Last);
- Flags.Table (N).Flag2 := Val;
- end Set_Flag2;
-
- procedure Set_Flag3 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (N <= Nodes.Last);
- Flags.Table (N).Flag3 := Val;
- end Set_Flag3;
-
- procedure Set_Flag4 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (N <= Nodes.Last);
- Nodes.Table (N).Flag4 := Val;
- end Set_Flag4;
-
- procedure Set_Flag5 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (N <= Nodes.Last);
- Nodes.Table (N).Flag5 := Val;
- end Set_Flag5;
-
- procedure Set_Flag6 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (N <= Nodes.Last);
- Nodes.Table (N).Flag6 := Val;
- end Set_Flag6;
-
- procedure Set_Flag7 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (N <= Nodes.Last);
- Nodes.Table (N).Flag7 := Val;
- end Set_Flag7;
-
- procedure Set_Flag8 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (N <= Nodes.Last);
- Nodes.Table (N).Flag8 := Val;
- end Set_Flag8;
-
- procedure Set_Flag9 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (N <= Nodes.Last);
- Nodes.Table (N).Flag9 := Val;
- end Set_Flag9;
-
- procedure Set_Flag10 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (N <= Nodes.Last);
- Nodes.Table (N).Flag10 := Val;
- end Set_Flag10;
-
- procedure Set_Flag11 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (N <= Nodes.Last);
- Nodes.Table (N).Flag11 := Val;
- end Set_Flag11;
-
- procedure Set_Flag12 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (N <= Nodes.Last);
- Nodes.Table (N).Flag12 := Val;
- end Set_Flag12;
-
- procedure Set_Flag13 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (N <= Nodes.Last);
- Nodes.Table (N).Flag13 := Val;
- end Set_Flag13;
-
- procedure Set_Flag14 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (N <= Nodes.Last);
- Nodes.Table (N).Flag14 := Val;
- end Set_Flag14;
-
- procedure Set_Flag15 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (N <= Nodes.Last);
- Nodes.Table (N).Flag15 := Val;
- end Set_Flag15;
-
- procedure Set_Flag16 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (N <= Nodes.Last);
- Nodes.Table (N).Flag16 := Val;
- end Set_Flag16;
-
- procedure Set_Flag17 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (N <= Nodes.Last);
- Nodes.Table (N).Flag17 := Val;
- end Set_Flag17;
-
- procedure Set_Flag18 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (N <= Nodes.Last);
- Nodes.Table (N).Flag18 := Val;
- end Set_Flag18;
-
- procedure Set_Flag19 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- Nodes.Table (N + 1).In_List := Val;
- end Set_Flag19;
-
- procedure Set_Flag20 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- Nodes.Table (N + 1).Has_Aspects := Val;
- end Set_Flag20;
-
- procedure Set_Flag21 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- Nodes.Table (N + 1).Rewrite_Ins := Val;
- end Set_Flag21;
-
- procedure Set_Flag22 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- Nodes.Table (N + 1).Analyzed := Val;
- end Set_Flag22;
-
- procedure Set_Flag23 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- Nodes.Table (N + 1).Comes_From_Source := Val;
- end Set_Flag23;
-
- procedure Set_Flag24 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- Nodes.Table (N + 1).Error_Posted := Val;
- end Set_Flag24;
-
- procedure Set_Flag25 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- Nodes.Table (N + 1).Flag4 := Val;
- end Set_Flag25;
-
- procedure Set_Flag26 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- Nodes.Table (N + 1).Flag5 := Val;
- end Set_Flag26;
-
- procedure Set_Flag27 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- Nodes.Table (N + 1).Flag6 := Val;
- end Set_Flag27;
-
- procedure Set_Flag28 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- Nodes.Table (N + 1).Flag7 := Val;
- end Set_Flag28;
-
- procedure Set_Flag29 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- Nodes.Table (N + 1).Flag8 := Val;
- end Set_Flag29;
-
- procedure Set_Flag30 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- Nodes.Table (N + 1).Flag9 := Val;
- end Set_Flag30;
-
- procedure Set_Flag31 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- Nodes.Table (N + 1).Flag10 := Val;
- end Set_Flag31;
-
- procedure Set_Flag32 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- Nodes.Table (N + 1).Flag11 := Val;
- end Set_Flag32;
-
- procedure Set_Flag33 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- Nodes.Table (N + 1).Flag12 := Val;
- end Set_Flag33;
-
- procedure Set_Flag34 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- Nodes.Table (N + 1).Flag13 := Val;
- end Set_Flag34;
-
- procedure Set_Flag35 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- Nodes.Table (N + 1).Flag14 := Val;
- end Set_Flag35;
-
- procedure Set_Flag36 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- Nodes.Table (N + 1).Flag15 := Val;
- end Set_Flag36;
-
- procedure Set_Flag37 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- Nodes.Table (N + 1).Flag16 := Val;
- end Set_Flag37;
-
- procedure Set_Flag38 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- Nodes.Table (N + 1).Flag17 := Val;
- end Set_Flag38;
-
- procedure Set_Flag39 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- Nodes.Table (N + 1).Flag18 := Val;
- end Set_Flag39;
-
- procedure Set_Flag40 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- Nodes.Table (N + 2).In_List := Val;
- end Set_Flag40;
-
- procedure Set_Flag41 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- Nodes.Table (N + 2).Has_Aspects := Val;
- end Set_Flag41;
-
- procedure Set_Flag42 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- Nodes.Table (N + 2).Rewrite_Ins := Val;
- end Set_Flag42;
-
- procedure Set_Flag43 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- Nodes.Table (N + 2).Analyzed := Val;
- end Set_Flag43;
-
- procedure Set_Flag44 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- Nodes.Table (N + 2).Comes_From_Source := Val;
- end Set_Flag44;
-
- procedure Set_Flag45 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- Nodes.Table (N + 2).Error_Posted := Val;
- end Set_Flag45;
-
- procedure Set_Flag46 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- Nodes.Table (N + 2).Flag4 := Val;
- end Set_Flag46;
-
- procedure Set_Flag47 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- Nodes.Table (N + 2).Flag5 := Val;
- end Set_Flag47;
-
- procedure Set_Flag48 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- Nodes.Table (N + 2).Flag6 := Val;
- end Set_Flag48;
-
- procedure Set_Flag49 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- Nodes.Table (N + 2).Flag7 := Val;
- end Set_Flag49;
-
- procedure Set_Flag50 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- Nodes.Table (N + 2).Flag8 := Val;
- end Set_Flag50;
-
- procedure Set_Flag51 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- Nodes.Table (N + 2).Flag9 := Val;
- end Set_Flag51;
-
- procedure Set_Flag52 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- Nodes.Table (N + 2).Flag10 := Val;
- end Set_Flag52;
-
- procedure Set_Flag53 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- Nodes.Table (N + 2).Flag11 := Val;
- end Set_Flag53;
-
- procedure Set_Flag54 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- Nodes.Table (N + 2).Flag12 := Val;
- end Set_Flag54;
-
- procedure Set_Flag55 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- Nodes.Table (N + 2).Flag13 := Val;
- end Set_Flag55;
-
- procedure Set_Flag56 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- Nodes.Table (N + 2).Flag14 := Val;
- end Set_Flag56;
-
- procedure Set_Flag57 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- Nodes.Table (N + 2).Flag15 := Val;
- end Set_Flag57;
-
- procedure Set_Flag58 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- Nodes.Table (N + 2).Flag16 := Val;
- end Set_Flag58;
-
- procedure Set_Flag59 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- Nodes.Table (N + 2).Flag17 := Val;
- end Set_Flag59;
-
- procedure Set_Flag60 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- Nodes.Table (N + 2).Flag18 := Val;
- end Set_Flag60;
-
- procedure Set_Flag61 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- Nodes.Table (N + 1).Pflag1 := Val;
- end Set_Flag61;
-
- procedure Set_Flag62 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- Nodes.Table (N + 1).Pflag2 := Val;
- end Set_Flag62;
-
- procedure Set_Flag63 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- Nodes.Table (N + 2).Pflag1 := Val;
- end Set_Flag63;
-
- procedure Set_Flag64 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- Nodes.Table (N + 2).Pflag2 := Val;
- end Set_Flag64;
-
- procedure Set_Flag65 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- To_Flag_Byte_Ptr
- (Node_Kind_Ptr'
- (Nodes.Table (N + 2).Nkind'Unrestricted_Access)).Flag65 := Val;
- end Set_Flag65;
-
- procedure Set_Flag66 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- To_Flag_Byte_Ptr
- (Node_Kind_Ptr'
- (Nodes.Table (N + 2).Nkind'Unrestricted_Access)).Flag66 := Val;
- end Set_Flag66;
-
- procedure Set_Flag67 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- To_Flag_Byte_Ptr
- (Node_Kind_Ptr'
- (Nodes.Table (N + 2).Nkind'Unrestricted_Access)).Flag67 := Val;
- end Set_Flag67;
-
- procedure Set_Flag68 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- To_Flag_Byte_Ptr
- (Node_Kind_Ptr'
- (Nodes.Table (N + 2).Nkind'Unrestricted_Access)).Flag68 := Val;
- end Set_Flag68;
-
- procedure Set_Flag69 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- To_Flag_Byte_Ptr
- (Node_Kind_Ptr'
- (Nodes.Table (N + 2).Nkind'Unrestricted_Access)).Flag69 := Val;
- end Set_Flag69;
-
- procedure Set_Flag70 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- To_Flag_Byte_Ptr
- (Node_Kind_Ptr'
- (Nodes.Table (N + 2).Nkind'Unrestricted_Access)).Flag70 := Val;
- end Set_Flag70;
-
- procedure Set_Flag71 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- To_Flag_Byte_Ptr
- (Node_Kind_Ptr'
- (Nodes.Table (N + 2).Nkind'Unrestricted_Access)).Flag71 := Val;
- end Set_Flag71;
-
- procedure Set_Flag72 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- To_Flag_Byte_Ptr
- (Node_Kind_Ptr'
- (Nodes.Table (N + 2).Nkind'Unrestricted_Access)).Flag72 := Val;
- end Set_Flag72;
-
- procedure Set_Flag73 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- To_Flag_Word_Ptr
- (Union_Id_Ptr'
- (Nodes.Table (N + 2).Field12'Unrestricted_Access)).Flag73 := Val;
- end Set_Flag73;
-
- procedure Set_Flag74 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- To_Flag_Word_Ptr
- (Union_Id_Ptr'
- (Nodes.Table (N + 2).Field12'Unrestricted_Access)).Flag74 := Val;
- end Set_Flag74;
-
- procedure Set_Flag75 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- To_Flag_Word_Ptr
- (Union_Id_Ptr'
- (Nodes.Table (N + 2).Field12'Unrestricted_Access)).Flag75 := Val;
- end Set_Flag75;
-
- procedure Set_Flag76 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- To_Flag_Word_Ptr
- (Union_Id_Ptr'
- (Nodes.Table (N + 2).Field12'Unrestricted_Access)).Flag76 := Val;
- end Set_Flag76;
-
- procedure Set_Flag77 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- To_Flag_Word_Ptr
- (Union_Id_Ptr'
- (Nodes.Table (N + 2).Field12'Unrestricted_Access)).Flag77 := Val;
- end Set_Flag77;
-
- procedure Set_Flag78 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- To_Flag_Word_Ptr
- (Union_Id_Ptr'
- (Nodes.Table (N + 2).Field12'Unrestricted_Access)).Flag78 := Val;
- end Set_Flag78;
-
- procedure Set_Flag79 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- To_Flag_Word_Ptr
- (Union_Id_Ptr'
- (Nodes.Table (N + 2).Field12'Unrestricted_Access)).Flag79 := Val;
- end Set_Flag79;
-
- procedure Set_Flag80 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- To_Flag_Word_Ptr
- (Union_Id_Ptr'
- (Nodes.Table (N + 2).Field12'Unrestricted_Access)).Flag80 := Val;
- end Set_Flag80;
-
- procedure Set_Flag81 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- To_Flag_Word_Ptr
- (Union_Id_Ptr'
- (Nodes.Table (N + 2).Field12'Unrestricted_Access)).Flag81 := Val;
- end Set_Flag81;
-
- procedure Set_Flag82 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- To_Flag_Word_Ptr
- (Union_Id_Ptr'
- (Nodes.Table (N + 2).Field12'Unrestricted_Access)).Flag82 := Val;
- end Set_Flag82;
-
- procedure Set_Flag83 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- To_Flag_Word_Ptr
- (Union_Id_Ptr'
- (Nodes.Table (N + 2).Field12'Unrestricted_Access)).Flag83 := Val;
- end Set_Flag83;
-
- procedure Set_Flag84 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- To_Flag_Word_Ptr
- (Union_Id_Ptr'
- (Nodes.Table (N + 2).Field12'Unrestricted_Access)).Flag84 := Val;
- end Set_Flag84;
-
- procedure Set_Flag85 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- To_Flag_Word_Ptr
- (Union_Id_Ptr'
- (Nodes.Table (N + 2).Field12'Unrestricted_Access)).Flag85 := Val;
- end Set_Flag85;
-
- procedure Set_Flag86 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- To_Flag_Word_Ptr
- (Union_Id_Ptr'
- (Nodes.Table (N + 2).Field12'Unrestricted_Access)).Flag86 := Val;
- end Set_Flag86;
-
- procedure Set_Flag87 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- To_Flag_Word_Ptr
- (Union_Id_Ptr'
- (Nodes.Table (N + 2).Field12'Unrestricted_Access)).Flag87 := Val;
- end Set_Flag87;
-
- procedure Set_Flag88 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- To_Flag_Word_Ptr
- (Union_Id_Ptr'
- (Nodes.Table (N + 2).Field12'Unrestricted_Access)).Flag88 := Val;
- end Set_Flag88;
-
- procedure Set_Flag89 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- To_Flag_Word_Ptr
- (Union_Id_Ptr'
- (Nodes.Table (N + 2).Field12'Unrestricted_Access)).Flag89 := Val;
- end Set_Flag89;
-
- procedure Set_Flag90 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- To_Flag_Word_Ptr
- (Union_Id_Ptr'
- (Nodes.Table (N + 2).Field12'Unrestricted_Access)).Flag90 := Val;
- end Set_Flag90;
-
- procedure Set_Flag91 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- To_Flag_Word_Ptr
- (Union_Id_Ptr'
- (Nodes.Table (N + 2).Field12'Unrestricted_Access)).Flag91 := Val;
- end Set_Flag91;
-
- procedure Set_Flag92 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- To_Flag_Word_Ptr
- (Union_Id_Ptr'
- (Nodes.Table (N + 2).Field12'Unrestricted_Access)).Flag92 := Val;
- end Set_Flag92;
-
- procedure Set_Flag93 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- To_Flag_Word_Ptr
- (Union_Id_Ptr'
- (Nodes.Table (N + 2).Field12'Unrestricted_Access)).Flag93 := Val;
- end Set_Flag93;
-
- procedure Set_Flag94 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- To_Flag_Word_Ptr
- (Union_Id_Ptr'
- (Nodes.Table (N + 2).Field12'Unrestricted_Access)).Flag94 := Val;
- end Set_Flag94;
-
- procedure Set_Flag95 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- To_Flag_Word_Ptr
- (Union_Id_Ptr'
- (Nodes.Table (N + 2).Field12'Unrestricted_Access)).Flag95 := Val;
- end Set_Flag95;
-
- procedure Set_Flag96 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- To_Flag_Word_Ptr
- (Union_Id_Ptr'
- (Nodes.Table (N + 2).Field12'Unrestricted_Access)).Flag96 := Val;
- end Set_Flag96;
-
- procedure Set_Flag97 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- To_Flag_Word2_Ptr
- (Union_Id_Ptr'
- (Nodes.Table (N + 3).Field12'Unrestricted_Access)).Flag97 := Val;
- end Set_Flag97;
-
- procedure Set_Flag98 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- To_Flag_Word2_Ptr
- (Union_Id_Ptr'
- (Nodes.Table (N + 3).Field12'Unrestricted_Access)).Flag98 := Val;
- end Set_Flag98;
-
- procedure Set_Flag99 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- To_Flag_Word2_Ptr
- (Union_Id_Ptr'
- (Nodes.Table (N + 3).Field12'Unrestricted_Access)).Flag99 := Val;
- end Set_Flag99;
-
- procedure Set_Flag100 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- To_Flag_Word2_Ptr
- (Union_Id_Ptr'
- (Nodes.Table (N + 3).Field12'Unrestricted_Access)).Flag100 := Val;
- end Set_Flag100;
-
- procedure Set_Flag101 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- To_Flag_Word2_Ptr
- (Union_Id_Ptr'
- (Nodes.Table (N + 3).Field12'Unrestricted_Access)).Flag101 := Val;
- end Set_Flag101;
-
- procedure Set_Flag102 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- To_Flag_Word2_Ptr
- (Union_Id_Ptr'
- (Nodes.Table (N + 3).Field12'Unrestricted_Access)).Flag102 := Val;
- end Set_Flag102;
-
- procedure Set_Flag103 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- To_Flag_Word2_Ptr
- (Union_Id_Ptr'
- (Nodes.Table (N + 3).Field12'Unrestricted_Access)).Flag103 := Val;
- end Set_Flag103;
-
- procedure Set_Flag104 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- To_Flag_Word2_Ptr
- (Union_Id_Ptr'
- (Nodes.Table (N + 3).Field12'Unrestricted_Access)).Flag104 := Val;
- end Set_Flag104;
-
- procedure Set_Flag105 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- To_Flag_Word2_Ptr
- (Union_Id_Ptr'
- (Nodes.Table (N + 3).Field12'Unrestricted_Access)).Flag105 := Val;
- end Set_Flag105;
-
- procedure Set_Flag106 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- To_Flag_Word2_Ptr
- (Union_Id_Ptr'
- (Nodes.Table (N + 3).Field12'Unrestricted_Access)).Flag106 := Val;
- end Set_Flag106;
-
- procedure Set_Flag107 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- To_Flag_Word2_Ptr
- (Union_Id_Ptr'
- (Nodes.Table (N + 3).Field12'Unrestricted_Access)).Flag107 := Val;
- end Set_Flag107;
-
- procedure Set_Flag108 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- To_Flag_Word2_Ptr
- (Union_Id_Ptr'
- (Nodes.Table (N + 3).Field12'Unrestricted_Access)).Flag108 := Val;
- end Set_Flag108;
-
- procedure Set_Flag109 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- To_Flag_Word2_Ptr
- (Union_Id_Ptr'
- (Nodes.Table (N + 3).Field12'Unrestricted_Access)).Flag109 := Val;
- end Set_Flag109;
-
- procedure Set_Flag110 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- To_Flag_Word2_Ptr
- (Union_Id_Ptr'
- (Nodes.Table (N + 3).Field12'Unrestricted_Access)).Flag110 := Val;
- end Set_Flag110;
-
- procedure Set_Flag111 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- To_Flag_Word2_Ptr
- (Union_Id_Ptr'
- (Nodes.Table (N + 3).Field12'Unrestricted_Access)).Flag111 := Val;
- end Set_Flag111;
-
- procedure Set_Flag112 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- To_Flag_Word2_Ptr
- (Union_Id_Ptr'
- (Nodes.Table (N + 3).Field12'Unrestricted_Access)).Flag112 := Val;
- end Set_Flag112;
-
- procedure Set_Flag113 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- To_Flag_Word2_Ptr
- (Union_Id_Ptr'
- (Nodes.Table (N + 3).Field12'Unrestricted_Access)).Flag113 := Val;
- end Set_Flag113;
-
- procedure Set_Flag114 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- To_Flag_Word2_Ptr
- (Union_Id_Ptr'
- (Nodes.Table (N + 3).Field12'Unrestricted_Access)).Flag114 := Val;
- end Set_Flag114;
-
- procedure Set_Flag115 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- To_Flag_Word2_Ptr
- (Union_Id_Ptr'
- (Nodes.Table (N + 3).Field12'Unrestricted_Access)).Flag115 := Val;
- end Set_Flag115;
-
- procedure Set_Flag116 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- To_Flag_Word2_Ptr
- (Union_Id_Ptr'
- (Nodes.Table (N + 3).Field12'Unrestricted_Access)).Flag116 := Val;
- end Set_Flag116;
-
- procedure Set_Flag117 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- To_Flag_Word2_Ptr
- (Union_Id_Ptr'
- (Nodes.Table (N + 3).Field12'Unrestricted_Access)).Flag117 := Val;
- end Set_Flag117;
-
- procedure Set_Flag118 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- To_Flag_Word2_Ptr
- (Union_Id_Ptr'
- (Nodes.Table (N + 3).Field12'Unrestricted_Access)).Flag118 := Val;
- end Set_Flag118;
-
- procedure Set_Flag119 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- To_Flag_Word2_Ptr
- (Union_Id_Ptr'
- (Nodes.Table (N + 3).Field12'Unrestricted_Access)).Flag119 := Val;
- end Set_Flag119;
-
- procedure Set_Flag120 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- To_Flag_Word2_Ptr
- (Union_Id_Ptr'
- (Nodes.Table (N + 3).Field12'Unrestricted_Access)).Flag120 := Val;
- end Set_Flag120;
-
- procedure Set_Flag121 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- To_Flag_Word2_Ptr
- (Union_Id_Ptr'
- (Nodes.Table (N + 3).Field12'Unrestricted_Access)).Flag121 := Val;
- end Set_Flag121;
-
- procedure Set_Flag122 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- To_Flag_Word2_Ptr
- (Union_Id_Ptr'
- (Nodes.Table (N + 3).Field12'Unrestricted_Access)).Flag122 := Val;
- end Set_Flag122;
-
- procedure Set_Flag123 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- To_Flag_Word2_Ptr
- (Union_Id_Ptr'
- (Nodes.Table (N + 3).Field12'Unrestricted_Access)).Flag123 := Val;
- end Set_Flag123;
-
- procedure Set_Flag124 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- To_Flag_Word2_Ptr
- (Union_Id_Ptr'
- (Nodes.Table (N + 3).Field12'Unrestricted_Access)).Flag124 := Val;
- end Set_Flag124;
-
- procedure Set_Flag125 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- To_Flag_Word2_Ptr
- (Union_Id_Ptr'
- (Nodes.Table (N + 3).Field12'Unrestricted_Access)).Flag125 := Val;
- end Set_Flag125;
-
- procedure Set_Flag126 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- To_Flag_Word2_Ptr
- (Union_Id_Ptr'
- (Nodes.Table (N + 3).Field12'Unrestricted_Access)).Flag126 := Val;
- end Set_Flag126;
-
- procedure Set_Flag127 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- To_Flag_Word2_Ptr
- (Union_Id_Ptr'
- (Nodes.Table (N + 3).Field12'Unrestricted_Access)).Flag127 := Val;
- end Set_Flag127;
-
- procedure Set_Flag128 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- To_Flag_Word2_Ptr
- (Union_Id_Ptr'
- (Nodes.Table (N + 3).Field12'Unrestricted_Access)).Flag128 := Val;
- end Set_Flag128;
-
- procedure Set_Flag129 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- Nodes.Table (N + 3).In_List := Val;
- end Set_Flag129;
-
- procedure Set_Flag130 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- Nodes.Table (N + 3).Has_Aspects := Val;
- end Set_Flag130;
-
- procedure Set_Flag131 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- Nodes.Table (N + 3).Rewrite_Ins := Val;
- end Set_Flag131;
-
- procedure Set_Flag132 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- Nodes.Table (N + 3).Analyzed := Val;
- end Set_Flag132;
-
- procedure Set_Flag133 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- Nodes.Table (N + 3).Comes_From_Source := Val;
- end Set_Flag133;
-
- procedure Set_Flag134 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- Nodes.Table (N + 3).Error_Posted := Val;
- end Set_Flag134;
-
- procedure Set_Flag135 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- Nodes.Table (N + 3).Flag4 := Val;
- end Set_Flag135;
-
- procedure Set_Flag136 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- Nodes.Table (N + 3).Flag5 := Val;
- end Set_Flag136;
-
- procedure Set_Flag137 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- Nodes.Table (N + 3).Flag6 := Val;
- end Set_Flag137;
-
- procedure Set_Flag138 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- Nodes.Table (N + 3).Flag7 := Val;
- end Set_Flag138;
-
- procedure Set_Flag139 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- Nodes.Table (N + 3).Flag8 := Val;
- end Set_Flag139;
-
- procedure Set_Flag140 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- Nodes.Table (N + 3).Flag9 := Val;
- end Set_Flag140;
-
- procedure Set_Flag141 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- Nodes.Table (N + 3).Flag10 := Val;
- end Set_Flag141;
-
- procedure Set_Flag142 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- Nodes.Table (N + 3).Flag11 := Val;
- end Set_Flag142;
-
- procedure Set_Flag143 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- Nodes.Table (N + 3).Flag12 := Val;
- end Set_Flag143;
-
- procedure Set_Flag144 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- Nodes.Table (N + 3).Flag13 := Val;
- end Set_Flag144;
-
- procedure Set_Flag145 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- Nodes.Table (N + 3).Flag14 := Val;
- end Set_Flag145;
-
- procedure Set_Flag146 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- Nodes.Table (N + 3).Flag15 := Val;
- end Set_Flag146;
-
- procedure Set_Flag147 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- Nodes.Table (N + 3).Flag16 := Val;
- end Set_Flag147;
-
- procedure Set_Flag148 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- Nodes.Table (N + 3).Flag17 := Val;
- end Set_Flag148;
-
- procedure Set_Flag149 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- Nodes.Table (N + 3).Flag18 := Val;
- end Set_Flag149;
-
- procedure Set_Flag150 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- Nodes.Table (N + 3).Pflag1 := Val;
- end Set_Flag150;
-
- procedure Set_Flag151 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- Nodes.Table (N + 3).Pflag2 := Val;
- end Set_Flag151;
-
- procedure Set_Flag152 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- To_Flag_Word3_Ptr
- (Union_Id_Ptr'
- (Nodes.Table (N + 3).Field11'Unrestricted_Access)).Flag152 := Val;
- end Set_Flag152;
-
- procedure Set_Flag153 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- To_Flag_Word3_Ptr
- (Union_Id_Ptr'
- (Nodes.Table (N + 3).Field11'Unrestricted_Access)).Flag153 := Val;
- end Set_Flag153;
-
- procedure Set_Flag154 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- To_Flag_Word3_Ptr
- (Union_Id_Ptr'
- (Nodes.Table (N + 3).Field11'Unrestricted_Access)).Flag154 := Val;
- end Set_Flag154;
-
- procedure Set_Flag155 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- To_Flag_Word3_Ptr
- (Union_Id_Ptr'
- (Nodes.Table (N + 3).Field11'Unrestricted_Access)).Flag155 := Val;
- end Set_Flag155;
-
- procedure Set_Flag156 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- To_Flag_Word3_Ptr
- (Union_Id_Ptr'
- (Nodes.Table (N + 3).Field11'Unrestricted_Access)).Flag156 := Val;
- end Set_Flag156;
-
- procedure Set_Flag157 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- To_Flag_Word3_Ptr
- (Union_Id_Ptr'
- (Nodes.Table (N + 3).Field11'Unrestricted_Access)).Flag157 := Val;
- end Set_Flag157;
-
- procedure Set_Flag158 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- To_Flag_Word3_Ptr
- (Union_Id_Ptr'
- (Nodes.Table (N + 3).Field11'Unrestricted_Access)).Flag158 := Val;
- end Set_Flag158;
-
- procedure Set_Flag159 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- To_Flag_Word3_Ptr
- (Union_Id_Ptr'
- (Nodes.Table (N + 3).Field11'Unrestricted_Access)).Flag159 := Val;
- end Set_Flag159;
-
- procedure Set_Flag160 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- To_Flag_Word3_Ptr
- (Union_Id_Ptr'
- (Nodes.Table (N + 3).Field11'Unrestricted_Access)).Flag160 := Val;
- end Set_Flag160;
-
- procedure Set_Flag161 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- To_Flag_Word3_Ptr
- (Union_Id_Ptr'
- (Nodes.Table (N + 3).Field11'Unrestricted_Access)).Flag161 := Val;
- end Set_Flag161;
-
- procedure Set_Flag162 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- To_Flag_Word3_Ptr
- (Union_Id_Ptr'
- (Nodes.Table (N + 3).Field11'Unrestricted_Access)).Flag162 := Val;
- end Set_Flag162;
-
- procedure Set_Flag163 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- To_Flag_Word3_Ptr
- (Union_Id_Ptr'
- (Nodes.Table (N + 3).Field11'Unrestricted_Access)).Flag163 := Val;
- end Set_Flag163;
-
- procedure Set_Flag164 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- To_Flag_Word3_Ptr
- (Union_Id_Ptr'
- (Nodes.Table (N + 3).Field11'Unrestricted_Access)).Flag164 := Val;
- end Set_Flag164;
-
- procedure Set_Flag165 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- To_Flag_Word3_Ptr
- (Union_Id_Ptr'
- (Nodes.Table (N + 3).Field11'Unrestricted_Access)).Flag165 := Val;
- end Set_Flag165;
-
- procedure Set_Flag166 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- To_Flag_Word3_Ptr
- (Union_Id_Ptr'
- (Nodes.Table (N + 3).Field11'Unrestricted_Access)).Flag166 := Val;
- end Set_Flag166;
-
- procedure Set_Flag167 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- To_Flag_Word3_Ptr
- (Union_Id_Ptr'
- (Nodes.Table (N + 3).Field11'Unrestricted_Access)).Flag167 := Val;
- end Set_Flag167;
-
- procedure Set_Flag168 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- To_Flag_Word3_Ptr
- (Union_Id_Ptr'
- (Nodes.Table (N + 3).Field11'Unrestricted_Access)).Flag168 := Val;
- end Set_Flag168;
-
- procedure Set_Flag169 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- To_Flag_Word3_Ptr
- (Union_Id_Ptr'
- (Nodes.Table (N + 3).Field11'Unrestricted_Access)).Flag169 := Val;
- end Set_Flag169;
-
- procedure Set_Flag170 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- To_Flag_Word3_Ptr
- (Union_Id_Ptr'
- (Nodes.Table (N + 3).Field11'Unrestricted_Access)).Flag170 := Val;
- end Set_Flag170;
-
- procedure Set_Flag171 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- To_Flag_Word3_Ptr
- (Union_Id_Ptr'
- (Nodes.Table (N + 3).Field11'Unrestricted_Access)).Flag171 := Val;
- end Set_Flag171;
-
- procedure Set_Flag172 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- To_Flag_Word3_Ptr
- (Union_Id_Ptr'
- (Nodes.Table (N + 3).Field11'Unrestricted_Access)).Flag172 := Val;
- end Set_Flag172;
-
- procedure Set_Flag173 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- To_Flag_Word3_Ptr
- (Union_Id_Ptr'
- (Nodes.Table (N + 3).Field11'Unrestricted_Access)).Flag173 := Val;
- end Set_Flag173;
-
- procedure Set_Flag174 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- To_Flag_Word3_Ptr
- (Union_Id_Ptr'
- (Nodes.Table (N + 3).Field11'Unrestricted_Access)).Flag174 := Val;
- end Set_Flag174;
-
- procedure Set_Flag175 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- To_Flag_Word3_Ptr
- (Union_Id_Ptr'
- (Nodes.Table (N + 3).Field11'Unrestricted_Access)).Flag175 := Val;
- end Set_Flag175;
-
- procedure Set_Flag176 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- To_Flag_Word3_Ptr
- (Union_Id_Ptr'
- (Nodes.Table (N + 3).Field11'Unrestricted_Access)).Flag176 := Val;
- end Set_Flag176;
-
- procedure Set_Flag177 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- To_Flag_Word3_Ptr
- (Union_Id_Ptr'
- (Nodes.Table (N + 3).Field11'Unrestricted_Access)).Flag177 := Val;
- end Set_Flag177;
-
- procedure Set_Flag178 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- To_Flag_Word3_Ptr
- (Union_Id_Ptr'
- (Nodes.Table (N + 3).Field11'Unrestricted_Access)).Flag178 := Val;
- end Set_Flag178;
-
- procedure Set_Flag179 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- To_Flag_Word3_Ptr
- (Union_Id_Ptr'
- (Nodes.Table (N + 3).Field11'Unrestricted_Access)).Flag179 := Val;
- end Set_Flag179;
-
- procedure Set_Flag180 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- To_Flag_Word3_Ptr
- (Union_Id_Ptr'
- (Nodes.Table (N + 3).Field11'Unrestricted_Access)).Flag180 := Val;
- end Set_Flag180;
-
- procedure Set_Flag181 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- To_Flag_Word3_Ptr
- (Union_Id_Ptr'
- (Nodes.Table (N + 3).Field11'Unrestricted_Access)).Flag181 := Val;
- end Set_Flag181;
-
- procedure Set_Flag182 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- To_Flag_Word3_Ptr
- (Union_Id_Ptr'
- (Nodes.Table (N + 3).Field11'Unrestricted_Access)).Flag182 := Val;
- end Set_Flag182;
-
- procedure Set_Flag183 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- To_Flag_Word3_Ptr
- (Union_Id_Ptr'
- (Nodes.Table (N + 3).Field11'Unrestricted_Access)).Flag183 := Val;
- end Set_Flag183;
-
- procedure Set_Flag184 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- To_Flag_Word4_Ptr
- (Union_Id_Ptr'
- (Nodes.Table (N + 4).Field12'Unrestricted_Access)).Flag184 := Val;
- end Set_Flag184;
-
- procedure Set_Flag185 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- To_Flag_Word4_Ptr
- (Union_Id_Ptr'
- (Nodes.Table (N + 4).Field12'Unrestricted_Access)).Flag185 := Val;
- end Set_Flag185;
-
- procedure Set_Flag186 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- To_Flag_Word4_Ptr
- (Union_Id_Ptr'
- (Nodes.Table (N + 4).Field12'Unrestricted_Access)).Flag186 := Val;
- end Set_Flag186;
-
- procedure Set_Flag187 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- To_Flag_Word4_Ptr
- (Union_Id_Ptr'
- (Nodes.Table (N + 4).Field12'Unrestricted_Access)).Flag187 := Val;
- end Set_Flag187;
-
- procedure Set_Flag188 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- To_Flag_Word4_Ptr
- (Union_Id_Ptr'
- (Nodes.Table (N + 4).Field12'Unrestricted_Access)).Flag188 := Val;
- end Set_Flag188;
-
- procedure Set_Flag189 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- To_Flag_Word4_Ptr
- (Union_Id_Ptr'
- (Nodes.Table (N + 4).Field12'Unrestricted_Access)).Flag189 := Val;
- end Set_Flag189;
-
- procedure Set_Flag190 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- To_Flag_Word4_Ptr
- (Union_Id_Ptr'
- (Nodes.Table (N + 4).Field12'Unrestricted_Access)).Flag190 := Val;
- end Set_Flag190;
-
- procedure Set_Flag191 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- To_Flag_Word4_Ptr
- (Union_Id_Ptr'
- (Nodes.Table (N + 4).Field12'Unrestricted_Access)).Flag191 := Val;
- end Set_Flag191;
-
- procedure Set_Flag192 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- To_Flag_Word4_Ptr
- (Union_Id_Ptr'
- (Nodes.Table (N + 4).Field12'Unrestricted_Access)).Flag192 := Val;
- end Set_Flag192;
-
- procedure Set_Flag193 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- To_Flag_Word4_Ptr
- (Union_Id_Ptr'
- (Nodes.Table (N + 4).Field12'Unrestricted_Access)).Flag193 := Val;
- end Set_Flag193;
-
- procedure Set_Flag194 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- To_Flag_Word4_Ptr
- (Union_Id_Ptr'
- (Nodes.Table (N + 4).Field12'Unrestricted_Access)).Flag194 := Val;
- end Set_Flag194;
-
- procedure Set_Flag195 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- To_Flag_Word4_Ptr
- (Union_Id_Ptr'
- (Nodes.Table (N + 4).Field12'Unrestricted_Access)).Flag195 := Val;
- end Set_Flag195;
-
- procedure Set_Flag196 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- To_Flag_Word4_Ptr
- (Union_Id_Ptr'
- (Nodes.Table (N + 4).Field12'Unrestricted_Access)).Flag196 := Val;
- end Set_Flag196;
-
- procedure Set_Flag197 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- To_Flag_Word4_Ptr
- (Union_Id_Ptr'
- (Nodes.Table (N + 4).Field12'Unrestricted_Access)).Flag197 := Val;
- end Set_Flag197;
-
- procedure Set_Flag198 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- To_Flag_Word4_Ptr
- (Union_Id_Ptr'
- (Nodes.Table (N + 4).Field12'Unrestricted_Access)).Flag198 := Val;
- end Set_Flag198;
-
- procedure Set_Flag199 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- To_Flag_Word4_Ptr
- (Union_Id_Ptr'
- (Nodes.Table (N + 4).Field12'Unrestricted_Access)).Flag199 := Val;
- end Set_Flag199;
-
- procedure Set_Flag200 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- To_Flag_Word4_Ptr
- (Union_Id_Ptr'
- (Nodes.Table (N + 4).Field12'Unrestricted_Access)).Flag200 := Val;
- end Set_Flag200;
-
- procedure Set_Flag201 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- To_Flag_Word4_Ptr
- (Union_Id_Ptr'
- (Nodes.Table (N + 4).Field12'Unrestricted_Access)).Flag201 := Val;
- end Set_Flag201;
-
- procedure Set_Flag202 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- To_Flag_Word4_Ptr
- (Union_Id_Ptr'
- (Nodes.Table (N + 4).Field12'Unrestricted_Access)).Flag202 := Val;
- end Set_Flag202;
-
- procedure Set_Flag203 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- To_Flag_Word4_Ptr
- (Union_Id_Ptr'
- (Nodes.Table (N + 4).Field12'Unrestricted_Access)).Flag203 := Val;
- end Set_Flag203;
-
- procedure Set_Flag204 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- To_Flag_Word4_Ptr
- (Union_Id_Ptr'
- (Nodes.Table (N + 4).Field12'Unrestricted_Access)).Flag204 := Val;
- end Set_Flag204;
-
- procedure Set_Flag205 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- To_Flag_Word4_Ptr
- (Union_Id_Ptr'
- (Nodes.Table (N + 4).Field12'Unrestricted_Access)).Flag205 := Val;
- end Set_Flag205;
-
- procedure Set_Flag206 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- To_Flag_Word4_Ptr
- (Union_Id_Ptr'
- (Nodes.Table (N + 4).Field12'Unrestricted_Access)).Flag206 := Val;
- end Set_Flag206;
-
- procedure Set_Flag207 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- To_Flag_Word4_Ptr
- (Union_Id_Ptr'
- (Nodes.Table (N + 4).Field12'Unrestricted_Access)).Flag207 := Val;
- end Set_Flag207;
-
- procedure Set_Flag208 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- To_Flag_Word4_Ptr
- (Union_Id_Ptr'
- (Nodes.Table (N + 4).Field12'Unrestricted_Access)).Flag208 := Val;
- end Set_Flag208;
-
- procedure Set_Flag209 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- To_Flag_Word4_Ptr
- (Union_Id_Ptr'
- (Nodes.Table (N + 4).Field12'Unrestricted_Access)).Flag209 := Val;
- end Set_Flag209;
-
- procedure Set_Flag210 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- To_Flag_Word4_Ptr
- (Union_Id_Ptr'
- (Nodes.Table (N + 4).Field12'Unrestricted_Access)).Flag210 := Val;
- end Set_Flag210;
-
- procedure Set_Flag211 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- To_Flag_Word4_Ptr
- (Union_Id_Ptr'
- (Nodes.Table (N + 4).Field12'Unrestricted_Access)).Flag211 := Val;
- end Set_Flag211;
-
- procedure Set_Flag212 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- To_Flag_Word4_Ptr
- (Union_Id_Ptr'
- (Nodes.Table (N + 4).Field12'Unrestricted_Access)).Flag212 := Val;
- end Set_Flag212;
-
- procedure Set_Flag213 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- To_Flag_Word4_Ptr
- (Union_Id_Ptr'
- (Nodes.Table (N + 4).Field12'Unrestricted_Access)).Flag213 := Val;
- end Set_Flag213;
-
- procedure Set_Flag214 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- To_Flag_Word4_Ptr
- (Union_Id_Ptr'
- (Nodes.Table (N + 4).Field12'Unrestricted_Access)).Flag214 := Val;
- end Set_Flag214;
-
- procedure Set_Flag215 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- To_Flag_Word4_Ptr
- (Union_Id_Ptr'
- (Nodes.Table (N + 4).Field12'Unrestricted_Access)).Flag215 := Val;
- end Set_Flag215;
-
- procedure Set_Flag216 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- Nodes.Table (N + 4).In_List := Val;
- end Set_Flag216;
-
- procedure Set_Flag217 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- Nodes.Table (N + 4).Has_Aspects := Val;
- end Set_Flag217;
-
- procedure Set_Flag218 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- Nodes.Table (N + 4).Rewrite_Ins := Val;
- end Set_Flag218;
-
- procedure Set_Flag219 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- Nodes.Table (N + 4).Analyzed := Val;
- end Set_Flag219;
-
- procedure Set_Flag220 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- Nodes.Table (N + 4).Comes_From_Source := Val;
- end Set_Flag220;
-
- procedure Set_Flag221 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- Nodes.Table (N + 4).Error_Posted := Val;
- end Set_Flag221;
-
- procedure Set_Flag222 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- Nodes.Table (N + 4).Flag4 := Val;
- end Set_Flag222;
-
- procedure Set_Flag223 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- Nodes.Table (N + 4).Flag5 := Val;
- end Set_Flag223;
-
- procedure Set_Flag224 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- Nodes.Table (N + 4).Flag6 := Val;
- end Set_Flag224;
-
- procedure Set_Flag225 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- Nodes.Table (N + 4).Flag7 := Val;
- end Set_Flag225;
-
- procedure Set_Flag226 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- Nodes.Table (N + 4).Flag8 := Val;
- end Set_Flag226;
-
- procedure Set_Flag227 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- Nodes.Table (N + 4).Flag9 := Val;
- end Set_Flag227;
-
- procedure Set_Flag228 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- Nodes.Table (N + 4).Flag10 := Val;
- end Set_Flag228;
-
- procedure Set_Flag229 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- Nodes.Table (N + 4).Flag11 := Val;
- end Set_Flag229;
-
- procedure Set_Flag230 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- Nodes.Table (N + 4).Flag12 := Val;
- end Set_Flag230;
-
- procedure Set_Flag231 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- Nodes.Table (N + 4).Flag13 := Val;
- end Set_Flag231;
-
- procedure Set_Flag232 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- Nodes.Table (N + 4).Flag14 := Val;
- end Set_Flag232;
-
- procedure Set_Flag233 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- Nodes.Table (N + 4).Flag15 := Val;
- end Set_Flag233;
-
- procedure Set_Flag234 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- Nodes.Table (N + 4).Flag16 := Val;
- end Set_Flag234;
-
- procedure Set_Flag235 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- Nodes.Table (N + 4).Flag17 := Val;
- end Set_Flag235;
-
- procedure Set_Flag236 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- Nodes.Table (N + 4).Flag18 := Val;
- end Set_Flag236;
-
- procedure Set_Flag237 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- Nodes.Table (N + 4).Pflag1 := Val;
- end Set_Flag237;
-
- procedure Set_Flag238 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- Nodes.Table (N + 4).Pflag2 := Val;
- end Set_Flag238;
-
- procedure Set_Flag239 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- To_Flag_Byte2_Ptr
- (Node_Kind_Ptr'
- (Nodes.Table (N + 3).Nkind'Unrestricted_Access)).Flag239 := Val;
- end Set_Flag239;
-
- procedure Set_Flag240 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- To_Flag_Byte2_Ptr
- (Node_Kind_Ptr'
- (Nodes.Table (N + 3).Nkind'Unrestricted_Access)).Flag240 := Val;
- end Set_Flag240;
-
- procedure Set_Flag241 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- To_Flag_Byte2_Ptr
- (Node_Kind_Ptr'
- (Nodes.Table (N + 3).Nkind'Unrestricted_Access)).Flag241 := Val;
- end Set_Flag241;
-
- procedure Set_Flag242 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- To_Flag_Byte2_Ptr
- (Node_Kind_Ptr'
- (Nodes.Table (N + 3).Nkind'Unrestricted_Access)).Flag242 := Val;
- end Set_Flag242;
-
- procedure Set_Flag243 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- To_Flag_Byte2_Ptr
- (Node_Kind_Ptr'
- (Nodes.Table (N + 3).Nkind'Unrestricted_Access)).Flag243 := Val;
- end Set_Flag243;
-
- procedure Set_Flag244 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- To_Flag_Byte2_Ptr
- (Node_Kind_Ptr'
- (Nodes.Table (N + 3).Nkind'Unrestricted_Access)).Flag244 := Val;
- end Set_Flag244;
-
- procedure Set_Flag245 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- To_Flag_Byte2_Ptr
- (Node_Kind_Ptr'
- (Nodes.Table (N + 3).Nkind'Unrestricted_Access)).Flag245 := Val;
- end Set_Flag245;
-
- procedure Set_Flag246 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- To_Flag_Byte2_Ptr
- (Node_Kind_Ptr'
- (Nodes.Table (N + 3).Nkind'Unrestricted_Access)).Flag246 := Val;
- end Set_Flag246;
-
- procedure Set_Flag247 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- To_Flag_Byte3_Ptr
- (Node_Kind_Ptr'
- (Nodes.Table (N + 4).Nkind'Unrestricted_Access)).Flag247 := Val;
- end Set_Flag247;
-
- procedure Set_Flag248 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- To_Flag_Byte3_Ptr
- (Node_Kind_Ptr'
- (Nodes.Table (N + 4).Nkind'Unrestricted_Access)).Flag248 := Val;
- end Set_Flag248;
-
- procedure Set_Flag249 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- To_Flag_Byte3_Ptr
- (Node_Kind_Ptr'
- (Nodes.Table (N + 4).Nkind'Unrestricted_Access)).Flag249 := Val;
- end Set_Flag249;
-
- procedure Set_Flag250 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- To_Flag_Byte3_Ptr
- (Node_Kind_Ptr'
- (Nodes.Table (N + 4).Nkind'Unrestricted_Access)).Flag250 := Val;
- end Set_Flag250;
-
- procedure Set_Flag251 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- To_Flag_Byte3_Ptr
- (Node_Kind_Ptr'
- (Nodes.Table (N + 4).Nkind'Unrestricted_Access)).Flag251 := Val;
- end Set_Flag251;
-
- procedure Set_Flag252 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- To_Flag_Byte3_Ptr
- (Node_Kind_Ptr'
- (Nodes.Table (N + 4).Nkind'Unrestricted_Access)).Flag252 := Val;
- end Set_Flag252;
-
- procedure Set_Flag253 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- To_Flag_Byte3_Ptr
- (Node_Kind_Ptr'
- (Nodes.Table (N + 4).Nkind'Unrestricted_Access)).Flag253 := Val;
- end Set_Flag253;
-
- procedure Set_Flag254 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- To_Flag_Byte3_Ptr
- (Node_Kind_Ptr'
- (Nodes.Table (N + 4).Nkind'Unrestricted_Access)).Flag254 := Val;
- end Set_Flag254;
-
- procedure Set_Flag255 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- To_Flag_Word5_Ptr
- (Union_Id_Ptr'
- (Nodes.Table (N + 5).Field12'Unrestricted_Access)).Flag255 := Val;
- end Set_Flag255;
-
- procedure Set_Flag256 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- To_Flag_Word5_Ptr
- (Union_Id_Ptr'
- (Nodes.Table (N + 5).Field12'Unrestricted_Access)).Flag256 := Val;
- end Set_Flag256;
-
- procedure Set_Flag257 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- To_Flag_Word5_Ptr
- (Union_Id_Ptr'
- (Nodes.Table (N + 5).Field12'Unrestricted_Access)).Flag257 := Val;
- end Set_Flag257;
-
- procedure Set_Flag258 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- To_Flag_Word5_Ptr
- (Union_Id_Ptr'
- (Nodes.Table (N + 5).Field12'Unrestricted_Access)).Flag258 := Val;
- end Set_Flag258;
-
- procedure Set_Flag259 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- To_Flag_Word5_Ptr
- (Union_Id_Ptr'
- (Nodes.Table (N + 5).Field12'Unrestricted_Access)).Flag259 := Val;
- end Set_Flag259;
-
- procedure Set_Flag260 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- To_Flag_Word5_Ptr
- (Union_Id_Ptr'
- (Nodes.Table (N + 5).Field12'Unrestricted_Access)).Flag260 := Val;
- end Set_Flag260;
-
- procedure Set_Flag261 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- To_Flag_Word5_Ptr
- (Union_Id_Ptr'
- (Nodes.Table (N + 5).Field12'Unrestricted_Access)).Flag261 := Val;
- end Set_Flag261;
-
- procedure Set_Flag262 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- To_Flag_Word5_Ptr
- (Union_Id_Ptr'
- (Nodes.Table (N + 5).Field12'Unrestricted_Access)).Flag262 := Val;
- end Set_Flag262;
-
- procedure Set_Flag263 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- To_Flag_Word5_Ptr
- (Union_Id_Ptr'
- (Nodes.Table (N + 5).Field12'Unrestricted_Access)).Flag263 := Val;
- end Set_Flag263;
-
- procedure Set_Flag264 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- To_Flag_Word5_Ptr
- (Union_Id_Ptr'
- (Nodes.Table (N + 5).Field12'Unrestricted_Access)).Flag264 := Val;
- end Set_Flag264;
-
- procedure Set_Flag265 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- To_Flag_Word5_Ptr
- (Union_Id_Ptr'
- (Nodes.Table (N + 5).Field12'Unrestricted_Access)).Flag265 := Val;
- end Set_Flag265;
-
- procedure Set_Flag266 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- To_Flag_Word5_Ptr
- (Union_Id_Ptr'
- (Nodes.Table (N + 5).Field12'Unrestricted_Access)).Flag266 := Val;
- end Set_Flag266;
-
- procedure Set_Flag267 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- To_Flag_Word5_Ptr
- (Union_Id_Ptr'
- (Nodes.Table (N + 5).Field12'Unrestricted_Access)).Flag267 := Val;
- end Set_Flag267;
-
- procedure Set_Flag268 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- To_Flag_Word5_Ptr
- (Union_Id_Ptr'
- (Nodes.Table (N + 5).Field12'Unrestricted_Access)).Flag268 := Val;
- end Set_Flag268;
-
- procedure Set_Flag269 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- To_Flag_Word5_Ptr
- (Union_Id_Ptr'
- (Nodes.Table (N + 5).Field12'Unrestricted_Access)).Flag269 := Val;
- end Set_Flag269;
-
- procedure Set_Flag270 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- To_Flag_Word5_Ptr
- (Union_Id_Ptr'
- (Nodes.Table (N + 5).Field12'Unrestricted_Access)).Flag270 := Val;
- end Set_Flag270;
-
- procedure Set_Flag271 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- To_Flag_Word5_Ptr
- (Union_Id_Ptr'
- (Nodes.Table (N + 5).Field12'Unrestricted_Access)).Flag271 := Val;
- end Set_Flag271;
-
- procedure Set_Flag272 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- To_Flag_Word5_Ptr
- (Union_Id_Ptr'
- (Nodes.Table (N + 5).Field12'Unrestricted_Access)).Flag272 := Val;
- end Set_Flag272;
-
- procedure Set_Flag273 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- To_Flag_Word5_Ptr
- (Union_Id_Ptr'
- (Nodes.Table (N + 5).Field12'Unrestricted_Access)).Flag273 := Val;
- end Set_Flag273;
-
- procedure Set_Flag274 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- To_Flag_Word5_Ptr
- (Union_Id_Ptr'
- (Nodes.Table (N + 5).Field12'Unrestricted_Access)).Flag274 := Val;
- end Set_Flag274;
-
- procedure Set_Flag275 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- To_Flag_Word5_Ptr
- (Union_Id_Ptr'
- (Nodes.Table (N + 5).Field12'Unrestricted_Access)).Flag275 := Val;
- end Set_Flag275;
-
- procedure Set_Flag276 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- To_Flag_Word5_Ptr
- (Union_Id_Ptr'
- (Nodes.Table (N + 5).Field12'Unrestricted_Access)).Flag276 := Val;
- end Set_Flag276;
-
- procedure Set_Flag277 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- To_Flag_Word5_Ptr
- (Union_Id_Ptr'
- (Nodes.Table (N + 5).Field12'Unrestricted_Access)).Flag277 := Val;
- end Set_Flag277;
-
- procedure Set_Flag278 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- To_Flag_Word5_Ptr
- (Union_Id_Ptr'
- (Nodes.Table (N + 5).Field12'Unrestricted_Access)).Flag278 := Val;
- end Set_Flag278;
-
- procedure Set_Flag279 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- To_Flag_Word5_Ptr
- (Union_Id_Ptr'
- (Nodes.Table (N + 5).Field12'Unrestricted_Access)).Flag279 := Val;
- end Set_Flag279;
-
- procedure Set_Flag280 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- To_Flag_Word5_Ptr
- (Union_Id_Ptr'
- (Nodes.Table (N + 5).Field12'Unrestricted_Access)).Flag280 := Val;
- end Set_Flag280;
-
- procedure Set_Flag281 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- To_Flag_Word5_Ptr
- (Union_Id_Ptr'
- (Nodes.Table (N + 5).Field12'Unrestricted_Access)).Flag281 := Val;
- end Set_Flag281;
-
- procedure Set_Flag282 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- To_Flag_Word5_Ptr
- (Union_Id_Ptr'
- (Nodes.Table (N + 5).Field12'Unrestricted_Access)).Flag282 := Val;
- end Set_Flag282;
-
- procedure Set_Flag283 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- To_Flag_Word5_Ptr
- (Union_Id_Ptr'
- (Nodes.Table (N + 5).Field12'Unrestricted_Access)).Flag283 := Val;
- end Set_Flag283;
-
- procedure Set_Flag284 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- To_Flag_Word5_Ptr
- (Union_Id_Ptr'
- (Nodes.Table (N + 5).Field12'Unrestricted_Access)).Flag284 := Val;
- end Set_Flag284;
-
- procedure Set_Flag285 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- To_Flag_Word5_Ptr
- (Union_Id_Ptr'
- (Nodes.Table (N + 5).Field12'Unrestricted_Access)).Flag285 := Val;
- end Set_Flag285;
-
- procedure Set_Flag286 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- To_Flag_Word5_Ptr
- (Union_Id_Ptr'
- (Nodes.Table (N + 5).Field12'Unrestricted_Access)).Flag286 := Val;
- end Set_Flag286;
-
- procedure Set_Flag287 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- Nodes.Table (N + 5).In_List := Val;
- end Set_Flag287;
-
- procedure Set_Flag288 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- Nodes.Table (N + 5).Has_Aspects := Val;
- end Set_Flag288;
-
- procedure Set_Flag289 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- Nodes.Table (N + 5).Rewrite_Ins := Val;
- end Set_Flag289;
-
- procedure Set_Flag290 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- Nodes.Table (N + 5).Analyzed := Val;
- end Set_Flag290;
-
- procedure Set_Flag291 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- Nodes.Table (N + 5).Comes_From_Source := Val;
- end Set_Flag291;
-
- procedure Set_Flag292 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- Nodes.Table (N + 5).Error_Posted := Val;
- end Set_Flag292;
-
- procedure Set_Flag293 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- Nodes.Table (N + 5).Flag4 := Val;
- end Set_Flag293;
-
- procedure Set_Flag294 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- Nodes.Table (N + 5).Flag5 := Val;
- end Set_Flag294;
-
- procedure Set_Flag295 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- Nodes.Table (N + 5).Flag6 := Val;
- end Set_Flag295;
-
- procedure Set_Flag296 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- Nodes.Table (N + 5).Flag7 := Val;
- end Set_Flag296;
-
- procedure Set_Flag297 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- Nodes.Table (N + 5).Flag8 := Val;
- end Set_Flag297;
-
- procedure Set_Flag298 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- Nodes.Table (N + 5).Flag9 := Val;
- end Set_Flag298;
-
- procedure Set_Flag299 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- Nodes.Table (N + 5).Flag10 := Val;
- end Set_Flag299;
-
- procedure Set_Flag300 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- Nodes.Table (N + 5).Flag11 := Val;
- end Set_Flag300;
-
- procedure Set_Flag301 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- Nodes.Table (N + 5).Flag12 := Val;
- end Set_Flag301;
-
- procedure Set_Flag302 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- Nodes.Table (N + 5).Flag13 := Val;
- end Set_Flag302;
-
- procedure Set_Flag303 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- Nodes.Table (N + 5).Flag14 := Val;
- end Set_Flag303;
-
- procedure Set_Flag304 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- Nodes.Table (N + 5).Flag15 := Val;
- end Set_Flag304;
-
- procedure Set_Flag305 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- Nodes.Table (N + 5).Flag16 := Val;
- end Set_Flag305;
-
- procedure Set_Flag306 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- Nodes.Table (N + 5).Flag17 := Val;
- end Set_Flag306;
-
- procedure Set_Flag307 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- Nodes.Table (N + 5).Flag18 := Val;
- end Set_Flag307;
-
- procedure Set_Flag308 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- Nodes.Table (N + 5).Pflag1 := Val;
- end Set_Flag308;
-
- procedure Set_Flag309 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- Nodes.Table (N + 5).Pflag2 := Val;
- end Set_Flag309;
-
- procedure Set_Flag310 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- To_Flag_Byte4_Ptr
- (Node_Kind_Ptr'
- (Nodes.Table (N + 5).Nkind'Unrestricted_Access)).Flag310 := Val;
- end Set_Flag310;
-
- procedure Set_Flag311 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- To_Flag_Byte4_Ptr
- (Node_Kind_Ptr'
- (Nodes.Table (N + 5).Nkind'Unrestricted_Access)).Flag311 := Val;
- end Set_Flag311;
-
- procedure Set_Flag312 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- To_Flag_Byte4_Ptr
- (Node_Kind_Ptr'
- (Nodes.Table (N + 5).Nkind'Unrestricted_Access)).Flag312 := Val;
- end Set_Flag312;
-
- procedure Set_Flag313 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- To_Flag_Byte4_Ptr
- (Node_Kind_Ptr'
- (Nodes.Table (N + 5).Nkind'Unrestricted_Access)).Flag313 := Val;
- end Set_Flag313;
-
- procedure Set_Flag314 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- To_Flag_Byte4_Ptr
- (Node_Kind_Ptr'
- (Nodes.Table (N + 5).Nkind'Unrestricted_Access)).Flag314 := Val;
- end Set_Flag314;
-
- procedure Set_Flag315 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- To_Flag_Byte4_Ptr
- (Node_Kind_Ptr'
- (Nodes.Table (N + 5).Nkind'Unrestricted_Access)).Flag315 := Val;
- end Set_Flag315;
-
- procedure Set_Flag316 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- To_Flag_Byte4_Ptr
- (Node_Kind_Ptr'
- (Nodes.Table (N + 5).Nkind'Unrestricted_Access)).Flag316 := Val;
- end Set_Flag316;
-
- procedure Set_Flag317 (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (not Locked);
- pragma Assert (Nkind (N) in N_Entity);
- To_Flag_Byte4_Ptr
- (Node_Kind_Ptr'
- (Nodes.Table (N + 5).Nkind'Unrestricted_Access)).Flag317 := Val;
- end Set_Flag317;
-
- procedure Set_Node1_With_Parent (N : Node_Id; Val : Node_Id) is
- begin
- pragma Assert (not Locked);
- pragma Assert (N <= Nodes.Last);
-
- if Val > Error then
- Set_Parent (N => Val, Val => N);
- end if;
-
- Set_Node1 (N, Val);
- end Set_Node1_With_Parent;
-
- procedure Set_Node2_With_Parent (N : Node_Id; Val : Node_Id) is
- begin
- pragma Assert (not Locked);
- pragma Assert (N <= Nodes.Last);
-
- if Val > Error then
- Set_Parent (N => Val, Val => N);
- end if;
-
- Set_Node2 (N, Val);
- end Set_Node2_With_Parent;
-
- procedure Set_Node3_With_Parent (N : Node_Id; Val : Node_Id) is
- begin
- pragma Assert (not Locked);
- pragma Assert (N <= Nodes.Last);
-
- if Val > Error then
- Set_Parent (N => Val, Val => N);
- end if;
-
- Set_Node3 (N, Val);
- end Set_Node3_With_Parent;
-
- procedure Set_Node4_With_Parent (N : Node_Id; Val : Node_Id) is
- begin
- pragma Assert (not Locked);
- pragma Assert (N <= Nodes.Last);
-
- if Val > Error then
- Set_Parent (N => Val, Val => N);
- end if;
-
- Set_Node4 (N, Val);
- end Set_Node4_With_Parent;
-
- procedure Set_Node5_With_Parent (N : Node_Id; Val : Node_Id) is
- begin
- pragma Assert (not Locked);
- pragma Assert (N <= Nodes.Last);
-
- if Val > Error then
- Set_Parent (N => Val, Val => N);
- end if;
-
- Set_Node5 (N, Val);
- end Set_Node5_With_Parent;
-
- procedure Set_List1_With_Parent (N : Node_Id; Val : List_Id) is
- begin
- pragma Assert (not Locked);
- pragma Assert (N <= Nodes.Last);
- if Val /= No_List and then Val /= Error_List then
- Set_Parent (Val, N);
- end if;
- Set_List1 (N, Val);
- end Set_List1_With_Parent;
-
- procedure Set_List2_With_Parent (N : Node_Id; Val : List_Id) is
- begin
- pragma Assert (not Locked);
- pragma Assert (N <= Nodes.Last);
- if Val /= No_List and then Val /= Error_List then
- Set_Parent (Val, N);
- end if;
- Set_List2 (N, Val);
- end Set_List2_With_Parent;
-
- procedure Set_List3_With_Parent (N : Node_Id; Val : List_Id) is
- begin
- pragma Assert (not Locked);
- pragma Assert (N <= Nodes.Last);
- if Val /= No_List and then Val /= Error_List then
- Set_Parent (Val, N);
- end if;
- Set_List3 (N, Val);
- end Set_List3_With_Parent;
-
- procedure Set_List4_With_Parent (N : Node_Id; Val : List_Id) is
- begin
- pragma Assert (not Locked);
- pragma Assert (N <= Nodes.Last);
- if Val /= No_List and then Val /= Error_List then
- Set_Parent (Val, N);
- end if;
- Set_List4 (N, Val);
- end Set_List4_With_Parent;
-
- procedure Set_List5_With_Parent (N : Node_Id; Val : List_Id) is
- begin
- pragma Assert (not Locked);
- pragma Assert (N <= Nodes.Last);
- if Val /= No_List and then Val /= Error_List then
- Set_Parent (Val, N);
- end if;
- Set_List5 (N, Val);
- end Set_List5_With_Parent;
-
- end Unchecked_Access;
-
------------
-- Unlock --
------------
procedure Unlock is
begin
- Flags.Locked := False;
Orig_Nodes.Locked := False;
end Unlock;
@@ -8794,4 +2357,18 @@ package body Atree is
Locked := False;
end Unlock_Nodes;
+ ----------------
+ -- Zero_Slots --
+ ----------------
+
+ procedure Zero_Slots (First, Last : Node_Offset) is
+ begin
+ Slots.Table (First .. Last) := (others => 0);
+ end Zero_Slots;
+
+ procedure Zero_Slots (N : Node_Or_Entity_Id) is
+ begin
+ Zero_Slots (Off_0 (N), Off_L (N));
+ end Zero_Slots;
+
end Atree;
diff --git a/gcc/ada/atree.ads b/gcc/ada/atree.ads
index f84ff45..6fb5aa6 100644
--- a/gcc/ada/atree.ads
+++ b/gcc/ada/atree.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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,211 +23,52 @@
-- --
------------------------------------------------------------------------------
-with Alloc;
-with Sinfo; use Sinfo;
-with Einfo; use Einfo;
-with Namet; use Namet;
-with Types; use Types;
-with Snames; use Snames;
-with System; use System;
-with Table;
-with Uintp; use Uintp;
-with Urealp; use Urealp;
-with Unchecked_Conversion;
-
-package Atree is
-
--- This package defines the format of the tree used to represent the Ada
--- program internally. Syntactic and semantic information is combined in
--- this tree. There is no separate symbol table structure.
+-- This package defines the low-level representation of the tree used to
+-- represent the Ada program internally. Syntactic and semantic information
+-- is combined in this tree. There is no separate symbol table structure.
--- WARNING: There is a C version of this package. Any changes to this source
--- file must be properly reflected in the C header file atree.h
+-- WARNING: There is a C++ version of this package. Any changes to this source
+-- file must be properly reflected in the C++ header file atree.h.
-- Package Atree defines the basic structure of the tree and its nodes and
-- provides the basic abstract interface for manipulating the tree. Two other
-- packages use this interface to define the representation of Ada programs
-- using this tree format. The package Sinfo defines the basic representation
-- of the syntactic structure of the program, as output by the parser. The
--- package Einfo defines the semantic information which is added to the tree
--- nodes that represent declared entities (i.e. the information which might
--- typically be described in a separate symbol table structure).
+-- package Einfo defines the semantic information that is added to the tree
+-- nodes that represent declared entities (i.e. the information that is
+-- described in a separate symbol table structure in some other compilers).
-- The front end of the compiler first parses the program and generates a
-- tree that is simply a syntactic representation of the program in abstract
-- syntax tree format. Subsequent processing in the front end traverses the
-- tree, transforming it in various ways and adding semantic information.
- ----------------------
- -- Size of Entities --
- ----------------------
+with Alloc;
+with Sinfo.Nodes; use Sinfo.Nodes;
+with Einfo.Entities; use Einfo.Entities;
+with Types; use Types;
+with System; use System;
+with Table;
+with Unchecked_Conversion;
+
+package Atree is
- -- Currently entities are composed of 7 sequentially allocated 32-byte
- -- nodes, considered as a single record. The following definition gives
- -- the number of extension nodes. ????We plan to change this.
-
- Num_Extension_Nodes : Node_Id := 6;
- -- This value is increased by one if debug flag -gnatd.N is set. This is
- -- for testing performance impact of adding a new extension node. We make
- -- this of type Node_Id for easy reference in loops using this value.
- -- Print_Statistics can be used to display statistics on entities & nodes.
- -- Measurements conducted for the 5->6 bump showed an increase from 1.81 to
- -- 2.01 for the nodes/entities ratio and a 2% increase in compilation time
- -- on average for the GCC-based compiler at -O0 on a 32-bit x86 host.
-
- procedure Print_Statistics;
- pragma Export (Ada, Print_Statistics);
- -- Print various statistics on the tables maintained by the package
-
- ----------------------------------------
- -- Definitions of Fields in Tree Node --
- ----------------------------------------
-
- -- The representation of the tree is completely hidden, using a functional
- -- interface for accessing and modifying the contents of nodes. Logically
- -- a node contains a number of fields, much as though the nodes were
- -- defined as a record type. The fields in a node are as follows:
-
- -- Nkind Indicates the kind of the node. This field is present
- -- in all nodes. The type is Node_Kind, which is declared
- -- in the package Sinfo.
-
- -- Sloc Location (Source_Ptr) of the corresponding token
- -- in the Source buffer. The individual node definitions
- -- show which token is referenced by this pointer.
-
- -- In_List A flag used to indicate if the node is a member
- -- of a node list.
-
- -- Rewrite_Ins A flag set if a node is marked as a rewrite inserted
- -- node as a result of a call to Mark_Rewrite_Insertion.
-
- -- Paren_Count A 2-bit count used in sub-expression nodes to indicate
- -- the level of parentheses. The settings are 0,1,2 and
- -- 3 for many. If the value is 3, then an auxiliary table
- -- is used to indicate the real value. Set to zero for
- -- non-subexpression nodes.
-
- -- Note: the required parentheses surrounding conditional
- -- and quantified expressions count as a level of parens
- -- for this purpose, so e.g. in X := (if A then B else C);
- -- Paren_Count for the right side will be 1.
-
- -- Comes_From_Source
- -- This flag is present in all nodes. It is set if the
- -- node is built by the scanner or parser, and clear if
- -- the node is built by the analyzer or expander. It
- -- indicates that the node corresponds to a construct
- -- that appears in the original source program.
-
- -- Analyzed This flag is present in all nodes. It is set when
- -- a node is analyzed, and is used to avoid analyzing
- -- the same node twice. Analysis includes expansion if
- -- expansion is active, so in this case if the flag is
- -- set it means the node has been analyzed and expanded.
-
- -- Error_Posted This flag is present in all nodes. It is set when
- -- an error message is posted which is associated with
- -- the flagged node. This is used to avoid posting more
- -- than one message on the same node.
-
- -- Field1
- -- Field2
- -- Field3
- -- Field4
- -- Field5 Five fields holding Union_Id values
-
- -- ElistN Synonym for FieldN typed as Elist_Id (Empty = No_Elist)
- -- ListN Synonym for FieldN typed as List_Id
- -- NameN Synonym for FieldN typed as Name_Id
- -- NodeN Synonym for FieldN typed as Node_Id
- -- StrN Synonym for FieldN typed as String_Id
- -- UintN Synonym for FieldN typed as Uint (Empty = Uint_0)
- -- UrealN Synonym for FieldN typed as Ureal
-
- -- Note: in the case of ElistN and UintN fields, it is common that we
- -- end up with a value of Union_Id'(0) as the default value. This value
- -- is meaningless as a Uint or Elist_Id value. We have two choices here.
- -- We could require that all Uint and Elist fields be initialized to an
- -- appropriate value, but that's error prone, since it would be easy to
- -- miss an initialization. So instead we have the retrieval functions
- -- generate an appropriate default value (Uint_0 or No_Elist). Probably
- -- it would be cleaner to generate No_Uint in the Uint case but we got
- -- stuck with representing an "unset" size value as zero early on, and
- -- it will take a bit of fiddling to change that ???
-
- -- Note: the actual usage of FieldN (i.e. whether it contains a Elist_Id,
- -- List_Id, Name_Id, Node_Id, String_Id, Uint or Ureal) depends on the
- -- value in Nkind. Generally the access to this field is always via the
- -- functional interface, so the field names ElistN, ListN, NameN, NodeN,
- -- StrN, UintN and UrealN are used only in the bodies of the access
- -- functions (i.e. in the bodies of Sinfo and Einfo). These access
- -- functions contain debugging code that checks that the use is
- -- consistent with Nkind and Ekind values.
-
- -- However, in specialized circumstances (examples are the circuit in
- -- generic instantiation to copy trees, and in the tree dump routine),
- -- it is useful to be able to do untyped traversals, and an internal
- -- package in Atree allows for direct untyped accesses in such cases.
-
- -- Flag0 Nineteen Boolean flags (use depends on Nkind and
- -- Flag1 Ekind, as described for FieldN). Again the access
- -- Flag2 is usually via subprograms in Sinfo and Einfo which
- -- Flag3 provide high-level synonyms for these flags, and
- -- Flag4 contain debugging code that checks that the values
- -- Flag5 in Nkind and Ekind are appropriate for the access.
- -- Flag6
- -- Flag7
- -- Flag8
- -- Flag9
- -- Flag10
- -- Flag11 Note that Flag0-3 are stored separately in the Flags
- -- Flag12 table, but that's a detail of the implementation which
- -- Flag13 is entirely hidden by the functional interface.
- -- Flag14
- -- Flag15
- -- Flag16
- -- Flag17
- -- Flag18
-
- -- Link For a node, points to the Parent. For a list, points
- -- to the list header. Note that in the latter case, a
- -- client cannot modify the link field. This field is
- -- private to the Atree package (but is also modified
- -- by the Nlists package).
-
- -- The following additional fields are present in extended nodes used
- -- for entities (Nkind in N_Entity).
-
- -- Ekind Entity type. This field indicates the type of the
- -- entity, it is of type Entity_Kind which is defined
- -- in package Einfo.
-
- -- Flag19 299 additional flags
- -- ...
- -- Flag317
-
- -- Convention Entity convention (Convention_Id value)
-
- -- Field6 Additional Union_Id value stored in tree
-
- -- Node6 Synonym for Field6 typed as Node_Id
- -- Elist6 Synonym for Field6 typed as Elist_Id (Empty = No_Elist)
- -- Uint6 Synonym for Field6 typed as Uint (Empty = Uint_0)
-
- -- Similar definitions for Field7 to Field41 (and also Node7-Node41,
- -- Elist7-Elist41, Uint7-Uint41, Ureal7-Ureal41). Note that not all
- -- these functions are defined, only the ones that are actually used.
+ -- Access to node fields is generally done through the getters and setters
+ -- in packages Sinfo.Nodes and Einfo.Entities, which are automatically
+ -- generated (see Gen_IL.Gen). However, in specialized circumstances
+ -- (examples are the circuit in generic instantiation to copy trees, and in
+ -- the tree dump routine), it is useful to be able to do untyped
+ -- traversals, and an internal package in Atree allows for direct untyped
+ -- accesses in such cases.
function Last_Node_Id return Node_Id;
- pragma Inline (Last_Node_Id);
-- Returns Id of last allocated node Id
- function Nodes_Address return System.Address;
- -- Return address of Nodes table (used in Back_End for Gigi call)
-
- function Flags_Address return System.Address;
- -- Return address of Flags table (used in Back_End for Gigi call)
+ function Node_Offsets_Address return System.Address;
+ function Slots_Address return System.Address;
+ -- Address of Node_Offsets.Table and Slots.Table. Used in Back_End for Gigi
+ -- call.
function Approx_Num_Nodes_And_Entities return Nat;
-- This is an approximation to the number of nodes and entities allocated,
@@ -237,19 +78,21 @@ package Atree is
-- Use of Empty Node --
-----------------------
- -- The special Node_Id Empty is used to mark missing fields. Whenever the
- -- syntax has an optional component, then the corresponding field will be
- -- set to Empty if the component is missing.
+ -- The special Node_Id Empty is used to mark missing fields, similar to
+ -- "null" in Ada. Whenever the syntax has an optional component, then the
+ -- corresponding field will be set to Empty if the component is missing.
-- Note: Empty is not used to describe an empty list. Instead in this
-- case the node field contains a list which is empty, and these cases
-- should be distinguished (essentially from a type point of view, Empty
- -- is a Node, and is thus not a list).
+ -- is a Node, not a list).
- -- Note: Empty does in fact correspond to an allocated node. Only the
- -- Nkind field of this node may be referenced. It contains N_Empty, which
+ -- Note: Empty does in fact correspond to an allocated node. The Nkind
+ -- field of this node may be referenced. It contains N_Empty, which
-- uniquely identifies the empty case. This allows the Nkind field to be
- -- dereferenced before the check for Empty which is sometimes useful.
+ -- dereferenced before the check for Empty which is sometimes useful. We
+ -- also access certain other fields of Empty; see comments in
+ -- Gen_IL.Gen.Gen_Nodes.
-----------------------
-- Use of Error Node --
@@ -263,19 +106,18 @@ package Atree is
-- If an Error node is encountered, then you know that a previous
-- illegality has been detected. The proper reaction should be to
-- avoid posting related cascaded error messages, and to propagate
- -- the error node if necessary.
+ -- the Error node if necessary.
------------------------
-- Current_Error_Node --
------------------------
- -- The current error node is a global location indicating the current
- -- node that is being processed for the purposes of placing a compiler
+ -- Current_Error_Node is a global variable indicating the current node
+ -- that is being processed for the purposes of placing a compiler
-- abort message. This is not necessarily perfectly accurate, it is
-- just a reasonably accurate best guess. It is used to output the
-- source location in the abort message by Comperr, and also to
- -- implement the d3 debugging flag. This is also used by Rtsfind
- -- to generate error messages for high integrity mode.
+ -- implement the d3 debugging flag.
-- There are two ways this gets set. During parsing, when new source
-- nodes are being constructed by calls to New_Node and New_Entity,
@@ -285,8 +127,11 @@ package Atree is
-- Debug_A that mark the start and end of analysis/expansion of a
-- node in the tree.
- Current_Error_Node : Node_Id;
- -- Node to place error messages
+ -- Current_Error_Node is also used for other purposes. See, for example,
+ -- Rtsfind.
+
+ Current_Error_Node : Node_Id := Empty;
+ -- Node to place compiler abort messages
------------------
-- Error Counts --
@@ -347,77 +192,40 @@ package Atree is
-- bail out, assuming that the anomaly was caused by a previously detected
-- serious error (or configurable run time violation). This routine should
-- be called in these cases, and will raise an exception if no such error
- -- has been detected. This ensure that the anomaly is never allowed to go
- -- unnoticed.
-
- -------------------------------
- -- Default Setting of Fields --
- -------------------------------
-
- -- Nkind is set to N_Unused_At_Start
-
- -- Ekind is set to E_Void
-
- -- Sloc is always set, there is no default value
-
- -- Field1-5 fields are set to Empty
-
- -- Field6-41 fields in extended nodes are set to Empty
-
- -- Parent is set to Empty
-
- -- All Boolean flag fields are set to False
-
- -- Note: the value Empty is used in Field1-Field41 to indicate a null node.
- -- The usage varies. The common uses are to indicate absence of an optional
- -- clause or a completely unused Field1-35 field.
-
- -------------------------------------
- -- Use of Synonyms for Node Fields --
- -------------------------------------
-
- -- A subpackage Atree.Unchecked_Access provides routines for reading and
- -- writing the fields defined above (Field1-35, Node1-35, Flag0-317 etc).
- -- These unchecked access routines can be used for untyped traversals.
- -- In addition they are used in the implementations of the Sinfo and
- -- Einfo packages. These packages both provide logical synonyms for
- -- the generic fields, together with an appropriate set of access routines.
- -- Normally access to information within tree nodes uses these synonyms,
- -- providing a high level typed interface to the tree information.
+ -- has been detected. This ensures that the anomaly is never allowed to go
+ -- unnoticed in legal programs.
--------------------------------------------------
-- Node Allocation and Modification Subprograms --
--------------------------------------------------
- -- Generally the parser builds the tree and then it is further decorated
- -- (e.g. by setting the entity fields), but not fundamentally modified.
- -- However, there are cases in which the tree must be restructured by
- -- adding and rearranging nodes, as a result of disambiguating cases
- -- which the parser could not parse correctly, and adding additional
- -- semantic information (e.g. making constraint checks explicit). The
- -- following subprograms are used for constructing the tree in the first
- -- place, and then for subsequent modifications as required.
+ -- The following subprograms are used for constructing the tree in the
+ -- first place, and then for subsequent modifications as required.
procedure Initialize;
- -- Called at the start of compilation to initialize the allocation of the
- -- node and list tables and make the entries for Empty and Error.
+ -- Called at the start of compilation to make the entries for Empty and
+ -- Error.
procedure Lock;
- -- Called before the back end is invoked to lock the nodes table
- -- Also called after Unlock to relock???
+ -- Called before the back end is invoked to lock the nodes table.
+ -- Also called after Unlock to relock.
+
+ procedure Unlock;
+ -- Unlocks nodes table, in cases where the back end needs to modify it
procedure Lock_Nodes;
-- Called to lock node modifications when assertions are enabled; without
-- assertions calling this subprogram has no effect. The initial state of
-- the lock is unlocked.
- procedure Unlock;
- -- Unlocks nodes table, in cases where the back end needs to modify it
-
procedure Unlock_Nodes;
- -- Called to unlock entity modifications when assertions are enabled; if
+ -- Called to unlock node modifications when assertions are enabled; if
-- assertions are not enabled calling this subprogram has no effect.
+ function Is_Entity (N : Node_Or_Entity_Id) return Boolean;
+ pragma Inline (Is_Entity);
+ -- Returns True if N is an entity
+
function New_Node
(New_Node_Kind : Node_Kind;
New_Sloc : Source_Ptr) return Node_Id;
@@ -461,20 +269,12 @@ package Atree is
-- semantics in the reference manual. This procedure copies the setting
-- of Comes_From_Source from OldN to NewN.
- function Has_Extension (N : Node_Id) return Boolean;
- pragma Inline (Has_Extension);
- -- Returns True if the given node has an extension (i.e. was created by
- -- a call to New_Entity rather than New_Node, and Nkind is in N_Entity)
+ procedure Change_Node (N : Node_Id; New_Kind : Node_Kind);
+ -- This procedure replaces the given node by setting its Nkind field to the
+ -- indicated value and resetting all other fields to their default values
+ -- except for certain fields that are preserved (see body for details).
- procedure Change_Node (N : Node_Id; New_Node_Kind : Node_Kind);
- -- This procedure replaces the given node by setting its Nkind field to
- -- the indicated value and resetting all other fields to their default
- -- values except for Sloc, which is unchanged, and the Parent pointer
- -- and list links, which are also unchanged. All other information in
- -- the original node is lost. The new node has an extension if the
- -- original node had an extension.
-
- procedure Copy_Node (Source : Node_Id; Destination : Node_Id);
+ procedure Copy_Node (Source, Destination : Node_Or_Entity_Id);
-- Copy the entire contents of the source node to the destination node.
-- The contents of the source node is not affected. If the source node
-- has an extension, then the destination must have an extension also.
@@ -545,16 +345,8 @@ package Atree is
-- semantic chains: Homonym and Next_Entity: the corresponding links must
-- be adjusted by the caller, according to context.
- function Extend_Node (Source : Node_Id) return Entity_Id;
- -- This function returns a copy of its input node with an extension added.
- -- The fields of the extension are set to Empty. Due to the way extensions
- -- are handled (as four consecutive array elements), it may be necessary
- -- to reallocate the node, so that the returned value is not the same as
- -- the input value, but where possible the returned value will be the same
- -- as the input value (i.e. the extension will occur in place). It is the
- -- caller's responsibility to ensure that any pointers to the original node
- -- are appropriately updated. This function is used only by Sinfo.CN to
- -- change nodes into their corresponding entities.
+ procedure Extend_Node (Source : Node_Id);
+ -- This turns a node into an entity; it function is used only by Sinfo.CN.
type Ignored_Ghost_Record_Proc is access procedure (N : Node_Or_Entity_Id);
@@ -622,122 +414,36 @@ package Atree is
-- The following functions return the contents of the indicated field of
-- the node referenced by the argument, which is a Node_Id.
- function Analyzed (N : Node_Id) return Boolean;
- pragma Inline (Analyzed);
-
- function Check_Actuals (N : Node_Id) return Boolean;
- pragma Inline (Check_Actuals);
-
- function Comes_From_Source (N : Node_Id) return Boolean;
- pragma Inline (Comes_From_Source);
-
- function Error_Posted (N : Node_Id) return Boolean;
- pragma Inline (Error_Posted);
-
- function Has_Aspects (N : Node_Id) return Boolean;
- pragma Inline (Has_Aspects);
-
- function Is_Ignored_Ghost_Node (N : Node_Id) return Boolean;
- pragma Inline (Is_Ignored_Ghost_Node);
-
- function Nkind (N : Node_Id) return Node_Kind;
- pragma Inline (Nkind);
-
- function No (N : Node_Id) return Boolean;
+ function No (N : Node_Id) return Boolean;
pragma Inline (No);
-- Tests given Id for equality with the Empty node. This allows notations
-- like "if No (Variant_Part)" as opposed to "if Variant_Part = Empty".
- function Parent (N : Node_Id) return Node_Id;
+ function Parent (N : Node_Or_Entity_Id) return Node_Or_Entity_Id;
pragma Inline (Parent);
-- Returns the parent of a node if the node is not a list member, or else
-- the parent of the list containing the node if the node is a list member.
- function Paren_Count (N : Node_Id) return Nat;
+ function Paren_Count (N : Node_Id) return Nat;
pragma Inline (Paren_Count);
+ -- Number of parentheses that surround an expression
- function Present (N : Node_Id) return Boolean;
+ function Present (N : Node_Id) return Boolean;
pragma Inline (Present);
-- Tests given Id for inequality with the Empty node. This allows notations
-- like "if Present (Statement)" as opposed to "if Statement /= Empty".
- function Sloc (N : Node_Id) return Source_Ptr;
- pragma Inline (Sloc);
-
- -----------------------------
- -- Entity Access Functions --
- -----------------------------
-
- -- The following functions apply only to Entity_Id values, i.e.
- -- to extended nodes.
-
- function Ekind (E : Entity_Id) return Entity_Kind;
- pragma Inline (Ekind);
-
- function Convention (E : Entity_Id) return Convention_Id;
- pragma Inline (Convention);
-
- ----------------------------
- -- Node Update Procedures --
- ----------------------------
-
- -- The following functions set a specified field in the node whose Id is
- -- passed as the first argument. The second parameter is the new value
- -- to be set in the specified field. Note that Set_Nkind is in the next
- -- section, since its use is restricted.
-
- procedure Set_Analyzed (N : Node_Id; Val : Boolean := True);
- pragma Inline (Set_Analyzed);
-
- procedure Set_Check_Actuals (N : Node_Id; Val : Boolean := True);
- pragma Inline (Set_Check_Actuals);
-
- procedure Set_Comes_From_Source (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Comes_From_Source);
- -- Note that this routine is very rarely used, since usually the default
- -- mechanism provided sets the right value, but in some unusual cases, the
- -- value needs to be reset (e.g. when a source node is copied, and the copy
- -- must not have Comes_From_Source set).
-
- procedure Set_Error_Posted (N : Node_Id; Val : Boolean := True);
- pragma Inline (Set_Error_Posted);
-
- procedure Set_Has_Aspects (N : Node_Id; Val : Boolean := True);
- pragma Inline (Set_Has_Aspects);
-
- procedure Set_Is_Ignored_Ghost_Node (N : Node_Id; Val : Boolean := True);
- pragma Inline (Set_Is_Ignored_Ghost_Node);
-
- procedure Set_Original_Node (N : Node_Id; Val : Node_Id);
+ 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.
- procedure Set_Parent (N : Node_Id; Val : Node_Id);
+ procedure Set_Parent (N : Node_Or_Entity_Id; Val : Node_Or_Entity_Id);
pragma Inline (Set_Parent);
- procedure Set_Paren_Count (N : Node_Id; Val : Nat);
+ procedure Set_Paren_Count (N : Node_Id; Val : Nat);
pragma Inline (Set_Paren_Count);
- procedure Set_Sloc (N : Node_Id; Val : Source_Ptr);
- pragma Inline (Set_Sloc);
-
- ------------------------------
- -- Entity Update Procedures --
- ------------------------------
-
- -- The following procedures apply only to Entity_Id values, i.e.
- -- to extended nodes.
-
- procedure Basic_Set_Convention (E : Entity_Id; Val : Convention_Id);
- pragma Inline (Basic_Set_Convention);
- -- Clients should use Sem_Util.Set_Convention rather than calling this
- -- routine directly, as Set_Convention also deals with the special
- -- processing required for access types.
-
- procedure Set_Ekind (E : Entity_Id; Val : Entity_Kind);
- pragma Inline (Set_Ekind);
-
---------------------------
-- Tree Rewrite Routines --
---------------------------
@@ -806,17 +512,15 @@ package Atree is
-- original node, i.e. the old contents of Old_Node.
procedure Replace (Old_Node, New_Node : Node_Id);
- -- This is similar to Rewrite, except that the old value of Old_Node is
- -- not saved, and the New_Node is deleted after the replace, since it
- -- is assumed that it can no longer be legitimately needed. The flag
+ -- This is similar to Rewrite, except that the old value of Old_Node
+ -- is not saved. New_Node should not be used after Replace. The flag
-- Is_Rewrite_Substitution will be False for the resulting node, unless
-- it was already true on entry, and Original_Node will not return the
- -- original contents of the Old_Node, but rather the New_Node value (unless
- -- Old_Node had already been rewritten using Rewrite). Replace also
- -- preserves the setting of Comes_From_Source.
+ -- original contents of the Old_Node, but rather the New_Node value.
+ -- Replace also preserves the setting of Comes_From_Source.
--
- -- Note, New_Node may not contain references to Old_Node, for example as
- -- descendants, since the rewrite would make such references invalid. If
+ -- Note that New_Node must not contain references to Old_Node, for example
+ -- as descendants, since the rewrite would make such references invalid. If
-- New_Node does need to reference Old_Node, then these references should
-- be to a relocated copy of Old_Node (see Relocate_Node procedure).
--
@@ -839,2804 +543,76 @@ package Atree is
--
-- Note: Parents are not preserved in original tree nodes that are
-- retrieved in this way (i.e. their children may have children whose
- -- pointers which reference some other node). This needs more details???
+ -- Parent pointers reference some other node).
--
-- Note: there is no direct mechanism for deleting an original node (in
-- a manner that can be reversed later). One possible approach is to use
-- Rewrite to substitute a null statement for the node to be deleted.
- -----------------------------------
- -- Generic Field Access Routines --
- -----------------------------------
-
- -- This subpackage provides the functions for accessing and procedures for
- -- setting fields that are normally referenced by wrapper subprograms (e.g.
- -- logical synonyms defined in packages Sinfo and Einfo, or specialized
- -- routines such as Rewrite (for Original_Node), or the node creation
- -- routines (for Set_Nkind). The implementations of these wrapper
- -- subprograms use the package Atree.Unchecked_Access as do various
- -- special case accesses where no wrapper applies. Documentation is always
- -- required for such a special case access explaining why it is needed.
-
- package Unchecked_Access is
-
- -- Functions to allow interpretation of Union_Id values as Uint and
- -- Ureal values.
-
- function To_Union is new Unchecked_Conversion (Uint, Union_Id);
- function To_Union is new Unchecked_Conversion (Ureal, Union_Id);
-
- function From_Union is new Unchecked_Conversion (Union_Id, Uint);
- function From_Union is new Unchecked_Conversion (Union_Id, Ureal);
-
- -- Functions to fetch contents of indicated field. It is an error to
- -- attempt to read the value of a field which is not present.
-
- function Field1 (N : Node_Id) return Union_Id;
- pragma Inline (Field1);
-
- function Field2 (N : Node_Id) return Union_Id;
- pragma Inline (Field2);
-
- function Field3 (N : Node_Id) return Union_Id;
- pragma Inline (Field3);
-
- function Field4 (N : Node_Id) return Union_Id;
- pragma Inline (Field4);
-
- function Field5 (N : Node_Id) return Union_Id;
- pragma Inline (Field5);
-
- function Field6 (N : Node_Id) return Union_Id;
- pragma Inline (Field6);
-
- function Field7 (N : Node_Id) return Union_Id;
- pragma Inline (Field7);
-
- function Field8 (N : Node_Id) return Union_Id;
- pragma Inline (Field8);
-
- function Field9 (N : Node_Id) return Union_Id;
- pragma Inline (Field9);
-
- function Field10 (N : Node_Id) return Union_Id;
- pragma Inline (Field10);
-
- function Field11 (N : Node_Id) return Union_Id;
- pragma Inline (Field11);
-
- function Field12 (N : Node_Id) return Union_Id;
- pragma Inline (Field12);
-
- function Field13 (N : Node_Id) return Union_Id;
- pragma Inline (Field13);
-
- function Field14 (N : Node_Id) return Union_Id;
- pragma Inline (Field14);
-
- function Field15 (N : Node_Id) return Union_Id;
- pragma Inline (Field15);
-
- function Field16 (N : Node_Id) return Union_Id;
- pragma Inline (Field16);
-
- function Field17 (N : Node_Id) return Union_Id;
- pragma Inline (Field17);
-
- function Field18 (N : Node_Id) return Union_Id;
- pragma Inline (Field18);
-
- function Field19 (N : Node_Id) return Union_Id;
- pragma Inline (Field19);
-
- function Field20 (N : Node_Id) return Union_Id;
- pragma Inline (Field20);
-
- function Field21 (N : Node_Id) return Union_Id;
- pragma Inline (Field21);
-
- function Field22 (N : Node_Id) return Union_Id;
- pragma Inline (Field22);
-
- function Field23 (N : Node_Id) return Union_Id;
- pragma Inline (Field23);
-
- function Field24 (N : Node_Id) return Union_Id;
- pragma Inline (Field24);
-
- function Field25 (N : Node_Id) return Union_Id;
- pragma Inline (Field25);
-
- function Field26 (N : Node_Id) return Union_Id;
- pragma Inline (Field26);
-
- function Field27 (N : Node_Id) return Union_Id;
- pragma Inline (Field27);
-
- function Field28 (N : Node_Id) return Union_Id;
- pragma Inline (Field28);
-
- function Field29 (N : Node_Id) return Union_Id;
- pragma Inline (Field29);
-
- function Field30 (N : Node_Id) return Union_Id;
- pragma Inline (Field30);
-
- function Field31 (N : Node_Id) return Union_Id;
- pragma Inline (Field31);
-
- function Field32 (N : Node_Id) return Union_Id;
- pragma Inline (Field32);
-
- function Field33 (N : Node_Id) return Union_Id;
- pragma Inline (Field33);
-
- function Field34 (N : Node_Id) return Union_Id;
- pragma Inline (Field34);
-
- function Field35 (N : Node_Id) return Union_Id;
- pragma Inline (Field35);
-
- function Field36 (N : Node_Id) return Union_Id;
- pragma Inline (Field36);
-
- function Field37 (N : Node_Id) return Union_Id;
- pragma Inline (Field37);
-
- function Field38 (N : Node_Id) return Union_Id;
- pragma Inline (Field38);
-
- function Field39 (N : Node_Id) return Union_Id;
- pragma Inline (Field39);
-
- function Field40 (N : Node_Id) return Union_Id;
- pragma Inline (Field40);
-
- function Field41 (N : Node_Id) return Union_Id;
- pragma Inline (Field41);
-
- function Node1 (N : Node_Id) return Node_Id;
- pragma Inline (Node1);
-
- function Node2 (N : Node_Id) return Node_Id;
- pragma Inline (Node2);
-
- function Node3 (N : Node_Id) return Node_Id;
- pragma Inline (Node3);
-
- function Node4 (N : Node_Id) return Node_Id;
- pragma Inline (Node4);
-
- function Node5 (N : Node_Id) return Node_Id;
- pragma Inline (Node5);
-
- function Node6 (N : Node_Id) return Node_Id;
- pragma Inline (Node6);
-
- function Node7 (N : Node_Id) return Node_Id;
- pragma Inline (Node7);
-
- function Node8 (N : Node_Id) return Node_Id;
- pragma Inline (Node8);
-
- function Node9 (N : Node_Id) return Node_Id;
- pragma Inline (Node9);
-
- function Node10 (N : Node_Id) return Node_Id;
- pragma Inline (Node10);
-
- function Node11 (N : Node_Id) return Node_Id;
- pragma Inline (Node11);
-
- function Node12 (N : Node_Id) return Node_Id;
- pragma Inline (Node12);
-
- function Node13 (N : Node_Id) return Node_Id;
- pragma Inline (Node13);
-
- function Node14 (N : Node_Id) return Node_Id;
- pragma Inline (Node14);
-
- function Node15 (N : Node_Id) return Node_Id;
- pragma Inline (Node15);
-
- function Node16 (N : Node_Id) return Node_Id;
- pragma Inline (Node16);
-
- function Node17 (N : Node_Id) return Node_Id;
- pragma Inline (Node17);
-
- function Node18 (N : Node_Id) return Node_Id;
- pragma Inline (Node18);
-
- function Node19 (N : Node_Id) return Node_Id;
- pragma Inline (Node19);
-
- function Node20 (N : Node_Id) return Node_Id;
- pragma Inline (Node20);
-
- function Node21 (N : Node_Id) return Node_Id;
- pragma Inline (Node21);
-
- function Node22 (N : Node_Id) return Node_Id;
- pragma Inline (Node22);
-
- function Node23 (N : Node_Id) return Node_Id;
- pragma Inline (Node23);
-
- function Node24 (N : Node_Id) return Node_Id;
- pragma Inline (Node24);
-
- function Node25 (N : Node_Id) return Node_Id;
- pragma Inline (Node25);
-
- function Node26 (N : Node_Id) return Node_Id;
- pragma Inline (Node26);
-
- function Node27 (N : Node_Id) return Node_Id;
- pragma Inline (Node27);
-
- function Node28 (N : Node_Id) return Node_Id;
- pragma Inline (Node28);
-
- function Node29 (N : Node_Id) return Node_Id;
- pragma Inline (Node29);
-
- function Node30 (N : Node_Id) return Node_Id;
- pragma Inline (Node30);
-
- function Node31 (N : Node_Id) return Node_Id;
- pragma Inline (Node31);
-
- function Node32 (N : Node_Id) return Node_Id;
- pragma Inline (Node32);
-
- function Node33 (N : Node_Id) return Node_Id;
- pragma Inline (Node33);
-
- function Node34 (N : Node_Id) return Node_Id;
- pragma Inline (Node34);
-
- function Node35 (N : Node_Id) return Node_Id;
- pragma Inline (Node35);
-
- function Node36 (N : Node_Id) return Node_Id;
- pragma Inline (Node36);
-
- function Node37 (N : Node_Id) return Node_Id;
- pragma Inline (Node37);
-
- function Node38 (N : Node_Id) return Node_Id;
- pragma Inline (Node38);
-
- function Node39 (N : Node_Id) return Node_Id;
- pragma Inline (Node39);
-
- function Node40 (N : Node_Id) return Node_Id;
- pragma Inline (Node40);
-
- function Node41 (N : Node_Id) return Node_Id;
- pragma Inline (Node41);
-
- function List1 (N : Node_Id) return List_Id;
- pragma Inline (List1);
-
- function List2 (N : Node_Id) return List_Id;
- pragma Inline (List2);
-
- function List3 (N : Node_Id) return List_Id;
- pragma Inline (List3);
-
- function List4 (N : Node_Id) return List_Id;
- pragma Inline (List4);
-
- function List5 (N : Node_Id) return List_Id;
- pragma Inline (List5);
-
- function List10 (N : Node_Id) return List_Id;
- pragma Inline (List10);
-
- function List14 (N : Node_Id) return List_Id;
- pragma Inline (List14);
-
- function List25 (N : Node_Id) return List_Id;
- pragma Inline (List25);
-
- function List38 (N : Node_Id) return List_Id;
- pragma Inline (List38);
-
- function List39 (N : Node_Id) return List_Id;
- pragma Inline (List39);
-
- function Elist1 (N : Node_Id) return Elist_Id;
- pragma Inline (Elist1);
-
- function Elist2 (N : Node_Id) return Elist_Id;
- pragma Inline (Elist2);
-
- function Elist3 (N : Node_Id) return Elist_Id;
- pragma Inline (Elist3);
-
- function Elist4 (N : Node_Id) return Elist_Id;
- pragma Inline (Elist4);
-
- function Elist5 (N : Node_Id) return Elist_Id;
- pragma Inline (Elist5);
-
- function Elist8 (N : Node_Id) return Elist_Id;
- pragma Inline (Elist8);
-
- function Elist9 (N : Node_Id) return Elist_Id;
- pragma Inline (Elist9);
-
- function Elist10 (N : Node_Id) return Elist_Id;
- pragma Inline (Elist10);
-
- function Elist11 (N : Node_Id) return Elist_Id;
- pragma Inline (Elist11);
-
- function Elist13 (N : Node_Id) return Elist_Id;
- pragma Inline (Elist13);
-
- function Elist15 (N : Node_Id) return Elist_Id;
- pragma Inline (Elist15);
-
- function Elist16 (N : Node_Id) return Elist_Id;
- pragma Inline (Elist16);
-
- function Elist18 (N : Node_Id) return Elist_Id;
- pragma Inline (Elist18);
-
- function Elist21 (N : Node_Id) return Elist_Id;
- pragma Inline (Elist21);
-
- function Elist23 (N : Node_Id) return Elist_Id;
- pragma Inline (Elist23);
-
- function Elist24 (N : Node_Id) return Elist_Id;
- pragma Inline (Elist24);
-
- function Elist25 (N : Node_Id) return Elist_Id;
- pragma Inline (Elist25);
-
- function Elist26 (N : Node_Id) return Elist_Id;
- pragma Inline (Elist26);
-
- function Elist29 (N : Node_Id) return Elist_Id;
- pragma Inline (Elist29);
-
- function Elist30 (N : Node_Id) return Elist_Id;
- pragma Inline (Elist30);
-
- function Elist36 (N : Node_Id) return Elist_Id;
- pragma Inline (Elist36);
-
- function Name1 (N : Node_Id) return Name_Id;
- pragma Inline (Name1);
-
- function Name2 (N : Node_Id) return Name_Id;
- pragma Inline (Name2);
-
- function Str3 (N : Node_Id) return String_Id;
- pragma Inline (Str3);
-
- -- Note: the following Uintnn functions have a special test for the
- -- Field value being Empty. If an Empty value is found then Uint_0 is
- -- returned. This avoids the rather tricky requirement of initializing
- -- all Uint fields in nodes and entities.
-
- function Uint2 (N : Node_Id) return Uint;
- pragma Inline (Uint2);
-
- function Uint3 (N : Node_Id) return Uint;
- pragma Inline (Uint3);
-
- function Uint4 (N : Node_Id) return Uint;
- pragma Inline (Uint4);
-
- function Uint5 (N : Node_Id) return Uint;
- pragma Inline (Uint5);
-
- function Uint8 (N : Node_Id) return Uint;
- pragma Inline (Uint8);
-
- function Uint9 (N : Node_Id) return Uint;
- pragma Inline (Uint9);
-
- function Uint10 (N : Node_Id) return Uint;
- pragma Inline (Uint10);
-
- function Uint11 (N : Node_Id) return Uint;
- pragma Inline (Uint11);
-
- function Uint12 (N : Node_Id) return Uint;
- pragma Inline (Uint12);
-
- function Uint13 (N : Node_Id) return Uint;
- pragma Inline (Uint13);
-
- function Uint14 (N : Node_Id) return Uint;
- pragma Inline (Uint14);
-
- function Uint15 (N : Node_Id) return Uint;
- pragma Inline (Uint15);
-
- function Uint16 (N : Node_Id) return Uint;
- pragma Inline (Uint16);
-
- function Uint17 (N : Node_Id) return Uint;
- pragma Inline (Uint17);
-
- function Uint22 (N : Node_Id) return Uint;
- pragma Inline (Uint22);
-
- function Uint24 (N : Node_Id) return Uint;
- pragma Inline (Uint24);
-
- function Ureal3 (N : Node_Id) return Ureal;
- pragma Inline (Ureal3);
-
- function Ureal18 (N : Node_Id) return Ureal;
- pragma Inline (Ureal18);
-
- function Ureal21 (N : Node_Id) return Ureal;
- pragma Inline (Ureal21);
-
- function Flag0 (N : Node_Id) return Boolean;
- pragma Inline (Flag0);
-
- function Flag1 (N : Node_Id) return Boolean;
- pragma Inline (Flag1);
-
- function Flag2 (N : Node_Id) return Boolean;
- pragma Inline (Flag2);
-
- function Flag3 (N : Node_Id) return Boolean;
- pragma Inline (Flag3);
-
- function Flag4 (N : Node_Id) return Boolean;
- pragma Inline (Flag4);
-
- function Flag5 (N : Node_Id) return Boolean;
- pragma Inline (Flag5);
-
- function Flag6 (N : Node_Id) return Boolean;
- pragma Inline (Flag6);
-
- function Flag7 (N : Node_Id) return Boolean;
- pragma Inline (Flag7);
-
- function Flag8 (N : Node_Id) return Boolean;
- pragma Inline (Flag8);
-
- function Flag9 (N : Node_Id) return Boolean;
- pragma Inline (Flag9);
-
- function Flag10 (N : Node_Id) return Boolean;
- pragma Inline (Flag10);
-
- function Flag11 (N : Node_Id) return Boolean;
- pragma Inline (Flag11);
-
- function Flag12 (N : Node_Id) return Boolean;
- pragma Inline (Flag12);
-
- function Flag13 (N : Node_Id) return Boolean;
- pragma Inline (Flag13);
-
- function Flag14 (N : Node_Id) return Boolean;
- pragma Inline (Flag14);
-
- function Flag15 (N : Node_Id) return Boolean;
- pragma Inline (Flag15);
-
- function Flag16 (N : Node_Id) return Boolean;
- pragma Inline (Flag16);
-
- function Flag17 (N : Node_Id) return Boolean;
- pragma Inline (Flag17);
-
- function Flag18 (N : Node_Id) return Boolean;
- pragma Inline (Flag18);
-
- function Flag19 (N : Node_Id) return Boolean;
- pragma Inline (Flag19);
-
- function Flag20 (N : Node_Id) return Boolean;
- pragma Inline (Flag20);
-
- function Flag21 (N : Node_Id) return Boolean;
- pragma Inline (Flag21);
-
- function Flag22 (N : Node_Id) return Boolean;
- pragma Inline (Flag22);
-
- function Flag23 (N : Node_Id) return Boolean;
- pragma Inline (Flag23);
-
- function Flag24 (N : Node_Id) return Boolean;
- pragma Inline (Flag24);
-
- function Flag25 (N : Node_Id) return Boolean;
- pragma Inline (Flag25);
-
- function Flag26 (N : Node_Id) return Boolean;
- pragma Inline (Flag26);
-
- function Flag27 (N : Node_Id) return Boolean;
- pragma Inline (Flag27);
-
- function Flag28 (N : Node_Id) return Boolean;
- pragma Inline (Flag28);
-
- function Flag29 (N : Node_Id) return Boolean;
- pragma Inline (Flag29);
-
- function Flag30 (N : Node_Id) return Boolean;
- pragma Inline (Flag30);
-
- function Flag31 (N : Node_Id) return Boolean;
- pragma Inline (Flag31);
-
- function Flag32 (N : Node_Id) return Boolean;
- pragma Inline (Flag32);
-
- function Flag33 (N : Node_Id) return Boolean;
- pragma Inline (Flag33);
-
- function Flag34 (N : Node_Id) return Boolean;
- pragma Inline (Flag34);
-
- function Flag35 (N : Node_Id) return Boolean;
- pragma Inline (Flag35);
-
- function Flag36 (N : Node_Id) return Boolean;
- pragma Inline (Flag36);
-
- function Flag37 (N : Node_Id) return Boolean;
- pragma Inline (Flag37);
-
- function Flag38 (N : Node_Id) return Boolean;
- pragma Inline (Flag38);
-
- function Flag39 (N : Node_Id) return Boolean;
- pragma Inline (Flag39);
-
- function Flag40 (N : Node_Id) return Boolean;
- pragma Inline (Flag40);
-
- function Flag41 (N : Node_Id) return Boolean;
- pragma Inline (Flag41);
-
- function Flag42 (N : Node_Id) return Boolean;
- pragma Inline (Flag42);
-
- function Flag43 (N : Node_Id) return Boolean;
- pragma Inline (Flag43);
-
- function Flag44 (N : Node_Id) return Boolean;
- pragma Inline (Flag44);
-
- function Flag45 (N : Node_Id) return Boolean;
- pragma Inline (Flag45);
-
- function Flag46 (N : Node_Id) return Boolean;
- pragma Inline (Flag46);
-
- function Flag47 (N : Node_Id) return Boolean;
- pragma Inline (Flag47);
-
- function Flag48 (N : Node_Id) return Boolean;
- pragma Inline (Flag48);
-
- function Flag49 (N : Node_Id) return Boolean;
- pragma Inline (Flag49);
-
- function Flag50 (N : Node_Id) return Boolean;
- pragma Inline (Flag50);
-
- function Flag51 (N : Node_Id) return Boolean;
- pragma Inline (Flag51);
-
- function Flag52 (N : Node_Id) return Boolean;
- pragma Inline (Flag52);
-
- function Flag53 (N : Node_Id) return Boolean;
- pragma Inline (Flag53);
-
- function Flag54 (N : Node_Id) return Boolean;
- pragma Inline (Flag54);
-
- function Flag55 (N : Node_Id) return Boolean;
- pragma Inline (Flag55);
-
- function Flag56 (N : Node_Id) return Boolean;
- pragma Inline (Flag56);
-
- function Flag57 (N : Node_Id) return Boolean;
- pragma Inline (Flag57);
-
- function Flag58 (N : Node_Id) return Boolean;
- pragma Inline (Flag58);
-
- function Flag59 (N : Node_Id) return Boolean;
- pragma Inline (Flag59);
-
- function Flag60 (N : Node_Id) return Boolean;
- pragma Inline (Flag60);
-
- function Flag61 (N : Node_Id) return Boolean;
- pragma Inline (Flag61);
-
- function Flag62 (N : Node_Id) return Boolean;
- pragma Inline (Flag62);
-
- function Flag63 (N : Node_Id) return Boolean;
- pragma Inline (Flag63);
-
- function Flag64 (N : Node_Id) return Boolean;
- pragma Inline (Flag64);
-
- function Flag65 (N : Node_Id) return Boolean;
- pragma Inline (Flag65);
-
- function Flag66 (N : Node_Id) return Boolean;
- pragma Inline (Flag66);
-
- function Flag67 (N : Node_Id) return Boolean;
- pragma Inline (Flag67);
-
- function Flag68 (N : Node_Id) return Boolean;
- pragma Inline (Flag68);
-
- function Flag69 (N : Node_Id) return Boolean;
- pragma Inline (Flag69);
-
- function Flag70 (N : Node_Id) return Boolean;
- pragma Inline (Flag70);
-
- function Flag71 (N : Node_Id) return Boolean;
- pragma Inline (Flag71);
-
- function Flag72 (N : Node_Id) return Boolean;
- pragma Inline (Flag72);
-
- function Flag73 (N : Node_Id) return Boolean;
- pragma Inline (Flag73);
-
- function Flag74 (N : Node_Id) return Boolean;
- pragma Inline (Flag74);
-
- function Flag75 (N : Node_Id) return Boolean;
- pragma Inline (Flag75);
-
- function Flag76 (N : Node_Id) return Boolean;
- pragma Inline (Flag76);
-
- function Flag77 (N : Node_Id) return Boolean;
- pragma Inline (Flag77);
-
- function Flag78 (N : Node_Id) return Boolean;
- pragma Inline (Flag78);
-
- function Flag79 (N : Node_Id) return Boolean;
- pragma Inline (Flag79);
-
- function Flag80 (N : Node_Id) return Boolean;
- pragma Inline (Flag80);
-
- function Flag81 (N : Node_Id) return Boolean;
- pragma Inline (Flag81);
-
- function Flag82 (N : Node_Id) return Boolean;
- pragma Inline (Flag82);
-
- function Flag83 (N : Node_Id) return Boolean;
- pragma Inline (Flag83);
-
- function Flag84 (N : Node_Id) return Boolean;
- pragma Inline (Flag84);
-
- function Flag85 (N : Node_Id) return Boolean;
- pragma Inline (Flag85);
-
- function Flag86 (N : Node_Id) return Boolean;
- pragma Inline (Flag86);
-
- function Flag87 (N : Node_Id) return Boolean;
- pragma Inline (Flag87);
-
- function Flag88 (N : Node_Id) return Boolean;
- pragma Inline (Flag88);
-
- function Flag89 (N : Node_Id) return Boolean;
- pragma Inline (Flag89);
-
- function Flag90 (N : Node_Id) return Boolean;
- pragma Inline (Flag90);
-
- function Flag91 (N : Node_Id) return Boolean;
- pragma Inline (Flag91);
-
- function Flag92 (N : Node_Id) return Boolean;
- pragma Inline (Flag92);
-
- function Flag93 (N : Node_Id) return Boolean;
- pragma Inline (Flag93);
-
- function Flag94 (N : Node_Id) return Boolean;
- pragma Inline (Flag94);
-
- function Flag95 (N : Node_Id) return Boolean;
- pragma Inline (Flag95);
-
- function Flag96 (N : Node_Id) return Boolean;
- pragma Inline (Flag96);
-
- function Flag97 (N : Node_Id) return Boolean;
- pragma Inline (Flag97);
-
- function Flag98 (N : Node_Id) return Boolean;
- pragma Inline (Flag98);
-
- function Flag99 (N : Node_Id) return Boolean;
- pragma Inline (Flag99);
-
- function Flag100 (N : Node_Id) return Boolean;
- pragma Inline (Flag100);
-
- function Flag101 (N : Node_Id) return Boolean;
- pragma Inline (Flag101);
-
- function Flag102 (N : Node_Id) return Boolean;
- pragma Inline (Flag102);
-
- function Flag103 (N : Node_Id) return Boolean;
- pragma Inline (Flag103);
-
- function Flag104 (N : Node_Id) return Boolean;
- pragma Inline (Flag104);
-
- function Flag105 (N : Node_Id) return Boolean;
- pragma Inline (Flag105);
-
- function Flag106 (N : Node_Id) return Boolean;
- pragma Inline (Flag106);
-
- function Flag107 (N : Node_Id) return Boolean;
- pragma Inline (Flag107);
-
- function Flag108 (N : Node_Id) return Boolean;
- pragma Inline (Flag108);
-
- function Flag109 (N : Node_Id) return Boolean;
- pragma Inline (Flag109);
-
- function Flag110 (N : Node_Id) return Boolean;
- pragma Inline (Flag110);
-
- function Flag111 (N : Node_Id) return Boolean;
- pragma Inline (Flag111);
-
- function Flag112 (N : Node_Id) return Boolean;
- pragma Inline (Flag112);
-
- function Flag113 (N : Node_Id) return Boolean;
- pragma Inline (Flag113);
-
- function Flag114 (N : Node_Id) return Boolean;
- pragma Inline (Flag114);
-
- function Flag115 (N : Node_Id) return Boolean;
- pragma Inline (Flag115);
-
- function Flag116 (N : Node_Id) return Boolean;
- pragma Inline (Flag116);
-
- function Flag117 (N : Node_Id) return Boolean;
- pragma Inline (Flag117);
-
- function Flag118 (N : Node_Id) return Boolean;
- pragma Inline (Flag118);
-
- function Flag119 (N : Node_Id) return Boolean;
- pragma Inline (Flag119);
-
- function Flag120 (N : Node_Id) return Boolean;
- pragma Inline (Flag120);
-
- function Flag121 (N : Node_Id) return Boolean;
- pragma Inline (Flag121);
-
- function Flag122 (N : Node_Id) return Boolean;
- pragma Inline (Flag122);
-
- function Flag123 (N : Node_Id) return Boolean;
- pragma Inline (Flag123);
-
- function Flag124 (N : Node_Id) return Boolean;
- pragma Inline (Flag124);
-
- function Flag125 (N : Node_Id) return Boolean;
- pragma Inline (Flag125);
-
- function Flag126 (N : Node_Id) return Boolean;
- pragma Inline (Flag126);
-
- function Flag127 (N : Node_Id) return Boolean;
- pragma Inline (Flag127);
-
- function Flag128 (N : Node_Id) return Boolean;
- pragma Inline (Flag128);
-
- function Flag129 (N : Node_Id) return Boolean;
- pragma Inline (Flag129);
-
- function Flag130 (N : Node_Id) return Boolean;
- pragma Inline (Flag130);
-
- function Flag131 (N : Node_Id) return Boolean;
- pragma Inline (Flag131);
-
- function Flag132 (N : Node_Id) return Boolean;
- pragma Inline (Flag132);
-
- function Flag133 (N : Node_Id) return Boolean;
- pragma Inline (Flag133);
-
- function Flag134 (N : Node_Id) return Boolean;
- pragma Inline (Flag134);
-
- function Flag135 (N : Node_Id) return Boolean;
- pragma Inline (Flag135);
-
- function Flag136 (N : Node_Id) return Boolean;
- pragma Inline (Flag136);
-
- function Flag137 (N : Node_Id) return Boolean;
- pragma Inline (Flag137);
-
- function Flag138 (N : Node_Id) return Boolean;
- pragma Inline (Flag138);
-
- function Flag139 (N : Node_Id) return Boolean;
- pragma Inline (Flag139);
-
- function Flag140 (N : Node_Id) return Boolean;
- pragma Inline (Flag140);
-
- function Flag141 (N : Node_Id) return Boolean;
- pragma Inline (Flag141);
-
- function Flag142 (N : Node_Id) return Boolean;
- pragma Inline (Flag142);
-
- function Flag143 (N : Node_Id) return Boolean;
- pragma Inline (Flag143);
-
- function Flag144 (N : Node_Id) return Boolean;
- pragma Inline (Flag144);
-
- function Flag145 (N : Node_Id) return Boolean;
- pragma Inline (Flag145);
-
- function Flag146 (N : Node_Id) return Boolean;
- pragma Inline (Flag146);
-
- function Flag147 (N : Node_Id) return Boolean;
- pragma Inline (Flag147);
-
- function Flag148 (N : Node_Id) return Boolean;
- pragma Inline (Flag148);
-
- function Flag149 (N : Node_Id) return Boolean;
- pragma Inline (Flag149);
-
- function Flag150 (N : Node_Id) return Boolean;
- pragma Inline (Flag150);
-
- function Flag151 (N : Node_Id) return Boolean;
- pragma Inline (Flag151);
-
- function Flag152 (N : Node_Id) return Boolean;
- pragma Inline (Flag152);
-
- function Flag153 (N : Node_Id) return Boolean;
- pragma Inline (Flag153);
-
- function Flag154 (N : Node_Id) return Boolean;
- pragma Inline (Flag154);
-
- function Flag155 (N : Node_Id) return Boolean;
- pragma Inline (Flag155);
-
- function Flag156 (N : Node_Id) return Boolean;
- pragma Inline (Flag156);
-
- function Flag157 (N : Node_Id) return Boolean;
- pragma Inline (Flag157);
-
- function Flag158 (N : Node_Id) return Boolean;
- pragma Inline (Flag158);
-
- function Flag159 (N : Node_Id) return Boolean;
- pragma Inline (Flag159);
-
- function Flag160 (N : Node_Id) return Boolean;
- pragma Inline (Flag160);
-
- function Flag161 (N : Node_Id) return Boolean;
- pragma Inline (Flag161);
-
- function Flag162 (N : Node_Id) return Boolean;
- pragma Inline (Flag162);
-
- function Flag163 (N : Node_Id) return Boolean;
- pragma Inline (Flag163);
-
- function Flag164 (N : Node_Id) return Boolean;
- pragma Inline (Flag164);
-
- function Flag165 (N : Node_Id) return Boolean;
- pragma Inline (Flag165);
-
- function Flag166 (N : Node_Id) return Boolean;
- pragma Inline (Flag166);
-
- function Flag167 (N : Node_Id) return Boolean;
- pragma Inline (Flag167);
-
- function Flag168 (N : Node_Id) return Boolean;
- pragma Inline (Flag168);
-
- function Flag169 (N : Node_Id) return Boolean;
- pragma Inline (Flag169);
-
- function Flag170 (N : Node_Id) return Boolean;
- pragma Inline (Flag170);
-
- function Flag171 (N : Node_Id) return Boolean;
- pragma Inline (Flag171);
-
- function Flag172 (N : Node_Id) return Boolean;
- pragma Inline (Flag172);
-
- function Flag173 (N : Node_Id) return Boolean;
- pragma Inline (Flag173);
-
- function Flag174 (N : Node_Id) return Boolean;
- pragma Inline (Flag174);
-
- function Flag175 (N : Node_Id) return Boolean;
- pragma Inline (Flag175);
-
- function Flag176 (N : Node_Id) return Boolean;
- pragma Inline (Flag176);
-
- function Flag177 (N : Node_Id) return Boolean;
- pragma Inline (Flag177);
-
- function Flag178 (N : Node_Id) return Boolean;
- pragma Inline (Flag178);
-
- function Flag179 (N : Node_Id) return Boolean;
- pragma Inline (Flag179);
-
- function Flag180 (N : Node_Id) return Boolean;
- pragma Inline (Flag180);
-
- function Flag181 (N : Node_Id) return Boolean;
- pragma Inline (Flag181);
-
- function Flag182 (N : Node_Id) return Boolean;
- pragma Inline (Flag182);
-
- function Flag183 (N : Node_Id) return Boolean;
- pragma Inline (Flag183);
-
- function Flag184 (N : Node_Id) return Boolean;
- pragma Inline (Flag184);
-
- function Flag185 (N : Node_Id) return Boolean;
- pragma Inline (Flag185);
-
- function Flag186 (N : Node_Id) return Boolean;
- pragma Inline (Flag186);
-
- function Flag187 (N : Node_Id) return Boolean;
- pragma Inline (Flag187);
-
- function Flag188 (N : Node_Id) return Boolean;
- pragma Inline (Flag188);
-
- function Flag189 (N : Node_Id) return Boolean;
- pragma Inline (Flag189);
-
- function Flag190 (N : Node_Id) return Boolean;
- pragma Inline (Flag190);
-
- function Flag191 (N : Node_Id) return Boolean;
- pragma Inline (Flag191);
-
- function Flag192 (N : Node_Id) return Boolean;
- pragma Inline (Flag192);
-
- function Flag193 (N : Node_Id) return Boolean;
- pragma Inline (Flag193);
-
- function Flag194 (N : Node_Id) return Boolean;
- pragma Inline (Flag194);
-
- function Flag195 (N : Node_Id) return Boolean;
- pragma Inline (Flag195);
-
- function Flag196 (N : Node_Id) return Boolean;
- pragma Inline (Flag196);
-
- function Flag197 (N : Node_Id) return Boolean;
- pragma Inline (Flag197);
-
- function Flag198 (N : Node_Id) return Boolean;
- pragma Inline (Flag198);
-
- function Flag199 (N : Node_Id) return Boolean;
- pragma Inline (Flag199);
-
- function Flag200 (N : Node_Id) return Boolean;
- pragma Inline (Flag200);
-
- function Flag201 (N : Node_Id) return Boolean;
- pragma Inline (Flag201);
-
- function Flag202 (N : Node_Id) return Boolean;
- pragma Inline (Flag202);
-
- function Flag203 (N : Node_Id) return Boolean;
- pragma Inline (Flag203);
-
- function Flag204 (N : Node_Id) return Boolean;
- pragma Inline (Flag204);
-
- function Flag205 (N : Node_Id) return Boolean;
- pragma Inline (Flag205);
-
- function Flag206 (N : Node_Id) return Boolean;
- pragma Inline (Flag206);
-
- function Flag207 (N : Node_Id) return Boolean;
- pragma Inline (Flag207);
-
- function Flag208 (N : Node_Id) return Boolean;
- pragma Inline (Flag208);
-
- function Flag209 (N : Node_Id) return Boolean;
- pragma Inline (Flag209);
-
- function Flag210 (N : Node_Id) return Boolean;
- pragma Inline (Flag210);
-
- function Flag211 (N : Node_Id) return Boolean;
- pragma Inline (Flag211);
-
- function Flag212 (N : Node_Id) return Boolean;
- pragma Inline (Flag212);
-
- function Flag213 (N : Node_Id) return Boolean;
- pragma Inline (Flag213);
-
- function Flag214 (N : Node_Id) return Boolean;
- pragma Inline (Flag214);
-
- function Flag215 (N : Node_Id) return Boolean;
- pragma Inline (Flag215);
-
- function Flag216 (N : Node_Id) return Boolean;
- pragma Inline (Flag216);
-
- function Flag217 (N : Node_Id) return Boolean;
- pragma Inline (Flag217);
-
- function Flag218 (N : Node_Id) return Boolean;
- pragma Inline (Flag218);
-
- function Flag219 (N : Node_Id) return Boolean;
- pragma Inline (Flag219);
-
- function Flag220 (N : Node_Id) return Boolean;
- pragma Inline (Flag220);
-
- function Flag221 (N : Node_Id) return Boolean;
- pragma Inline (Flag221);
-
- function Flag222 (N : Node_Id) return Boolean;
- pragma Inline (Flag222);
-
- function Flag223 (N : Node_Id) return Boolean;
- pragma Inline (Flag223);
-
- function Flag224 (N : Node_Id) return Boolean;
- pragma Inline (Flag224);
-
- function Flag225 (N : Node_Id) return Boolean;
- pragma Inline (Flag225);
-
- function Flag226 (N : Node_Id) return Boolean;
- pragma Inline (Flag226);
-
- function Flag227 (N : Node_Id) return Boolean;
- pragma Inline (Flag227);
-
- function Flag228 (N : Node_Id) return Boolean;
- pragma Inline (Flag228);
-
- function Flag229 (N : Node_Id) return Boolean;
- pragma Inline (Flag229);
-
- function Flag230 (N : Node_Id) return Boolean;
- pragma Inline (Flag230);
-
- function Flag231 (N : Node_Id) return Boolean;
- pragma Inline (Flag231);
-
- function Flag232 (N : Node_Id) return Boolean;
- pragma Inline (Flag232);
-
- function Flag233 (N : Node_Id) return Boolean;
- pragma Inline (Flag233);
-
- function Flag234 (N : Node_Id) return Boolean;
- pragma Inline (Flag234);
-
- function Flag235 (N : Node_Id) return Boolean;
- pragma Inline (Flag235);
-
- function Flag236 (N : Node_Id) return Boolean;
- pragma Inline (Flag236);
-
- function Flag237 (N : Node_Id) return Boolean;
- pragma Inline (Flag237);
-
- function Flag238 (N : Node_Id) return Boolean;
- pragma Inline (Flag238);
-
- function Flag239 (N : Node_Id) return Boolean;
- pragma Inline (Flag239);
-
- function Flag240 (N : Node_Id) return Boolean;
- pragma Inline (Flag240);
-
- function Flag241 (N : Node_Id) return Boolean;
- pragma Inline (Flag241);
-
- function Flag242 (N : Node_Id) return Boolean;
- pragma Inline (Flag242);
-
- function Flag243 (N : Node_Id) return Boolean;
- pragma Inline (Flag243);
-
- function Flag244 (N : Node_Id) return Boolean;
- pragma Inline (Flag244);
-
- function Flag245 (N : Node_Id) return Boolean;
- pragma Inline (Flag245);
-
- function Flag246 (N : Node_Id) return Boolean;
- pragma Inline (Flag246);
-
- function Flag247 (N : Node_Id) return Boolean;
- pragma Inline (Flag247);
-
- function Flag248 (N : Node_Id) return Boolean;
- pragma Inline (Flag248);
-
- function Flag249 (N : Node_Id) return Boolean;
- pragma Inline (Flag249);
-
- function Flag250 (N : Node_Id) return Boolean;
- pragma Inline (Flag250);
-
- function Flag251 (N : Node_Id) return Boolean;
- pragma Inline (Flag251);
-
- function Flag252 (N : Node_Id) return Boolean;
- pragma Inline (Flag252);
-
- function Flag253 (N : Node_Id) return Boolean;
- pragma Inline (Flag253);
-
- function Flag254 (N : Node_Id) return Boolean;
- pragma Inline (Flag254);
-
- function Flag255 (N : Node_Id) return Boolean;
- pragma Inline (Flag255);
-
- function Flag256 (N : Node_Id) return Boolean;
- pragma Inline (Flag256);
-
- function Flag257 (N : Node_Id) return Boolean;
- pragma Inline (Flag257);
-
- function Flag258 (N : Node_Id) return Boolean;
- pragma Inline (Flag258);
-
- function Flag259 (N : Node_Id) return Boolean;
- pragma Inline (Flag259);
-
- function Flag260 (N : Node_Id) return Boolean;
- pragma Inline (Flag260);
-
- function Flag261 (N : Node_Id) return Boolean;
- pragma Inline (Flag261);
-
- function Flag262 (N : Node_Id) return Boolean;
- pragma Inline (Flag262);
-
- function Flag263 (N : Node_Id) return Boolean;
- pragma Inline (Flag263);
-
- function Flag264 (N : Node_Id) return Boolean;
- pragma Inline (Flag264);
-
- function Flag265 (N : Node_Id) return Boolean;
- pragma Inline (Flag265);
-
- function Flag266 (N : Node_Id) return Boolean;
- pragma Inline (Flag266);
-
- function Flag267 (N : Node_Id) return Boolean;
- pragma Inline (Flag267);
-
- function Flag268 (N : Node_Id) return Boolean;
- pragma Inline (Flag268);
-
- function Flag269 (N : Node_Id) return Boolean;
- pragma Inline (Flag269);
-
- function Flag270 (N : Node_Id) return Boolean;
- pragma Inline (Flag270);
-
- function Flag271 (N : Node_Id) return Boolean;
- pragma Inline (Flag271);
-
- function Flag272 (N : Node_Id) return Boolean;
- pragma Inline (Flag272);
-
- function Flag273 (N : Node_Id) return Boolean;
- pragma Inline (Flag273);
-
- function Flag274 (N : Node_Id) return Boolean;
- pragma Inline (Flag274);
-
- function Flag275 (N : Node_Id) return Boolean;
- pragma Inline (Flag275);
-
- function Flag276 (N : Node_Id) return Boolean;
- pragma Inline (Flag276);
-
- function Flag277 (N : Node_Id) return Boolean;
- pragma Inline (Flag277);
-
- function Flag278 (N : Node_Id) return Boolean;
- pragma Inline (Flag278);
-
- function Flag279 (N : Node_Id) return Boolean;
- pragma Inline (Flag279);
-
- function Flag280 (N : Node_Id) return Boolean;
- pragma Inline (Flag280);
-
- function Flag281 (N : Node_Id) return Boolean;
- pragma Inline (Flag281);
-
- function Flag282 (N : Node_Id) return Boolean;
- pragma Inline (Flag282);
-
- function Flag283 (N : Node_Id) return Boolean;
- pragma Inline (Flag283);
-
- function Flag284 (N : Node_Id) return Boolean;
- pragma Inline (Flag284);
-
- function Flag285 (N : Node_Id) return Boolean;
- pragma Inline (Flag285);
-
- function Flag286 (N : Node_Id) return Boolean;
- pragma Inline (Flag286);
-
- function Flag287 (N : Node_Id) return Boolean;
- pragma Inline (Flag287);
-
- function Flag288 (N : Node_Id) return Boolean;
- pragma Inline (Flag288);
-
- function Flag289 (N : Node_Id) return Boolean;
- pragma Inline (Flag289);
-
- function Flag290 (N : Node_Id) return Boolean;
- pragma Inline (Flag290);
-
- function Flag291 (N : Node_Id) return Boolean;
- pragma Inline (Flag291);
-
- function Flag292 (N : Node_Id) return Boolean;
- pragma Inline (Flag292);
-
- function Flag293 (N : Node_Id) return Boolean;
- pragma Inline (Flag293);
-
- function Flag294 (N : Node_Id) return Boolean;
- pragma Inline (Flag294);
-
- function Flag295 (N : Node_Id) return Boolean;
- pragma Inline (Flag295);
-
- function Flag296 (N : Node_Id) return Boolean;
- pragma Inline (Flag296);
-
- function Flag297 (N : Node_Id) return Boolean;
- pragma Inline (Flag297);
-
- function Flag298 (N : Node_Id) return Boolean;
- pragma Inline (Flag298);
-
- function Flag299 (N : Node_Id) return Boolean;
- pragma Inline (Flag299);
-
- function Flag300 (N : Node_Id) return Boolean;
- pragma Inline (Flag300);
-
- function Flag301 (N : Node_Id) return Boolean;
- pragma Inline (Flag301);
-
- function Flag302 (N : Node_Id) return Boolean;
- pragma Inline (Flag302);
-
- function Flag303 (N : Node_Id) return Boolean;
- pragma Inline (Flag303);
-
- function Flag304 (N : Node_Id) return Boolean;
- pragma Inline (Flag304);
-
- function Flag305 (N : Node_Id) return Boolean;
- pragma Inline (Flag305);
-
- function Flag306 (N : Node_Id) return Boolean;
- pragma Inline (Flag306);
-
- function Flag307 (N : Node_Id) return Boolean;
- pragma Inline (Flag307);
-
- function Flag308 (N : Node_Id) return Boolean;
- pragma Inline (Flag308);
-
- function Flag309 (N : Node_Id) return Boolean;
- pragma Inline (Flag309);
-
- function Flag310 (N : Node_Id) return Boolean;
- pragma Inline (Flag310);
-
- function Flag311 (N : Node_Id) return Boolean;
- pragma Inline (Flag311);
-
- function Flag312 (N : Node_Id) return Boolean;
- pragma Inline (Flag312);
-
- function Flag313 (N : Node_Id) return Boolean;
- pragma Inline (Flag313);
-
- function Flag314 (N : Node_Id) return Boolean;
- pragma Inline (Flag314);
-
- function Flag315 (N : Node_Id) return Boolean;
- pragma Inline (Flag315);
-
- function Flag316 (N : Node_Id) return Boolean;
- pragma Inline (Flag316);
-
- function Flag317 (N : Node_Id) return Boolean;
- pragma Inline (Flag317);
-
- -- Procedures to set value of indicated field
-
- procedure Set_Nkind (N : Node_Id; Val : Node_Kind);
- pragma Inline (Set_Nkind);
-
- procedure Set_Field1 (N : Node_Id; Val : Union_Id);
- pragma Inline (Set_Field1);
-
- procedure Set_Field2 (N : Node_Id; Val : Union_Id);
- pragma Inline (Set_Field2);
-
- procedure Set_Field3 (N : Node_Id; Val : Union_Id);
- pragma Inline (Set_Field3);
-
- procedure Set_Field4 (N : Node_Id; Val : Union_Id);
- pragma Inline (Set_Field4);
-
- procedure Set_Field5 (N : Node_Id; Val : Union_Id);
- pragma Inline (Set_Field5);
-
- procedure Set_Field6 (N : Node_Id; Val : Union_Id);
- pragma Inline (Set_Field6);
-
- procedure Set_Field7 (N : Node_Id; Val : Union_Id);
- pragma Inline (Set_Field7);
-
- procedure Set_Field8 (N : Node_Id; Val : Union_Id);
- pragma Inline (Set_Field8);
-
- procedure Set_Field9 (N : Node_Id; Val : Union_Id);
- pragma Inline (Set_Field9);
-
- procedure Set_Field10 (N : Node_Id; Val : Union_Id);
- pragma Inline (Set_Field10);
-
- procedure Set_Field11 (N : Node_Id; Val : Union_Id);
- pragma Inline (Set_Field11);
-
- procedure Set_Field12 (N : Node_Id; Val : Union_Id);
- pragma Inline (Set_Field12);
-
- procedure Set_Field13 (N : Node_Id; Val : Union_Id);
- pragma Inline (Set_Field13);
-
- procedure Set_Field14 (N : Node_Id; Val : Union_Id);
- pragma Inline (Set_Field14);
-
- procedure Set_Field15 (N : Node_Id; Val : Union_Id);
- pragma Inline (Set_Field15);
-
- procedure Set_Field16 (N : Node_Id; Val : Union_Id);
- pragma Inline (Set_Field16);
-
- procedure Set_Field17 (N : Node_Id; Val : Union_Id);
- pragma Inline (Set_Field17);
-
- procedure Set_Field18 (N : Node_Id; Val : Union_Id);
- pragma Inline (Set_Field18);
-
- procedure Set_Field19 (N : Node_Id; Val : Union_Id);
- pragma Inline (Set_Field19);
-
- procedure Set_Field20 (N : Node_Id; Val : Union_Id);
- pragma Inline (Set_Field20);
-
- procedure Set_Field21 (N : Node_Id; Val : Union_Id);
- pragma Inline (Set_Field21);
-
- procedure Set_Field22 (N : Node_Id; Val : Union_Id);
- pragma Inline (Set_Field22);
-
- procedure Set_Field23 (N : Node_Id; Val : Union_Id);
- pragma Inline (Set_Field23);
-
- procedure Set_Field24 (N : Node_Id; Val : Union_Id);
- pragma Inline (Set_Field24);
-
- procedure Set_Field25 (N : Node_Id; Val : Union_Id);
- pragma Inline (Set_Field25);
-
- procedure Set_Field26 (N : Node_Id; Val : Union_Id);
- pragma Inline (Set_Field26);
-
- procedure Set_Field27 (N : Node_Id; Val : Union_Id);
- pragma Inline (Set_Field27);
-
- procedure Set_Field28 (N : Node_Id; Val : Union_Id);
- pragma Inline (Set_Field28);
-
- procedure Set_Field29 (N : Node_Id; Val : Union_Id);
- pragma Inline (Set_Field29);
-
- procedure Set_Field30 (N : Node_Id; Val : Union_Id);
- pragma Inline (Set_Field30);
-
- procedure Set_Field31 (N : Node_Id; Val : Union_Id);
- pragma Inline (Set_Field31);
-
- procedure Set_Field32 (N : Node_Id; Val : Union_Id);
- pragma Inline (Set_Field32);
-
- procedure Set_Field33 (N : Node_Id; Val : Union_Id);
- pragma Inline (Set_Field33);
-
- procedure Set_Field34 (N : Node_Id; Val : Union_Id);
- pragma Inline (Set_Field34);
-
- procedure Set_Field35 (N : Node_Id; Val : Union_Id);
- pragma Inline (Set_Field35);
-
- procedure Set_Field36 (N : Node_Id; Val : Union_Id);
- pragma Inline (Set_Field36);
-
- procedure Set_Field37 (N : Node_Id; Val : Union_Id);
- pragma Inline (Set_Field37);
-
- procedure Set_Field38 (N : Node_Id; Val : Union_Id);
- pragma Inline (Set_Field38);
-
- procedure Set_Field39 (N : Node_Id; Val : Union_Id);
- pragma Inline (Set_Field39);
-
- procedure Set_Field40 (N : Node_Id; Val : Union_Id);
- pragma Inline (Set_Field40);
-
- procedure Set_Field41 (N : Node_Id; Val : Union_Id);
- pragma Inline (Set_Field41);
-
- procedure Set_Node1 (N : Node_Id; Val : Node_Id);
- pragma Inline (Set_Node1);
-
- procedure Set_Node2 (N : Node_Id; Val : Node_Id);
- pragma Inline (Set_Node2);
-
- procedure Set_Node3 (N : Node_Id; Val : Node_Id);
- pragma Inline (Set_Node3);
-
- procedure Set_Node4 (N : Node_Id; Val : Node_Id);
- pragma Inline (Set_Node4);
-
- procedure Set_Node5 (N : Node_Id; Val : Node_Id);
- pragma Inline (Set_Node5);
-
- procedure Set_Node6 (N : Node_Id; Val : Node_Id);
- pragma Inline (Set_Node6);
-
- procedure Set_Node7 (N : Node_Id; Val : Node_Id);
- pragma Inline (Set_Node7);
-
- procedure Set_Node8 (N : Node_Id; Val : Node_Id);
- pragma Inline (Set_Node8);
-
- procedure Set_Node9 (N : Node_Id; Val : Node_Id);
- pragma Inline (Set_Node9);
-
- procedure Set_Node10 (N : Node_Id; Val : Node_Id);
- pragma Inline (Set_Node10);
-
- procedure Set_Node11 (N : Node_Id; Val : Node_Id);
- pragma Inline (Set_Node11);
-
- procedure Set_Node12 (N : Node_Id; Val : Node_Id);
- pragma Inline (Set_Node12);
-
- procedure Set_Node13 (N : Node_Id; Val : Node_Id);
- pragma Inline (Set_Node13);
-
- procedure Set_Node14 (N : Node_Id; Val : Node_Id);
- pragma Inline (Set_Node14);
-
- procedure Set_Node15 (N : Node_Id; Val : Node_Id);
- pragma Inline (Set_Node15);
-
- procedure Set_Node16 (N : Node_Id; Val : Node_Id);
- pragma Inline (Set_Node16);
-
- procedure Set_Node17 (N : Node_Id; Val : Node_Id);
- pragma Inline (Set_Node17);
-
- procedure Set_Node18 (N : Node_Id; Val : Node_Id);
- pragma Inline (Set_Node18);
-
- procedure Set_Node19 (N : Node_Id; Val : Node_Id);
- pragma Inline (Set_Node19);
-
- procedure Set_Node20 (N : Node_Id; Val : Node_Id);
- pragma Inline (Set_Node20);
-
- procedure Set_Node21 (N : Node_Id; Val : Node_Id);
- pragma Inline (Set_Node21);
-
- procedure Set_Node22 (N : Node_Id; Val : Node_Id);
- pragma Inline (Set_Node22);
-
- procedure Set_Node23 (N : Node_Id; Val : Node_Id);
- pragma Inline (Set_Node23);
-
- procedure Set_Node24 (N : Node_Id; Val : Node_Id);
- pragma Inline (Set_Node24);
-
- procedure Set_Node25 (N : Node_Id; Val : Node_Id);
- pragma Inline (Set_Node25);
-
- procedure Set_Node26 (N : Node_Id; Val : Node_Id);
- pragma Inline (Set_Node26);
-
- procedure Set_Node27 (N : Node_Id; Val : Node_Id);
- pragma Inline (Set_Node27);
-
- procedure Set_Node28 (N : Node_Id; Val : Node_Id);
- pragma Inline (Set_Node28);
-
- procedure Set_Node29 (N : Node_Id; Val : Node_Id);
- pragma Inline (Set_Node29);
-
- procedure Set_Node30 (N : Node_Id; Val : Node_Id);
- pragma Inline (Set_Node30);
-
- procedure Set_Node31 (N : Node_Id; Val : Node_Id);
- pragma Inline (Set_Node31);
-
- procedure Set_Node32 (N : Node_Id; Val : Node_Id);
- pragma Inline (Set_Node32);
-
- procedure Set_Node33 (N : Node_Id; Val : Node_Id);
- pragma Inline (Set_Node33);
-
- procedure Set_Node34 (N : Node_Id; Val : Node_Id);
- pragma Inline (Set_Node34);
-
- procedure Set_Node35 (N : Node_Id; Val : Node_Id);
- pragma Inline (Set_Node35);
-
- procedure Set_Node36 (N : Node_Id; Val : Node_Id);
- pragma Inline (Set_Node36);
-
- procedure Set_Node37 (N : Node_Id; Val : Node_Id);
- pragma Inline (Set_Node37);
-
- procedure Set_Node38 (N : Node_Id; Val : Node_Id);
- pragma Inline (Set_Node38);
-
- procedure Set_Node39 (N : Node_Id; Val : Node_Id);
- pragma Inline (Set_Node39);
-
- procedure Set_Node40 (N : Node_Id; Val : Node_Id);
- pragma Inline (Set_Node40);
-
- procedure Set_Node41 (N : Node_Id; Val : Node_Id);
- pragma Inline (Set_Node41);
-
- procedure Set_List1 (N : Node_Id; Val : List_Id);
- pragma Inline (Set_List1);
-
- procedure Set_List2 (N : Node_Id; Val : List_Id);
- pragma Inline (Set_List2);
-
- procedure Set_List3 (N : Node_Id; Val : List_Id);
- pragma Inline (Set_List3);
-
- procedure Set_List4 (N : Node_Id; Val : List_Id);
- pragma Inline (Set_List4);
-
- procedure Set_List5 (N : Node_Id; Val : List_Id);
- pragma Inline (Set_List5);
-
- procedure Set_List10 (N : Node_Id; Val : List_Id);
- pragma Inline (Set_List10);
-
- procedure Set_List14 (N : Node_Id; Val : List_Id);
- pragma Inline (Set_List14);
-
- procedure Set_List25 (N : Node_Id; Val : List_Id);
- pragma Inline (Set_List25);
-
- procedure Set_List38 (N : Node_Id; Val : List_Id);
- pragma Inline (Set_List38);
-
- procedure Set_List39 (N : Node_Id; Val : List_Id);
- pragma Inline (Set_List39);
-
- procedure Set_Elist1 (N : Node_Id; Val : Elist_Id);
- pragma Inline (Set_Elist1);
-
- procedure Set_Elist2 (N : Node_Id; Val : Elist_Id);
- pragma Inline (Set_Elist2);
-
- procedure Set_Elist3 (N : Node_Id; Val : Elist_Id);
- pragma Inline (Set_Elist3);
-
- procedure Set_Elist4 (N : Node_Id; Val : Elist_Id);
- pragma Inline (Set_Elist4);
-
- procedure Set_Elist5 (N : Node_Id; Val : Elist_Id);
- pragma Inline (Set_Elist5);
-
- procedure Set_Elist8 (N : Node_Id; Val : Elist_Id);
- pragma Inline (Set_Elist8);
-
- procedure Set_Elist9 (N : Node_Id; Val : Elist_Id);
- pragma Inline (Set_Elist9);
-
- procedure Set_Elist10 (N : Node_Id; Val : Elist_Id);
- pragma Inline (Set_Elist10);
-
- procedure Set_Elist11 (N : Node_Id; Val : Elist_Id);
- pragma Inline (Set_Elist11);
-
- procedure Set_Elist13 (N : Node_Id; Val : Elist_Id);
- pragma Inline (Set_Elist13);
-
- procedure Set_Elist15 (N : Node_Id; Val : Elist_Id);
- pragma Inline (Set_Elist15);
-
- procedure Set_Elist16 (N : Node_Id; Val : Elist_Id);
- pragma Inline (Set_Elist16);
-
- procedure Set_Elist18 (N : Node_Id; Val : Elist_Id);
- pragma Inline (Set_Elist18);
-
- procedure Set_Elist21 (N : Node_Id; Val : Elist_Id);
- pragma Inline (Set_Elist21);
-
- procedure Set_Elist23 (N : Node_Id; Val : Elist_Id);
- pragma Inline (Set_Elist23);
-
- procedure Set_Elist24 (N : Node_Id; Val : Elist_Id);
- pragma Inline (Set_Elist24);
-
- procedure Set_Elist25 (N : Node_Id; Val : Elist_Id);
- pragma Inline (Set_Elist25);
-
- procedure Set_Elist26 (N : Node_Id; Val : Elist_Id);
- pragma Inline (Set_Elist26);
-
- procedure Set_Elist29 (N : Node_Id; Val : Elist_Id);
- pragma Inline (Set_Elist29);
-
- procedure Set_Elist30 (N : Node_Id; Val : Elist_Id);
- pragma Inline (Set_Elist30);
-
- procedure Set_Elist36 (N : Node_Id; Val : Elist_Id);
- pragma Inline (Set_Elist36);
-
- procedure Set_Name1 (N : Node_Id; Val : Name_Id);
- pragma Inline (Set_Name1);
-
- procedure Set_Name2 (N : Node_Id; Val : Name_Id);
- pragma Inline (Set_Name2);
-
- procedure Set_Str3 (N : Node_Id; Val : String_Id);
- pragma Inline (Set_Str3);
-
- procedure Set_Uint2 (N : Node_Id; Val : Uint);
- pragma Inline (Set_Uint2);
-
- procedure Set_Uint3 (N : Node_Id; Val : Uint);
- pragma Inline (Set_Uint3);
-
- procedure Set_Uint4 (N : Node_Id; Val : Uint);
- pragma Inline (Set_Uint4);
-
- procedure Set_Uint5 (N : Node_Id; Val : Uint);
- pragma Inline (Set_Uint5);
-
- procedure Set_Uint8 (N : Node_Id; Val : Uint);
- pragma Inline (Set_Uint8);
-
- procedure Set_Uint9 (N : Node_Id; Val : Uint);
- pragma Inline (Set_Uint9);
-
- procedure Set_Uint10 (N : Node_Id; Val : Uint);
- pragma Inline (Set_Uint10);
-
- procedure Set_Uint11 (N : Node_Id; Val : Uint);
- pragma Inline (Set_Uint11);
-
- procedure Set_Uint12 (N : Node_Id; Val : Uint);
- pragma Inline (Set_Uint12);
-
- procedure Set_Uint13 (N : Node_Id; Val : Uint);
- pragma Inline (Set_Uint13);
-
- procedure Set_Uint14 (N : Node_Id; Val : Uint);
- pragma Inline (Set_Uint14);
-
- procedure Set_Uint15 (N : Node_Id; Val : Uint);
- pragma Inline (Set_Uint15);
-
- procedure Set_Uint16 (N : Node_Id; Val : Uint);
- pragma Inline (Set_Uint16);
-
- procedure Set_Uint17 (N : Node_Id; Val : Uint);
- pragma Inline (Set_Uint17);
-
- procedure Set_Uint22 (N : Node_Id; Val : Uint);
- pragma Inline (Set_Uint22);
-
- procedure Set_Uint24 (N : Node_Id; Val : Uint);
- pragma Inline (Set_Uint24);
-
- procedure Set_Ureal3 (N : Node_Id; Val : Ureal);
- pragma Inline (Set_Ureal3);
-
- procedure Set_Ureal18 (N : Node_Id; Val : Ureal);
- pragma Inline (Set_Ureal18);
-
- procedure Set_Ureal21 (N : Node_Id; Val : Ureal);
- pragma Inline (Set_Ureal21);
-
- procedure Set_Flag0 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag0);
-
- procedure Set_Flag1 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag1);
-
- procedure Set_Flag2 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag2);
-
- procedure Set_Flag3 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag3);
-
- procedure Set_Flag4 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag4);
-
- procedure Set_Flag5 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag5);
-
- procedure Set_Flag6 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag6);
-
- procedure Set_Flag7 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag7);
-
- procedure Set_Flag8 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag8);
-
- procedure Set_Flag9 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag9);
-
- procedure Set_Flag10 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag10);
-
- procedure Set_Flag11 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag11);
-
- procedure Set_Flag12 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag12);
-
- procedure Set_Flag13 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag13);
-
- procedure Set_Flag14 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag14);
-
- procedure Set_Flag15 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag15);
-
- procedure Set_Flag16 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag16);
-
- procedure Set_Flag17 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag17);
-
- procedure Set_Flag18 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag18);
-
- procedure Set_Flag19 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag19);
-
- procedure Set_Flag20 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag20);
-
- procedure Set_Flag21 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag21);
-
- procedure Set_Flag22 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag22);
-
- procedure Set_Flag23 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag23);
-
- procedure Set_Flag24 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag24);
-
- procedure Set_Flag25 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag25);
-
- procedure Set_Flag26 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag26);
-
- procedure Set_Flag27 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag27);
-
- procedure Set_Flag28 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag28);
-
- procedure Set_Flag29 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag29);
-
- procedure Set_Flag30 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag30);
-
- procedure Set_Flag31 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag31);
-
- procedure Set_Flag32 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag32);
-
- procedure Set_Flag33 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag33);
-
- procedure Set_Flag34 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag34);
-
- procedure Set_Flag35 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag35);
-
- procedure Set_Flag36 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag36);
-
- procedure Set_Flag37 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag37);
-
- procedure Set_Flag38 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag38);
-
- procedure Set_Flag39 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag39);
-
- procedure Set_Flag40 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag40);
-
- procedure Set_Flag41 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag41);
-
- procedure Set_Flag42 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag42);
-
- procedure Set_Flag43 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag43);
-
- procedure Set_Flag44 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag44);
-
- procedure Set_Flag45 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag45);
-
- procedure Set_Flag46 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag46);
-
- procedure Set_Flag47 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag47);
-
- procedure Set_Flag48 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag48);
-
- procedure Set_Flag49 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag49);
-
- procedure Set_Flag50 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag50);
-
- procedure Set_Flag51 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag51);
-
- procedure Set_Flag52 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag52);
-
- procedure Set_Flag53 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag53);
-
- procedure Set_Flag54 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag54);
-
- procedure Set_Flag55 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag55);
-
- procedure Set_Flag56 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag56);
-
- procedure Set_Flag57 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag57);
-
- procedure Set_Flag58 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag58);
-
- procedure Set_Flag59 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag59);
-
- procedure Set_Flag60 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag60);
-
- procedure Set_Flag61 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag61);
-
- procedure Set_Flag62 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag62);
-
- procedure Set_Flag63 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag63);
-
- procedure Set_Flag64 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag64);
-
- procedure Set_Flag65 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag65);
-
- procedure Set_Flag66 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag66);
-
- procedure Set_Flag67 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag67);
-
- procedure Set_Flag68 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag68);
-
- procedure Set_Flag69 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag69);
-
- procedure Set_Flag70 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag70);
-
- procedure Set_Flag71 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag71);
-
- procedure Set_Flag72 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag72);
-
- procedure Set_Flag73 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag73);
-
- procedure Set_Flag74 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag74);
-
- procedure Set_Flag75 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag75);
-
- procedure Set_Flag76 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag76);
-
- procedure Set_Flag77 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag77);
-
- procedure Set_Flag78 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag78);
-
- procedure Set_Flag79 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag79);
-
- procedure Set_Flag80 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag80);
-
- procedure Set_Flag81 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag81);
-
- procedure Set_Flag82 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag82);
-
- procedure Set_Flag83 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag83);
-
- procedure Set_Flag84 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag84);
-
- procedure Set_Flag85 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag85);
-
- procedure Set_Flag86 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag86);
-
- procedure Set_Flag87 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag87);
-
- procedure Set_Flag88 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag88);
-
- procedure Set_Flag89 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag89);
-
- procedure Set_Flag90 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag90);
-
- procedure Set_Flag91 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag91);
-
- procedure Set_Flag92 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag92);
-
- procedure Set_Flag93 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag93);
-
- procedure Set_Flag94 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag94);
-
- procedure Set_Flag95 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag95);
-
- procedure Set_Flag96 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag96);
-
- procedure Set_Flag97 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag97);
-
- procedure Set_Flag98 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag98);
-
- procedure Set_Flag99 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag99);
-
- procedure Set_Flag100 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag100);
-
- procedure Set_Flag101 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag101);
-
- procedure Set_Flag102 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag102);
-
- procedure Set_Flag103 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag103);
-
- procedure Set_Flag104 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag104);
-
- procedure Set_Flag105 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag105);
-
- procedure Set_Flag106 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag106);
-
- procedure Set_Flag107 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag107);
-
- procedure Set_Flag108 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag108);
-
- procedure Set_Flag109 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag109);
-
- procedure Set_Flag110 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag110);
-
- procedure Set_Flag111 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag111);
-
- procedure Set_Flag112 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag112);
-
- procedure Set_Flag113 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag113);
-
- procedure Set_Flag114 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag114);
-
- procedure Set_Flag115 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag115);
-
- procedure Set_Flag116 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag116);
-
- procedure Set_Flag117 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag117);
-
- procedure Set_Flag118 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag118);
-
- procedure Set_Flag119 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag119);
-
- procedure Set_Flag120 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag120);
-
- procedure Set_Flag121 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag121);
-
- procedure Set_Flag122 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag122);
-
- procedure Set_Flag123 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag123);
-
- procedure Set_Flag124 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag124);
-
- procedure Set_Flag125 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag125);
-
- procedure Set_Flag126 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag126);
-
- procedure Set_Flag127 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag127);
-
- procedure Set_Flag128 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag128);
-
- procedure Set_Flag129 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag129);
-
- procedure Set_Flag130 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag130);
-
- procedure Set_Flag131 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag131);
-
- procedure Set_Flag132 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag132);
-
- procedure Set_Flag133 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag133);
-
- procedure Set_Flag134 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag134);
-
- procedure Set_Flag135 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag135);
-
- procedure Set_Flag136 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag136);
-
- procedure Set_Flag137 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag137);
-
- procedure Set_Flag138 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag138);
-
- procedure Set_Flag139 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag139);
-
- procedure Set_Flag140 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag140);
-
- procedure Set_Flag141 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag141);
-
- procedure Set_Flag142 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag142);
-
- procedure Set_Flag143 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag143);
-
- procedure Set_Flag144 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag144);
-
- procedure Set_Flag145 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag145);
-
- procedure Set_Flag146 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag146);
-
- procedure Set_Flag147 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag147);
-
- procedure Set_Flag148 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag148);
-
- procedure Set_Flag149 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag149);
-
- procedure Set_Flag150 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag150);
-
- procedure Set_Flag151 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag151);
-
- procedure Set_Flag152 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag152);
-
- procedure Set_Flag153 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag153);
-
- procedure Set_Flag154 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag154);
-
- procedure Set_Flag155 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag155);
-
- procedure Set_Flag156 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag156);
-
- procedure Set_Flag157 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag157);
-
- procedure Set_Flag158 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag158);
-
- procedure Set_Flag159 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag159);
-
- procedure Set_Flag160 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag160);
-
- procedure Set_Flag161 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag161);
-
- procedure Set_Flag162 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag162);
-
- procedure Set_Flag163 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag163);
-
- procedure Set_Flag164 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag164);
-
- procedure Set_Flag165 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag165);
-
- procedure Set_Flag166 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag166);
-
- procedure Set_Flag167 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag167);
-
- procedure Set_Flag168 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag168);
-
- procedure Set_Flag169 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag169);
-
- procedure Set_Flag170 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag170);
-
- procedure Set_Flag171 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag171);
-
- procedure Set_Flag172 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag172);
-
- procedure Set_Flag173 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag173);
-
- procedure Set_Flag174 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag174);
-
- procedure Set_Flag175 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag175);
-
- procedure Set_Flag176 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag176);
-
- procedure Set_Flag177 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag177);
-
- procedure Set_Flag178 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag178);
-
- procedure Set_Flag179 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag179);
-
- procedure Set_Flag180 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag180);
-
- procedure Set_Flag181 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag181);
-
- procedure Set_Flag182 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag182);
-
- procedure Set_Flag183 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag183);
-
- procedure Set_Flag184 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag184);
-
- procedure Set_Flag185 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag185);
-
- procedure Set_Flag186 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag186);
-
- procedure Set_Flag187 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag187);
-
- procedure Set_Flag188 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag188);
-
- procedure Set_Flag189 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag189);
-
- procedure Set_Flag190 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag190);
-
- procedure Set_Flag191 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag191);
-
- procedure Set_Flag192 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag192);
-
- procedure Set_Flag193 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag193);
-
- procedure Set_Flag194 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag194);
-
- procedure Set_Flag195 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag195);
-
- procedure Set_Flag196 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag196);
-
- procedure Set_Flag197 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag197);
-
- procedure Set_Flag198 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag198);
-
- procedure Set_Flag199 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag199);
-
- procedure Set_Flag200 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag200);
-
- procedure Set_Flag201 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag201);
-
- procedure Set_Flag202 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag202);
-
- procedure Set_Flag203 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag203);
-
- procedure Set_Flag204 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag204);
-
- procedure Set_Flag205 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag205);
-
- procedure Set_Flag206 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag206);
-
- procedure Set_Flag207 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag207);
-
- procedure Set_Flag208 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag208);
-
- procedure Set_Flag209 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag209);
-
- procedure Set_Flag210 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag210);
-
- procedure Set_Flag211 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag211);
-
- procedure Set_Flag212 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag212);
-
- procedure Set_Flag213 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag213);
-
- procedure Set_Flag214 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag214);
-
- procedure Set_Flag215 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag215);
-
- procedure Set_Flag216 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag216);
-
- procedure Set_Flag217 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag217);
-
- procedure Set_Flag218 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag218);
-
- procedure Set_Flag219 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag219);
-
- procedure Set_Flag220 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag220);
-
- procedure Set_Flag221 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag221);
-
- procedure Set_Flag222 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag222);
-
- procedure Set_Flag223 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag223);
-
- procedure Set_Flag224 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag224);
-
- procedure Set_Flag225 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag225);
-
- procedure Set_Flag226 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag226);
-
- procedure Set_Flag227 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag227);
-
- procedure Set_Flag228 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag228);
-
- procedure Set_Flag229 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag229);
-
- procedure Set_Flag230 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag230);
-
- procedure Set_Flag231 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag231);
-
- procedure Set_Flag232 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag232);
-
- procedure Set_Flag233 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag233);
-
- procedure Set_Flag234 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag234);
-
- procedure Set_Flag235 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag235);
-
- procedure Set_Flag236 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag236);
-
- procedure Set_Flag237 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag237);
-
- procedure Set_Flag238 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag238);
-
- procedure Set_Flag239 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag239);
-
- procedure Set_Flag240 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag240);
-
- procedure Set_Flag241 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag241);
-
- procedure Set_Flag242 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag242);
-
- procedure Set_Flag243 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag243);
-
- procedure Set_Flag244 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag244);
-
- procedure Set_Flag245 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag245);
-
- procedure Set_Flag246 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag246);
-
- procedure Set_Flag247 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag247);
-
- procedure Set_Flag248 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag248);
-
- procedure Set_Flag249 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag249);
-
- procedure Set_Flag250 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag250);
-
- procedure Set_Flag251 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag251);
-
- procedure Set_Flag252 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag252);
-
- procedure Set_Flag253 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag253);
-
- procedure Set_Flag254 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag254);
-
- procedure Set_Flag255 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag255);
-
- procedure Set_Flag256 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag256);
-
- procedure Set_Flag257 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag257);
-
- procedure Set_Flag258 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag258);
-
- procedure Set_Flag259 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag259);
-
- procedure Set_Flag260 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag260);
-
- procedure Set_Flag261 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag261);
-
- procedure Set_Flag262 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag262);
-
- procedure Set_Flag263 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag263);
-
- procedure Set_Flag264 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag264);
-
- procedure Set_Flag265 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag265);
-
- procedure Set_Flag266 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag266);
-
- procedure Set_Flag267 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag267);
-
- procedure Set_Flag268 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag268);
-
- procedure Set_Flag269 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag269);
-
- procedure Set_Flag270 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag270);
-
- procedure Set_Flag271 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag271);
-
- procedure Set_Flag272 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag272);
-
- procedure Set_Flag273 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag273);
-
- procedure Set_Flag274 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag274);
-
- procedure Set_Flag275 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag275);
-
- procedure Set_Flag276 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag276);
-
- procedure Set_Flag277 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag277);
-
- procedure Set_Flag278 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag278);
-
- procedure Set_Flag279 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag279);
-
- procedure Set_Flag280 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag280);
-
- procedure Set_Flag281 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag281);
-
- procedure Set_Flag282 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag282);
-
- procedure Set_Flag283 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag283);
-
- procedure Set_Flag284 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag284);
-
- procedure Set_Flag285 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag285);
-
- procedure Set_Flag286 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag286);
-
- procedure Set_Flag287 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag287);
-
- procedure Set_Flag288 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag288);
-
- procedure Set_Flag289 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag289);
-
- procedure Set_Flag290 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag290);
-
- procedure Set_Flag291 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag291);
-
- procedure Set_Flag292 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag292);
-
- procedure Set_Flag293 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag293);
-
- procedure Set_Flag294 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag294);
-
- procedure Set_Flag295 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag295);
-
- procedure Set_Flag296 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag296);
-
- procedure Set_Flag297 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag297);
-
- procedure Set_Flag298 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag298);
-
- procedure Set_Flag299 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag299);
-
- procedure Set_Flag300 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag300);
-
- procedure Set_Flag301 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag301);
-
- procedure Set_Flag302 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag302);
-
- procedure Set_Flag303 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag303);
-
- procedure Set_Flag304 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag304);
-
- procedure Set_Flag305 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag305);
-
- procedure Set_Flag306 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag306);
-
- procedure Set_Flag307 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag307);
-
- procedure Set_Flag308 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag308);
-
- procedure Set_Flag309 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag309);
-
- procedure Set_Flag310 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag310);
-
- procedure Set_Flag311 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag311);
-
- procedure Set_Flag312 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag312);
-
- procedure Set_Flag313 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag313);
-
- procedure Set_Flag314 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag314);
-
- procedure Set_Flag315 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag315);
-
- procedure Set_Flag316 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag316);
-
- procedure Set_Flag317 (N : Node_Id; Val : Boolean);
- pragma Inline (Set_Flag317);
-
- -- The following versions of Set_Noden also set the parent pointer of
- -- the referenced node if it is not Empty.
-
- procedure Set_Node1_With_Parent (N : Node_Id; Val : Node_Id);
- pragma Inline (Set_Node1_With_Parent);
-
- procedure Set_Node2_With_Parent (N : Node_Id; Val : Node_Id);
- pragma Inline (Set_Node2_With_Parent);
-
- procedure Set_Node3_With_Parent (N : Node_Id; Val : Node_Id);
- pragma Inline (Set_Node3_With_Parent);
-
- procedure Set_Node4_With_Parent (N : Node_Id; Val : Node_Id);
- pragma Inline (Set_Node4_With_Parent);
-
- procedure Set_Node5_With_Parent (N : Node_Id; Val : Node_Id);
- pragma Inline (Set_Node5_With_Parent);
-
- -- The following versions of Set_Listn also set the parent pointer of
- -- the referenced node if it is not Empty.
-
- procedure Set_List1_With_Parent (N : Node_Id; Val : List_Id);
- pragma Inline (Set_List1_With_Parent);
-
- procedure Set_List2_With_Parent (N : Node_Id; Val : List_Id);
- pragma Inline (Set_List2_With_Parent);
-
- procedure Set_List3_With_Parent (N : Node_Id; Val : List_Id);
- pragma Inline (Set_List3_With_Parent);
-
- procedure Set_List4_With_Parent (N : Node_Id; Val : List_Id);
- pragma Inline (Set_List4_With_Parent);
-
- procedure Set_List5_With_Parent (N : Node_Id; Val : List_Id);
- pragma Inline (Set_List5_With_Parent);
+ ----------------------
+ -- Vanishing Fields --
+ ----------------------
- end Unchecked_Access;
+ -- The Nkind and Ekind fields are like Ada discriminants governing a
+ -- variant part. They determine which fields are present. If the Nkind
+ -- or Ekind fields are changed, then this can change which fields are
+ -- present. If a field is present for the old kind, but not for the
+ -- new kind, the field vanishes. This requires some care when changing
+ -- kinds, as described below. Note that Ada doesn't even allow direct
+ -- modification of a discriminant.
+
+ type Node_Field_Set is array (Node_Field) of Boolean with Pack;
+
+ type Entity_Field_Set is array (Entity_Field) of Boolean with Pack;
+
+ procedure Reinit_Field_To_Zero (N : Node_Id; Field : Node_Field);
+ procedure Reinit_Field_To_Zero (N : Node_Id; Field : Entity_Field);
+ -- When a node is created, all fields are initialized to zero, even if zero
+ -- is not a valid value of the field type. These procedures put the field
+ -- back to its initial zero value. Note that you can't just do something
+ -- like Set_Some_Field (N, 0), if Some_Field is of (say) type Uintp,
+ -- because Uintp is a subrange that does not include 0.
+ type Entity_Kind_Set is array (Entity_Kind) of Boolean with Pack;
+ procedure Reinit_Field_To_Zero
+ (N : Node_Id; Field : Entity_Field; Old_Ekind : Entity_Kind_Set);
+ procedure Reinit_Field_To_Zero
+ (N : Node_Id; Field : Entity_Field; Old_Ekind : Entity_Kind);
+ -- Same as above, but assert that the old Ekind is as specified. We might
+ -- want to get rid of these, but it's useful documentation while working on
+ -- this.
+
+ function Field_Is_Initial_Zero
+ (N : Node_Id; Field : Node_Field) return Boolean;
+ function Field_Is_Initial_Zero
+ (N : Entity_Id; Field : Entity_Field) return Boolean;
+ -- True if the field value is the initial zero value
+
+ procedure Mutate_Nkind (N : Node_Id; Val : Node_Kind) with Inline;
+ -- There is no Set_Nkind in Sinfo.Nodes. We use this instead. This is here,
+ -- and has a different name, because it does some extra checking. Nkind is
+ -- like a discriminant, in that it controls which fields exist, and that
+ -- set of fields can be different for the new kind. Discriminants cannot be
+ -- modified in Ada for that reason. The rule here is more flexible: Nkind
+ -- can be modified. However, when Nkind is modified, fields that exist for
+ -- the old kind, but not for the new kind will vanish. We require that all
+ -- vanishing fields be set to their initial zero value before calling
+ -- Mutate_Nkind. This is necessary, because the memory occupied by the
+ -- vanishing fields might be used for totally unrelated fields in the new
+ -- node. See Reinit_Field_To_Zero.
+
+ procedure Mutate_Ekind
+ (N : Entity_Id; Val : Entity_Kind) with Inline;
+ -- Ekind is also like a discriminant, and is mostly treated as above (see
+ -- Mutate_Nkind). However, there are a few cases where we set the Ekind
+ -- from its initial E_Void value to something else, then set it back to
+ -- E_Void, then back to the something else, and we expect the "something
+ -- else" fields to retain their value. The two "something else"s are not
+ -- always the same; for example we change from E_Void, to E_Variable, to
+ -- E_Void, to E_Constant.
+
+ procedure Print_Atree_Info (N : Node_Or_Entity_Id);
+ -- Called from Treepr to print out information about N that is private to
+ -- Atree.
-----------------------------
-- Private Part Subpackage --
@@ -3650,347 +626,234 @@ package Atree is
package Atree_Private_Part is
+ pragma Assert (Node_Kind'Pos (N_Unused_At_Start) = 0);
+ pragma Assert (Empty_List_Or_Node = 0);
+ pragma Assert (Entity_Kind'Pos (E_Void) = 0);
+ -- We want nodes initialized to zero bits by default
+
-------------------------
-- Tree Representation --
-------------------------
- -- The nodes of the tree are stored in a table (i.e. an array). In the
- -- case of extended nodes six consecutive components in the array are
- -- used. There are thus two formats for array components. One is used
- -- for nonextended nodes, and for the first component of extended
- -- nodes. The other is used for the extension parts (second, third,
- -- fourth, fifth, and sixth components) of an extended node. A variant
- -- record structure is used to distinguish the two formats.
-
- type Node_Record (Is_Extension : Boolean := False) is record
-
- -- Logically, the only field in the common part is the above
- -- Is_Extension discriminant (a single bit). However, Gigi cannot
- -- yet handle such a structure, so we fill out the common part of
- -- the record with fields that are used in different ways for
- -- normal nodes and node extensions.
-
- Pflag1, Pflag2 : Boolean;
- -- The Paren_Count field is represented using two boolean flags,
- -- where Pflag1 is worth 1, and Pflag2 is worth 2. This is done
- -- because we need to be easily able to reuse this field for
- -- extra flags in the extended node case.
-
- In_List : Boolean;
- -- Flag used to indicate if node is a member of a list.
- -- This field is considered private to the Atree package.
-
- Has_Aspects : Boolean;
- -- Flag used to indicate that a node has aspect specifications that
- -- are associated with the node. See Aspects package for details.
-
- Rewrite_Ins : Boolean;
- -- Flag set by Mark_Rewrite_Insertion procedure.
- -- This field is considered private to the Atree package.
-
- Analyzed : Boolean;
- -- Flag to indicate the node has been analyzed (and expanded)
-
- Comes_From_Source : Boolean;
- -- Flag to indicate that node comes from the source program (i.e.
- -- was built by the parser or scanner, not the analyzer or expander).
-
- Error_Posted : Boolean;
- -- Flag to indicate that an error message has been posted on the
- -- node (to avoid duplicate flags on the same node)
-
- Flag4 : Boolean;
- Flag5 : Boolean;
- Flag6 : Boolean;
- Flag7 : Boolean;
- Flag8 : Boolean;
- Flag9 : Boolean;
- Flag10 : Boolean;
- Flag11 : Boolean;
- Flag12 : Boolean;
- Flag13 : Boolean;
- Flag14 : Boolean;
- Flag15 : Boolean;
- Flag16 : Boolean;
- Flag17 : Boolean;
- Flag18 : Boolean;
- -- Flags 4-18 for a normal node. Note that Flags 0-3 are stored
- -- separately in the Flags array.
-
- -- The above fields are used as follows in components 2-6 of an
- -- extended node entry. Currently they are not used in component 7,
- -- since for now we have all the flags we need, but of course they
- -- can be used for additional flags when needed in component 7.
-
- -- In_List used as Flag19,Flag40,Flag129,Flag216,Flag287
- -- Has_Aspects used as Flag20,Flag41,Flag130,Flag217,Flag288
- -- Rewrite_Ins used as Flag21,Flag42,Flag131,Flag218,Flag289
- -- Analyzed used as Flag22,Flag43,Flag132,Flag219,Flag290
- -- Comes_From_Source used as Flag23,Flag44,Flag133,Flag220,Flag291
- -- Error_Posted used as Flag24,Flag45,Flag134,Flag221,Flag292
- -- Flag4 used as Flag25,Flag46,Flag135,Flag222,Flag293
- -- Flag5 used as Flag26,Flag47,Flag136,Flag223,Flag294
- -- Flag6 used as Flag27,Flag48,Flag137,Flag224,Flag295
- -- Flag7 used as Flag28,Flag49,Flag138,Flag225,Flag296
- -- Flag8 used as Flag29,Flag50,Flag139,Flag226,Flag297
- -- Flag9 used as Flag30,Flag51,Flag140,Flag227,Flag298
- -- Flag10 used as Flag31,Flag52,Flag141,Flag228,Flag299
- -- Flag11 used as Flag32,Flag53,Flag142,Flag229,Flag300
- -- Flag12 used as Flag33,Flag54,Flag143,Flag230,Flag301
- -- Flag13 used as Flag34,Flag55,Flag144,Flag231,Flag302
- -- Flag14 used as Flag35,Flag56,Flag145,Flag232,Flag303
- -- Flag15 used as Flag36,Flag57,Flag146,Flag233,Flag304
- -- Flag16 used as Flag37,Flag58,Flag147,Flag234,Flag305
- -- Flag17 used as Flag38,Flag59,Flag148,Flag235,Flag306
- -- Flag18 used as Flag39,Flag60,Flag149,Flag236,Flag307
- -- Pflag1 used as Flag61,Flag62,Flag150,Flag237,Flag308
- -- Pflag2 used as Flag63,Flag64,Flag151,Flag238,Flag309
-
- Nkind : Node_Kind;
- -- For a nonextended node, or the initial section of an extended
- -- node, this field holds the Node_Kind value. For an extended node,
- -- The Nkind field is used as follows:
- --
- -- Second entry: holds the Ekind field of the entity
- -- Third entry: holds 8 additional flags (Flag65-Flag72)
- -- Fourth entry: holds 8 additional flags (Flag239-246)
- -- Fifth entry: holds 8 additional flags (Flag247-254)
- -- Sixth entry: holds 8 additional flags (Flag310-317)
- -- Seventh entry: currently unused
-
- -- Now finally (on a 32-bit boundary) comes the variant part
-
- case Is_Extension is
-
- -- Nonextended node, or first component of extended node
-
- when False =>
-
- Sloc : Source_Ptr;
- -- Source location for this node
-
- Link : Union_Id;
- -- This field is used either as the Parent pointer (if In_List
- -- is False), or to point to the list header (if In_List is
- -- True). This field is considered private and can be modified
- -- only by Atree or by Nlists.
-
- Field1 : Union_Id;
- Field2 : Union_Id;
- Field3 : Union_Id;
- Field4 : Union_Id;
- Field5 : Union_Id;
- -- Five general use fields, which can contain Node_Id, List_Id,
- -- Elist_Id, String_Id, or Name_Id values depending on the
- -- values in Nkind and (for extended nodes), in Ekind. See
- -- packages Sinfo and Einfo for details of their use.
-
- -- Extension (second component) of extended node
-
- when True =>
-
- Field6 : Union_Id;
- Field7 : Union_Id;
- Field8 : Union_Id;
- Field9 : Union_Id;
- Field10 : Union_Id;
- Field11 : Union_Id;
- Field12 : Union_Id;
- -- Seven additional general fields available only for entities.
- -- See package Einfo for details of their use (which depends
- -- on the value in the Ekind field).
-
- -- In the third component, the extension format as described
- -- above is used to hold additional general fields and flags
- -- as follows:
-
- -- Field6-11 Holds Field13-Field18
- -- Field12 Holds Flag73-Flag96 and Convention
-
- -- In the fourth component, the extension format as described
- -- above is used to hold additional general fields and flags
- -- as follows:
-
- -- Field6-10 Holds Field19-Field23
- -- Field11 Holds Flag152-Flag183
- -- Field12 Holds Flag97-Flag128
-
- -- In the fifth component, the extension format as described
- -- above is used to hold additional general fields and flags
- -- as follows:
-
- -- Field6-11 Holds Field24-Field29
- -- Field12 Holds Flag184-Flag215
-
- -- In the sixth component, the extension format as described
- -- above is used to hold additional general fields and flags
- -- as follows:
-
- -- Field6-11 Holds Field30-Field35
- -- Field12 Holds Flag255-Flag286
-
- -- In the seventh component, the extension format as described
- -- above is used to hold additional general fields as follows.
- -- Flags are also available potentially, but not used now, as
- -- we are not short of entity flags.
-
- -- Field6-11 Holds Field36-Field41
-
- end case;
- end record; -- Node_Record
- pragma Suppress_Initialization (Node_Record); -- see package Nodes below
-
- pragma Pack (Node_Record);
- for Node_Record'Size use 8 * 32;
- for Node_Record'Alignment use 4;
-
- function E_To_N is new Unchecked_Conversion (Entity_Kind, Node_Kind);
- function N_To_E is new Unchecked_Conversion (Node_Kind, Entity_Kind);
-
- -- Default value used to initialize default nodes. Note that some of the
- -- fields get overwritten, and in particular, Nkind always gets reset.
-
- Default_Node : constant Node_Record := (
- Is_Extension => False,
- Pflag1 => False,
- Pflag2 => False,
- In_List => False,
- Has_Aspects => False,
- Rewrite_Ins => False,
- Analyzed => False,
- Comes_From_Source => False,
- Error_Posted => False,
- Flag4 => False,
-
- Flag5 => False,
- Flag6 => False,
- Flag7 => False,
- Flag8 => False,
- Flag9 => False,
- Flag10 => False,
- Flag11 => False,
- Flag12 => False,
-
- Flag13 => False,
- Flag14 => False,
- Flag15 => False,
- Flag16 => False,
- Flag17 => False,
- Flag18 => False,
-
- Nkind => N_Unused_At_Start,
-
- Sloc => 0,
- Link => Empty_List_Or_Node,
- Field1 => Empty_List_Or_Node,
- Field2 => Empty_List_Or_Node,
- Field3 => Empty_List_Or_Node,
- Field4 => Empty_List_Or_Node,
- Field5 => Empty_List_Or_Node);
-
- -- Default value used to initialize node extensions (i.e. the second
- -- through seventh components of an extended node). Note we are cheating
- -- a bit here when it comes to Node12, which often holds flags and (for
- -- the third component), the convention. But it works because Empty,
- -- False, Convention_Ada, all happen to be all zero bits.
-
- Default_Node_Extension : constant Node_Record := (
- Is_Extension => True,
- Pflag1 => False,
- Pflag2 => False,
- In_List => False,
- Has_Aspects => False,
- Rewrite_Ins => False,
- Analyzed => False,
- Comes_From_Source => False,
- Error_Posted => False,
- Flag4 => False,
-
- Flag5 => False,
- Flag6 => False,
- Flag7 => False,
- Flag8 => False,
- Flag9 => False,
- Flag10 => False,
- Flag11 => False,
- Flag12 => False,
-
- Flag13 => False,
- Flag14 => False,
- Flag15 => False,
- Flag16 => False,
- Flag17 => False,
- Flag18 => False,
-
- Nkind => E_To_N (E_Void),
-
- Field6 => Empty_List_Or_Node,
- Field7 => Empty_List_Or_Node,
- Field8 => Empty_List_Or_Node,
- Field9 => Empty_List_Or_Node,
- Field10 => Empty_List_Or_Node,
- Field11 => Empty_List_Or_Node,
- Field12 => Empty_List_Or_Node);
-
- -- The following defines the extendable array used for the nodes table.
- -- Nodes with extensions use multiple consecutive entries in the array
- -- (see Num_Extension_Nodes).
-
- package Nodes is new Table.Table
- (Table_Component_Type => Node_Record,
+ -- The nodes of the tree are stored in two tables (i.e. growable
+ -- arrays).
+
+ -- A Node_Id points to an element of Nodes, which contains a
+ -- Field_Offset that points to an element of Slots. Each slot can
+ -- contain a single 32-bit field, or multiple smaller fields.
+ -- An n-bit field is aligned on an n-bit boundary. The size of a node is
+ -- the number of slots, which can range from 1 up to however many are
+ -- needed.
+ --
+ -- The reason for the extra level of indirection is that Copy_Node,
+ -- Exchange_Entities, and Rewrite all assume that nodes can be modified
+ -- in place.
+
+ subtype Node_Offset is Field_Offset'Base
+ range 1 .. Field_Offset'Base'Last;
+
+ package Node_Offsets is new Table.Table
+ (Table_Component_Type => Node_Offset,
Table_Index_Type => Node_Id'Base,
Table_Low_Bound => First_Node_Id,
- Table_Initial => Alloc.Nodes_Initial,
- Table_Increment => Alloc.Nodes_Increment,
- Release_Threshold => Alloc.Nodes_Release_Threshold,
- Table_Name => "Nodes");
-
- -- The following is a parallel table to Nodes, which provides 8 more
- -- bits of space that logically belong to the corresponding node. This
- -- is currently used to implement Flags 0,1,2,3 for normal nodes, or
- -- the first component of an extended node (four bits unused). Entries
- -- for extending components are completely unused.
-
- type Flags_Byte is record
- Flag0 : Boolean;
- -- Note: we don't use Flag0 at the moment. To put Flag0 into use
- -- requires some awkward work in Treeprs (treeprs.adt), so for the
- -- moment we don't use it.
-
- Flag1 : Boolean;
- Flag2 : Boolean;
- Flag3 : Boolean;
- -- These flags are used in the usual manner in Sinfo and Einfo
-
- -- The flags listed below use explicit names because following the
- -- FlagXXX convention would mean reshuffling of over 300+ flags.
-
- Check_Actuals : Boolean;
- -- Flag set to indicate that the marked node is subject to the check
- -- for writable actuals.
-
- Is_Ignored_Ghost_Node : Boolean;
- -- Flag denoting whether the node is subject to pragma Ghost with
- -- policy Ignore.
-
- Spare2 : Boolean;
- Spare3 : Boolean;
- end record;
-
- for Flags_Byte'Size use 8;
- pragma Pack (Flags_Byte);
-
- Default_Flags : constant Flags_Byte := (others => False);
- -- Default value used to initialize new entries
-
- package Flags is new Table.Table (
- Table_Component_Type => Flags_Byte,
- Table_Index_Type => Node_Id'Base,
- Table_Low_Bound => First_Node_Id,
- Table_Initial => Alloc.Nodes_Initial,
- Table_Increment => Alloc.Nodes_Increment,
- Release_Threshold => Alloc.Nodes_Release_Threshold,
- Table_Name => "Flags");
+ Table_Initial => Alloc.Node_Offsets_Initial,
+ Table_Increment => Alloc.Node_Offsets_Increment,
+ Table_Name => "Node_Offsets");
+
+ Noff : Node_Offsets.Table_Ptr renames Node_Offsets.Table with
+ Unreferenced;
+ function Nlast return Node_Id'Base renames Node_Offsets.Last with
+ Unreferenced;
+ -- Short names for use in gdb, not used in real code. Note that gdb
+ -- can't find Node_Offsets.Table without a full expanded name.
+
+ -- We define the type Slot as a 32-bit modular integer. It is logically
+ -- split into the appropriate numbers of components of appropriate size,
+ -- but this splitting is not explicit because packed arrays cannot be
+ -- properly interfaced in C/C++ and packed records are way too slow.
+
+ Slot_Size : constant := 32;
+ type Slot is mod 2**Slot_Size;
+ for Slot'Size use Slot_Size;
+
+ function Shift_Left (S : Slot; V : Natural) return Slot;
+ pragma Import (Intrinsic, Shift_Left);
+
+ function Shift_Right (S : Slot; V : Natural) return Slot;
+ pragma Import (Intrinsic, Shift_Right);
+
+ -- Low-level types for fields of the various supported sizes.
+ -- All fields are a power of 2 number of bits, and are aligned
+ -- to that number of bits:
+
+ type Field_Size_1_Bit is mod 2**1;
+ type Field_Size_2_Bit is mod 2**2;
+ type Field_Size_4_Bit is mod 2**4;
+ type Field_Size_8_Bit is mod 2**8;
+ type Field_Size_32_Bit is mod 2**32;
+
+ Slots_Low_Bound : constant Field_Offset := Field_Offset'First + 1;
+
+ package Slots is new Table.Table
+ (Table_Component_Type => Slot,
+ Table_Index_Type => Node_Offset'Base,
+ Table_Low_Bound => Slots_Low_Bound,
+ Table_Initial => Alloc.Slots_Initial,
+ Table_Increment => Alloc.Slots_Increment,
+ Table_Name => "Slots");
+ -- Note that Table_Low_Bound is set such that if we try to access
+ -- Slots.Table (0), we will get Constraint_Error.
+
+ Slts : Slots.Table_Ptr renames Slots.Table with
+ Unreferenced;
+ function Slast return Node_Offset'Base renames Slots.Last with
+ Unreferenced;
+ -- Short names for use in gdb, not used in real code. Note that gdb
+ -- can't find Slots.Table without a full expanded name.
+
+ function Alloc_Node_Id return Node_Id with Inline;
+
+ function Alloc_Slots (Num_Slots : Slot_Count) return Node_Offset
+ with Inline;
+ -- Allocate the slots for a node in the Slots table
+
+ -- Each of the following Get_N_Bit_Field functions fetches the field of
+ -- the given Field_Type at the given offset. Field_Type'Size must be N.
+ -- The offset is measured in units of Field_Type'Size. Likewise for the
+ -- Set_N_Bit_Field procedures. These are instantiated in Sinfo.Nodes and
+ -- Einfo.Entities for the various possible Field_Types (Flag, Node_Id,
+ -- Uint, etc).
+
+ generic
+ type Field_Type is private;
+ function Get_1_Bit_Field
+ (N : Node_Or_Entity_Id; Offset : Field_Offset) return Field_Type
+ with Inline;
+
+ generic
+ type Field_Type is private;
+ function Get_2_Bit_Field
+ (N : Node_Or_Entity_Id; Offset : Field_Offset) return Field_Type
+ with Inline;
+
+ generic
+ type Field_Type is private;
+ function Get_4_Bit_Field
+ (N : Node_Or_Entity_Id; Offset : Field_Offset) return Field_Type
+ with Inline;
+
+ generic
+ type Field_Type is private;
+ function Get_8_Bit_Field
+ (N : Node_Or_Entity_Id; Offset : Field_Offset) return Field_Type
+ with Inline;
+
+ generic
+ type Field_Type is private;
+ function Get_32_Bit_Field
+ (N : Node_Or_Entity_Id; Offset : Field_Offset) return Field_Type
+ with Inline;
+
+ generic
+ type Field_Type is private;
+ Default_Val : Field_Type;
+ function Get_32_Bit_Field_With_Default
+ (N : Node_Or_Entity_Id; Offset : Field_Offset) return Field_Type
+ with Inline;
+ -- If the field has not yet been set, return Default_Val
+
+ generic
+ type Field_Type is private;
+ function Get_Valid_32_Bit_Field
+ (N : Node_Or_Entity_Id; Offset : Field_Offset) return Field_Type
+ with Inline;
+ -- Assert that the field has already been set. This is currently used
+ -- only for Uints, but could be used more generally.
+
+ generic
+ type Field_Type is private;
+ procedure Set_1_Bit_Field
+ (N : Node_Or_Entity_Id; Offset : Field_Offset; Val : Field_Type)
+ with Inline;
+
+ generic
+ type Field_Type is private;
+ procedure Set_2_Bit_Field
+ (N : Node_Or_Entity_Id; Offset : Field_Offset; Val : Field_Type)
+ with Inline;
+
+ generic
+ type Field_Type is private;
+ procedure Set_4_Bit_Field
+ (N : Node_Or_Entity_Id; Offset : Field_Offset; Val : Field_Type)
+ with Inline;
+
+ generic
+ type Field_Type is private;
+ procedure Set_8_Bit_Field
+ (N : Node_Or_Entity_Id; Offset : Field_Offset; Val : Field_Type)
+ with Inline;
+
+ generic
+ type Field_Type is private;
+ procedure Set_32_Bit_Field
+ (N : Node_Or_Entity_Id; Offset : Field_Offset; Val : Field_Type)
+ with Inline;
+
+ -- The following are similar to the above generics, but are not generic,
+ -- and work with the low-level Field_n_bit types. If generics could be
+ -- overloaded, we would use the same names.
+
+ function Get_1_Bit_Val
+ (N : Node_Or_Entity_Id; Offset : Field_Offset) return Field_Size_1_Bit
+ with Inline;
+
+ function Get_2_Bit_Val
+ (N : Node_Or_Entity_Id; Offset : Field_Offset) return Field_Size_2_Bit
+ with Inline;
+
+ function Get_4_Bit_Val
+ (N : Node_Or_Entity_Id; Offset : Field_Offset) return Field_Size_4_Bit
+ with Inline;
+
+ function Get_8_Bit_Val
+ (N : Node_Or_Entity_Id; Offset : Field_Offset) return Field_Size_8_Bit
+ with Inline;
+
+ function Get_32_Bit_Val
+ (N : Node_Or_Entity_Id; Offset : Field_Offset) return Field_Size_32_Bit
+ with Inline;
+
+ procedure Set_1_Bit_Val
+ (N : Node_Or_Entity_Id; Offset : Field_Offset; Val : Field_Size_1_Bit)
+ with Inline;
+
+ procedure Set_2_Bit_Val
+ (N : Node_Or_Entity_Id; Offset : Field_Offset; Val : Field_Size_2_Bit)
+ with Inline;
+
+ procedure Set_4_Bit_Val
+ (N : Node_Or_Entity_Id; Offset : Field_Offset; Val : Field_Size_4_Bit)
+ with Inline;
+
+ procedure Set_8_Bit_Val
+ (N : Node_Or_Entity_Id; Offset : Field_Offset; Val : Field_Size_8_Bit)
+ with Inline;
+
+ procedure Set_32_Bit_Val
+ (N : Node_Or_Entity_Id; Offset : Field_Offset; Val : Field_Size_32_Bit)
+ with Inline;
+
+ -- The following are used in "asserts on" mode to validate nodes; an
+ -- exception is raised if invalid node content is detected.
+
+ procedure Validate_Node (N : Node_Or_Entity_Id);
+ -- Validate for reading
+ procedure Validate_Node_Write (N : Node_Or_Entity_Id);
+ -- Validate for writing
+
+ function Is_Valid_Node (U : Union_Id) return Boolean;
+ -- True if U is within the range of Node_Offsets
end Atree_Private_Part;
diff --git a/gcc/ada/atree.h b/gcc/ada/atree.h
index c63c535..08b791c 100644
--- a/gcc/ada/atree.h
+++ b/gcc/ada/atree.h
@@ -6,7 +6,7 @@
* *
* C Header File *
* *
- * Copyright (C) 1992-2020, Free Software Foundation, Inc. *
+ * Copyright (C) 1992-2021, Free Software Foundation, Inc. *
* *
* GNAT is 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,361 +35,20 @@
extern "C" {
#endif
-/* Structure used for the first part of the node in the case where we have
- an Nkind. */
-
-struct NFK
-{
- Boolean is_extension : 1;
- Boolean pflag1 : 1;
- Boolean pflag2 : 1;
- Boolean in_list : 1;
- Boolean has_aspects : 1;
- Boolean rewrite_ins : 1;
- Boolean analyzed : 1;
- Boolean c_f_s : 1;
- Boolean error_posted : 1;
-
- Boolean flag4 : 1;
- Boolean flag5 : 1;
- Boolean flag6 : 1;
- Boolean flag7 : 1;
- Boolean flag8 : 1;
- Boolean flag9 : 1;
- Boolean flag10 : 1;
-
- Boolean flag11 : 1;
- Boolean flag12 : 1;
- Boolean flag13 : 1;
- Boolean flag14 : 1;
- Boolean flag15 : 1;
- Boolean flag16 : 1;
- Boolean flag17 : 1;
- Boolean flag18 : 1;
-
- unsigned char kind;
-};
-
-/* Structure for the first part of a node when Nkind is not present by
- extra flag bits are. */
-
-struct NFNK
-{
- Boolean is_extension : 1;
- Boolean pflag1 : 1;
- Boolean pflag2 : 1;
- Boolean in_list : 1;
- Boolean has_aspects : 1;
- Boolean rewrite_ins : 1;
- Boolean analyzed : 1;
- Boolean c_f_s : 1;
- Boolean error_posted : 1;
-
- Boolean flag4 : 1;
- Boolean flag5 : 1;
- Boolean flag6 : 1;
- Boolean flag7 : 1;
- Boolean flag8 : 1;
- Boolean flag9 : 1;
- Boolean flag10 : 1;
-
- Boolean flag11 : 1;
- Boolean flag12 : 1;
- Boolean flag13 : 1;
- Boolean flag14 : 1;
- Boolean flag15 : 1;
- Boolean flag16 : 1;
- Boolean flag17 : 1;
- Boolean flag18 : 1;
-
- Boolean flag65 : 1;
- Boolean flag66 : 1;
- Boolean flag67 : 1;
- Boolean flag68 : 1;
- Boolean flag69 : 1;
- Boolean flag70 : 1;
- Boolean flag71 : 1;
- Boolean flag72 : 1;
-};
-
-/* Structure used for extra flags in third component overlaying Field12 */
-struct Flag_Word
-{
- Boolean flag73 : 1;
- Boolean flag74 : 1;
- Boolean flag75 : 1;
- Boolean flag76 : 1;
- Boolean flag77 : 1;
- Boolean flag78 : 1;
- Boolean flag79 : 1;
- Boolean flag80 : 1;
- Boolean flag81 : 1;
- Boolean flag82 : 1;
- Boolean flag83 : 1;
- Boolean flag84 : 1;
- Boolean flag85 : 1;
- Boolean flag86 : 1;
- Boolean flag87 : 1;
- Boolean flag88 : 1;
- Boolean flag89 : 1;
- Boolean flag90 : 1;
- Boolean flag91 : 1;
- Boolean flag92 : 1;
- Boolean flag93 : 1;
- Boolean flag94 : 1;
- Boolean flag95 : 1;
- Boolean flag96 : 1;
- Byte convention : 8;
-};
-
-/* Structure used for extra flags in fourth component overlaying Field12 */
-struct Flag_Word2
-{
- Boolean flag97 : 1;
- Boolean flag98 : 1;
- Boolean flag99 : 1;
- Boolean flag100 : 1;
- Boolean flag101 : 1;
- Boolean flag102 : 1;
- Boolean flag103 : 1;
- Boolean flag104 : 1;
- Boolean flag105 : 1;
- Boolean flag106 : 1;
- Boolean flag107 : 1;
- Boolean flag108 : 1;
- Boolean flag109 : 1;
- Boolean flag110 : 1;
- Boolean flag111 : 1;
- Boolean flag112 : 1;
- Boolean flag113 : 1;
- Boolean flag114 : 1;
- Boolean flag115 : 1;
- Boolean flag116 : 1;
- Boolean flag117 : 1;
- Boolean flag118 : 1;
- Boolean flag119 : 1;
- Boolean flag120 : 1;
- Boolean flag121 : 1;
- Boolean flag122 : 1;
- Boolean flag123 : 1;
- Boolean flag124 : 1;
- Boolean flag125 : 1;
- Boolean flag126 : 1;
- Boolean flag127 : 1;
- Boolean flag128 : 1;
-};
-
-/* Structure used for extra flags in fourth component overlaying Field11 */
-struct Flag_Word3
-{
- Boolean flag152 : 1;
- Boolean flag153 : 1;
- Boolean flag154 : 1;
- Boolean flag155 : 1;
- Boolean flag156 : 1;
- Boolean flag157 : 1;
- Boolean flag158 : 1;
- Boolean flag159 : 1;
-
- Boolean flag160 : 1;
- Boolean flag161 : 1;
- Boolean flag162 : 1;
- Boolean flag163 : 1;
- Boolean flag164 : 1;
- Boolean flag165 : 1;
- Boolean flag166 : 1;
- Boolean flag167 : 1;
-
- Boolean flag168 : 1;
- Boolean flag169 : 1;
- Boolean flag170 : 1;
- Boolean flag171 : 1;
- Boolean flag172 : 1;
- Boolean flag173 : 1;
- Boolean flag174 : 1;
- Boolean flag175 : 1;
-
- Boolean flag176 : 1;
- Boolean flag177 : 1;
- Boolean flag178 : 1;
- Boolean flag179 : 1;
- Boolean flag180 : 1;
- Boolean flag181 : 1;
- Boolean flag182 : 1;
- Boolean flag183 : 1;
-};
-
-/* Structure used for extra flags in fifth component overlaying Field12 */
-struct Flag_Word4
-{
- Boolean flag184 : 1;
- Boolean flag185 : 1;
- Boolean flag186 : 1;
- Boolean flag187 : 1;
- Boolean flag188 : 1;
- Boolean flag189 : 1;
- Boolean flag190 : 1;
- Boolean flag191 : 1;
-
- Boolean flag192 : 1;
- Boolean flag193 : 1;
- Boolean flag194 : 1;
- Boolean flag195 : 1;
- Boolean flag196 : 1;
- Boolean flag197 : 1;
- Boolean flag198 : 1;
- Boolean flag199 : 1;
-
- Boolean flag200 : 1;
- Boolean flag201 : 1;
- Boolean flag202 : 1;
- Boolean flag203 : 1;
- Boolean flag204 : 1;
- Boolean flag205 : 1;
- Boolean flag206 : 1;
- Boolean flag207 : 1;
-
- Boolean flag208 : 1;
- Boolean flag209 : 1;
- Boolean flag210 : 1;
- Boolean flag211 : 1;
- Boolean flag212 : 1;
- Boolean flag213 : 1;
- Boolean flag214 : 1;
- Boolean flag215 : 1;
-};
-
-/* Structure used for extra flags in sixth component overlaying Field12 */
-struct Flag_Word5
-{
- Boolean flag255 : 1;
- Boolean flag256 : 1;
- Boolean flag257 : 1;
- Boolean flag258 : 1;
- Boolean flag259 : 1;
- Boolean flag260 : 1;
- Boolean flag261 : 1;
- Boolean flag262 : 1;
-
- Boolean flag263 : 1;
- Boolean flag264 : 1;
- Boolean flag265 : 1;
- Boolean flag266 : 1;
- Boolean flag267 : 1;
- Boolean flag268 : 1;
- Boolean flag269 : 1;
- Boolean flag270 : 1;
-
- Boolean flag271 : 1;
- Boolean flag272 : 1;
- Boolean flag273 : 1;
- Boolean flag274 : 1;
- Boolean flag275 : 1;
- Boolean flag276 : 1;
- Boolean flag277 : 1;
- Boolean flag278 : 1;
-
- Boolean flag279 : 1;
- Boolean flag280 : 1;
- Boolean flag281 : 1;
- Boolean flag282 : 1;
- Boolean flag283 : 1;
- Boolean flag284 : 1;
- Boolean flag285 : 1;
- Boolean flag286 : 1;
-};
-struct Non_Extended
-{
- Source_Ptr sloc;
- Int link;
- Int field1;
- Int field2;
- Int field3;
- Int field4;
- Int field5;
-};
-
-/* The Following structure corresponds to variant with is_extension = True. */
-struct Extended
-{
- Int field6;
- Int field7;
- Int field8;
- Int field9;
- Int field10;
- union
- {
- Int field11;
- struct Flag_Word3 fw3;
- } X;
-
- union
- {
- Int field12;
- struct Flag_Word fw;
- struct Flag_Word2 fw2;
- struct Flag_Word4 fw4;
- struct Flag_Word5 fw5;
- } U;
-};
-
-/* A tree node itself. */
-
-struct Node
-{
- union kind
- {
- struct NFK K;
- struct NFNK NK;
- } U;
-
- union variant
- {
- struct Non_Extended NX;
- struct Extended EX;
- } V;
-};
-
-/* The actual tree is an array of nodes. The pointer to this array is passed
- as a parameter to the tree transformer procedure and stored in the global
- variable Nodes_Ptr after adjusting it by subtracting Node_First_Entry, so
- that Node_Id values can be used as subscripts. */
-extern struct Node *Nodes_Ptr;
-
#define Parent atree__parent
extern Node_Id Parent (Node_Id);
#define Original_Node atree__original_node
extern Node_Id Original_Node (Node_Id);
-/* The auxiliary flags array which is allocated in parallel to Nodes */
-
-struct Flags
-{
- Boolean Flag0 : 1;
- Boolean Flag1 : 1;
- Boolean Flag2 : 1;
- Boolean Flag3 : 1;
- Boolean Spare0 : 1;
- Boolean Spare1 : 1;
- Boolean Spare2 : 1;
- Boolean Spare3 : 1;
-};
-extern struct Flags *Flags_Ptr;
-
-/* Overloaded Functions:
-
- These functions are overloaded in the original Ada source, but there is
- only one corresponding C function, which works as described below. */
-
-/* Type used for union of Node_Id, List_Id, Elist_Id. */
+/* Type used for union of Node_Id, List_Id, Elist_Id. */
typedef Int Tree_Id;
/* These two functions can only be used for Node_Id and List_Id values and
they work in the C version because Empty = No_List = 0. */
-static Boolean No (Tree_Id);
-static Boolean Present (Tree_Id);
+INLINE Boolean No (Tree_Id);
+INLINE Boolean Present (Tree_Id);
INLINE Boolean
No (Tree_Id N)
@@ -400,496 +59,82 @@ No (Tree_Id N)
INLINE Boolean
Present (Tree_Id N)
{
- return N != Empty;
+ return !No (N);
}
-extern Node_Id Parent (Tree_Id);
-
#define Current_Error_Node atree__current_error_node
extern Node_Id Current_Error_Node;
-/* Node Access Functions: */
-
-#define Nkind(N) ((Node_Kind) (Nodes_Ptr[(N) - First_Node_Id].U.K.kind))
-#define Ekind(N) ((Entity_Kind) (Nodes_Ptr[N + 1].U.K.kind))
-#define Sloc(N) (Nodes_Ptr[(N) - First_Node_Id].V.NX.sloc)
-#define Paren_Count(N) (Nodes_Ptr[(N) - First_Node_Id].U.K.pflag1 \
- + 2 * Nodes_Ptr[(N) - First_Node_Id].U.K.pflag2)
-
-#define Field1(N) (Nodes_Ptr[(N) - First_Node_Id].V.NX.field1)
-#define Field2(N) (Nodes_Ptr[(N) - First_Node_Id].V.NX.field2)
-#define Field3(N) (Nodes_Ptr[(N) - First_Node_Id].V.NX.field3)
-#define Field4(N) (Nodes_Ptr[(N) - First_Node_Id].V.NX.field4)
-#define Field5(N) (Nodes_Ptr[(N) - First_Node_Id].V.NX.field5)
-#define Field6(N) (Nodes_Ptr[(N) - First_Node_Id + 1].V.EX.field6)
-#define Field7(N) (Nodes_Ptr[(N) - First_Node_Id + 1].V.EX.field7)
-#define Field8(N) (Nodes_Ptr[(N) - First_Node_Id + 1].V.EX.field8)
-#define Field9(N) (Nodes_Ptr[(N) - First_Node_Id + 1].V.EX.field9)
-#define Field10(N) (Nodes_Ptr[(N) - First_Node_Id + 1].V.EX.field10)
-#define Field11(N) (Nodes_Ptr[(N) - First_Node_Id + 1].V.EX.X.field11)
-#define Field12(N) (Nodes_Ptr[(N) - First_Node_Id + 1].V.EX.U.field12)
-#define Field13(N) (Nodes_Ptr[(N) - First_Node_Id + 2].V.EX.field6)
-#define Field14(N) (Nodes_Ptr[(N) - First_Node_Id + 2].V.EX.field7)
-#define Field15(N) (Nodes_Ptr[(N) - First_Node_Id + 2].V.EX.field8)
-#define Field16(N) (Nodes_Ptr[(N) - First_Node_Id + 2].V.EX.field9)
-#define Field17(N) (Nodes_Ptr[(N) - First_Node_Id + 2].V.EX.field10)
-#define Field18(N) (Nodes_Ptr[(N) - First_Node_Id + 2].V.EX.X.field11)
-#define Field19(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.field6)
-#define Field20(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.field7)
-#define Field21(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.field8)
-#define Field22(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.field9)
-#define Field23(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.field10)
-#define Field24(N) (Nodes_Ptr[(N) - First_Node_Id + 4].V.EX.field6)
-#define Field25(N) (Nodes_Ptr[(N) - First_Node_Id + 4].V.EX.field7)
-#define Field26(N) (Nodes_Ptr[(N) - First_Node_Id + 4].V.EX.field8)
-#define Field27(N) (Nodes_Ptr[(N) - First_Node_Id + 4].V.EX.field9)
-#define Field28(N) (Nodes_Ptr[(N) - First_Node_Id + 4].V.EX.field10)
-#define Field29(N) (Nodes_Ptr[(N) - First_Node_Id + 4].V.EX.X.field11)
-#define Field30(N) (Nodes_Ptr[(N) - First_Node_Id + 5].V.EX.field6)
-#define Field31(N) (Nodes_Ptr[(N) - First_Node_Id + 5].V.EX.field7)
-#define Field32(N) (Nodes_Ptr[(N) - First_Node_Id + 5].V.EX.field8)
-#define Field33(N) (Nodes_Ptr[(N) - First_Node_Id + 5].V.EX.field9)
-#define Field34(N) (Nodes_Ptr[(N) - First_Node_Id + 5].V.EX.field10)
-#define Field35(N) (Nodes_Ptr[(N) - First_Node_Id + 5].V.EX.X.field11)
-#define Field36(N) (Nodes_Ptr[(N) - First_Node_Id + 6].V.EX.field6)
-#define Field37(N) (Nodes_Ptr[(N) - First_Node_Id + 6].V.EX.field7)
-#define Field38(N) (Nodes_Ptr[(N) - First_Node_Id + 6].V.EX.field8)
-#define Field39(N) (Nodes_Ptr[(N) - First_Node_Id + 6].V.EX.field9)
-#define Field40(N) (Nodes_Ptr[(N) - First_Node_Id + 6].V.EX.field10)
-#define Field41(N) (Nodes_Ptr[(N) - First_Node_Id + 6].V.EX.X.field11)
-
-#define Node1(N) Field1 (N)
-#define Node2(N) Field2 (N)
-#define Node3(N) Field3 (N)
-#define Node4(N) Field4 (N)
-#define Node5(N) Field5 (N)
-#define Node6(N) Field6 (N)
-#define Node7(N) Field7 (N)
-#define Node8(N) Field8 (N)
-#define Node9(N) Field9 (N)
-#define Node10(N) Field10 (N)
-#define Node11(N) Field11 (N)
-#define Node12(N) Field12 (N)
-#define Node13(N) Field13 (N)
-#define Node14(N) Field14 (N)
-#define Node15(N) Field15 (N)
-#define Node16(N) Field16 (N)
-#define Node17(N) Field17 (N)
-#define Node18(N) Field18 (N)
-#define Node19(N) Field19 (N)
-#define Node20(N) Field20 (N)
-#define Node21(N) Field21 (N)
-#define Node22(N) Field22 (N)
-#define Node23(N) Field23 (N)
-#define Node24(N) Field24 (N)
-#define Node25(N) Field25 (N)
-#define Node26(N) Field26 (N)
-#define Node27(N) Field27 (N)
-#define Node28(N) Field28 (N)
-#define Node29(N) Field29 (N)
-#define Node30(N) Field30 (N)
-#define Node31(N) Field31 (N)
-#define Node32(N) Field32 (N)
-#define Node33(N) Field33 (N)
-#define Node34(N) Field34 (N)
-#define Node35(N) Field35 (N)
-#define Node36(N) Field36 (N)
-#define Node37(N) Field37 (N)
-#define Node38(N) Field38 (N)
-#define Node39(N) Field39 (N)
-#define Node40(N) Field40 (N)
-#define Node41(N) Field41 (N)
-
-#define List1(N) Field1 (N)
-#define List2(N) Field2 (N)
-#define List3(N) Field3 (N)
-#define List4(N) Field4 (N)
-#define List5(N) Field5 (N)
-#define List10(N) Field10 (N)
-#define List14(N) Field14 (N)
-#define List25(N) Field25 (N)
-#define List38(N) Field38 (N)
-#define List39(N) Field39 (N)
-
-#define Elist1(N) Field1 (N)
-#define Elist2(N) Field2 (N)
-#define Elist3(N) Field3 (N)
-#define Elist4(N) Field4 (N)
-#define Elist5(N) Field5 (N)
-#define Elist8(N) Field8 (N)
-#define Elist9(N) Field9 (N)
-#define Elist10(N) Field10 (N)
-#define Elist11(N) Field11 (N)
-#define Elist13(N) Field13 (N)
-#define Elist15(N) Field15 (N)
-#define Elist16(N) Field16 (N)
-#define Elist18(N) Field18 (N)
-#define Elist21(N) Field21 (N)
-#define Elist23(N) Field23 (N)
-#define Elist24(N) Field24 (N)
-#define Elist25(N) Field25 (N)
-#define Elist26(N) Field26 (N)
-#define Elist29(N) Field29 (N)
-#define Elist30(N) Field30 (N)
-#define Elist36(N) Field36 (N)
-
-#define Name1(N) Field1 (N)
-#define Name2(N) Field2 (N)
-
-#define Char_Code2(N) (Field2 (N) - Char_Code_Bias)
-
-#define Str3(N) Field3 (N)
-
-#define Uint2(N) ((Field2 (N) == 0) ? Uint_0 : Field2 (N))
-#define Uint3(N) ((Field3 (N) == 0) ? Uint_0 : Field3 (N))
-#define Uint4(N) ((Field4 (N) == 0) ? Uint_0 : Field4 (N))
-#define Uint5(N) ((Field5 (N) == 0) ? Uint_0 : Field5 (N))
-#define Uint8(N) ((Field8 (N) == 0) ? Uint_0 : Field8 (N))
-#define Uint9(N) ((Field9 (N) == 0) ? Uint_0 : Field9 (N))
-#define Uint10(N) ((Field10 (N) == 0) ? Uint_0 : Field10 (N))
-#define Uint11(N) ((Field11 (N) == 0) ? Uint_0 : Field11 (N))
-#define Uint12(N) ((Field12 (N) == 0) ? Uint_0 : Field12 (N))
-#define Uint13(N) ((Field13 (N) == 0) ? Uint_0 : Field13 (N))
-#define Uint14(N) ((Field14 (N) == 0) ? Uint_0 : Field14 (N))
-#define Uint15(N) ((Field15 (N) == 0) ? Uint_0 : Field15 (N))
-#define Uint16(N) ((Field16 (N) == 0) ? Uint_0 : Field16 (N))
-#define Uint17(N) ((Field17 (N) == 0) ? Uint_0 : Field17 (N))
-#define Uint22(N) ((Field22 (N) == 0) ? Uint_0 : Field22 (N))
-#define Uint24(N) ((Field24 (N) == 0) ? Uint_0 : Field24 (N))
-
-#define Ureal3(N) Field3 (N)
-#define Ureal18(N) Field18 (N)
-#define Ureal21(N) Field21 (N)
-
-#define Analyzed(N) (Nodes_Ptr[(N) - First_Node_Id].U.K.analyzed)
-#define Comes_From_Source(N) (Nodes_Ptr[(N) - First_Node_Id].U.K.c_f_s)
-#define Error_Posted(N) (Nodes_Ptr[(N) - First_Node_Id].U.K.error_posted)
-#define Has_Aspects(N) (Nodes_Ptr[(N) - First_Node_Id].U.K.has_aspects)
-#define Convention(N) \
- (Nodes_Ptr[(N) - First_Node_Id + 2].V.EX.U.fw.convention)
+/* The following code corresponds to the Get_n_Bit_Field functions (for
+ various n) in package Atree. The low-level getters in sinfo.h call
+ these even-lower-level getters. */
-#define Flag0(N) (Flags_Ptr[(N) - First_Node_Id].Flag0)
-#define Flag1(N) (Flags_Ptr[(N) - First_Node_Id].Flag1)
-#define Flag2(N) (Flags_Ptr[(N) - First_Node_Id].Flag2)
-#define Flag3(N) (Flags_Ptr[(N) - First_Node_Id].Flag3)
+extern Field_Offset *Node_Offsets_Ptr;
+extern any_slot *Slots_Ptr;
-#define Flag4(N) (Nodes_Ptr[(N) - First_Node_Id].U.K.flag4)
-#define Flag5(N) (Nodes_Ptr[(N) - First_Node_Id].U.K.flag5)
-#define Flag6(N) (Nodes_Ptr[(N) - First_Node_Id].U.K.flag6)
-#define Flag7(N) (Nodes_Ptr[(N) - First_Node_Id].U.K.flag7)
-#define Flag8(N) (Nodes_Ptr[(N) - First_Node_Id].U.K.flag8)
-#define Flag9(N) (Nodes_Ptr[(N) - First_Node_Id].U.K.flag9)
-#define Flag10(N) (Nodes_Ptr[(N) - First_Node_Id].U.K.flag10)
-#define Flag11(N) (Nodes_Ptr[(N) - First_Node_Id].U.K.flag11)
-#define Flag12(N) (Nodes_Ptr[(N) - First_Node_Id].U.K.flag12)
-#define Flag13(N) (Nodes_Ptr[(N) - First_Node_Id].U.K.flag13)
-#define Flag14(N) (Nodes_Ptr[(N) - First_Node_Id].U.K.flag14)
-#define Flag15(N) (Nodes_Ptr[(N) - First_Node_Id].U.K.flag15)
-#define Flag16(N) (Nodes_Ptr[(N) - First_Node_Id].U.K.flag16)
-#define Flag17(N) (Nodes_Ptr[(N) - First_Node_Id].U.K.flag17)
-#define Flag18(N) (Nodes_Ptr[(N) - First_Node_Id].U.K.flag18)
+INLINE unsigned int Get_1_Bit_Field (Node_Id, Field_Offset);
+INLINE unsigned int Get_2_Bit_Field (Node_Id, Field_Offset);
+INLINE unsigned int Get_4_Bit_Field (Node_Id, Field_Offset);
+INLINE unsigned int Get_8_Bit_Field (Node_Id, Field_Offset);
+INLINE unsigned int Get_32_Bit_Field (Node_Id, Field_Offset);
+INLINE unsigned int Get_32_Bit_Field_With_Default (Node_Id, Field_Offset,
+ unsigned int);
+INLINE unsigned int Get_Valid_32_Bit_Field (Node_Id, Field_Offset);
-#define Flag19(N) (Nodes_Ptr[(N) - First_Node_Id + 1].U.K.in_list)
-#define Flag20(N) (Nodes_Ptr[(N) - First_Node_Id + 1].U.K.has_aspects)
-#define Flag21(N) (Nodes_Ptr[(N) - First_Node_Id + 1].U.K.rewrite_ins)
-#define Flag22(N) (Nodes_Ptr[(N) - First_Node_Id + 1].U.K.analyzed)
-#define Flag23(N) (Nodes_Ptr[(N) - First_Node_Id + 1].U.K.c_f_s)
-#define Flag24(N) (Nodes_Ptr[(N) - First_Node_Id + 1].U.K.error_posted)
-#define Flag25(N) (Nodes_Ptr[(N) - First_Node_Id + 1].U.K.flag4)
-#define Flag26(N) (Nodes_Ptr[(N) - First_Node_Id + 1].U.K.flag5)
-#define Flag27(N) (Nodes_Ptr[(N) - First_Node_Id + 1].U.K.flag6)
-#define Flag28(N) (Nodes_Ptr[(N) - First_Node_Id + 1].U.K.flag7)
-#define Flag29(N) (Nodes_Ptr[(N) - First_Node_Id + 1].U.K.flag8)
-#define Flag30(N) (Nodes_Ptr[(N) - First_Node_Id + 1].U.K.flag9)
-#define Flag31(N) (Nodes_Ptr[(N) - First_Node_Id + 1].U.K.flag10)
-#define Flag32(N) (Nodes_Ptr[(N) - First_Node_Id + 1].U.K.flag11)
-#define Flag33(N) (Nodes_Ptr[(N) - First_Node_Id + 1].U.K.flag12)
-#define Flag34(N) (Nodes_Ptr[(N) - First_Node_Id + 1].U.K.flag13)
-#define Flag35(N) (Nodes_Ptr[(N) - First_Node_Id + 1].U.K.flag14)
-#define Flag36(N) (Nodes_Ptr[(N) - First_Node_Id + 1].U.K.flag15)
-#define Flag37(N) (Nodes_Ptr[(N) - First_Node_Id + 1].U.K.flag16)
-#define Flag38(N) (Nodes_Ptr[(N) - First_Node_Id + 1].U.K.flag17)
-#define Flag39(N) (Nodes_Ptr[(N) - First_Node_Id + 1].U.K.flag18)
-
-#define Flag40(N) (Nodes_Ptr[(N) - First_Node_Id + 2].U.K.in_list)
-#define Flag41(N) (Nodes_Ptr[(N) - First_Node_Id + 2].U.K.has_aspects)
-#define Flag42(N) (Nodes_Ptr[(N) - First_Node_Id + 2].U.K.rewrite_ins)
-#define Flag43(N) (Nodes_Ptr[(N) - First_Node_Id + 2].U.K.analyzed)
-#define Flag44(N) (Nodes_Ptr[(N) - First_Node_Id + 2].U.K.c_f_s)
-#define Flag45(N) (Nodes_Ptr[(N) - First_Node_Id + 2].U.K.error_posted)
-#define Flag46(N) (Nodes_Ptr[(N) - First_Node_Id + 2].U.K.flag4)
-#define Flag47(N) (Nodes_Ptr[(N) - First_Node_Id + 2].U.K.flag5)
-#define Flag48(N) (Nodes_Ptr[(N) - First_Node_Id + 2].U.K.flag6)
-#define Flag49(N) (Nodes_Ptr[(N) - First_Node_Id + 2].U.K.flag7)
-#define Flag50(N) (Nodes_Ptr[(N) - First_Node_Id + 2].U.K.flag8)
-#define Flag51(N) (Nodes_Ptr[(N) - First_Node_Id + 2].U.K.flag9)
-#define Flag52(N) (Nodes_Ptr[(N) - First_Node_Id + 2].U.K.flag10)
-#define Flag53(N) (Nodes_Ptr[(N) - First_Node_Id + 2].U.K.flag11)
-#define Flag54(N) (Nodes_Ptr[(N) - First_Node_Id + 2].U.K.flag12)
-#define Flag55(N) (Nodes_Ptr[(N) - First_Node_Id + 2].U.K.flag13)
-#define Flag56(N) (Nodes_Ptr[(N) - First_Node_Id + 2].U.K.flag14)
-#define Flag57(N) (Nodes_Ptr[(N) - First_Node_Id + 2].U.K.flag15)
-#define Flag58(N) (Nodes_Ptr[(N) - First_Node_Id + 2].U.K.flag16)
-#define Flag59(N) (Nodes_Ptr[(N) - First_Node_Id + 2].U.K.flag17)
-#define Flag60(N) (Nodes_Ptr[(N) - First_Node_Id + 2].U.K.flag18)
-#define Flag61(N) (Nodes_Ptr[(N) - First_Node_Id + 1].U.K.pflag1)
-#define Flag62(N) (Nodes_Ptr[(N) - First_Node_Id + 1].U.K.pflag2)
-#define Flag63(N) (Nodes_Ptr[(N) - First_Node_Id + 2].U.K.pflag1)
-#define Flag64(N) (Nodes_Ptr[(N) - First_Node_Id + 2].U.K.pflag2)
-
-#define Flag65(N) (Nodes_Ptr[(N) - First_Node_Id + 2].U.NK.flag65)
-#define Flag66(N) (Nodes_Ptr[(N) - First_Node_Id + 2].U.NK.flag66)
-#define Flag67(N) (Nodes_Ptr[(N) - First_Node_Id + 2].U.NK.flag67)
-#define Flag68(N) (Nodes_Ptr[(N) - First_Node_Id + 2].U.NK.flag68)
-#define Flag69(N) (Nodes_Ptr[(N) - First_Node_Id + 2].U.NK.flag69)
-#define Flag70(N) (Nodes_Ptr[(N) - First_Node_Id + 2].U.NK.flag70)
-#define Flag71(N) (Nodes_Ptr[(N) - First_Node_Id + 2].U.NK.flag71)
-#define Flag72(N) (Nodes_Ptr[(N) - First_Node_Id + 2].U.NK.flag72)
-
-#define Flag73(N) (Nodes_Ptr[(N) - First_Node_Id + 2].V.EX.U.fw.flag73)
-#define Flag74(N) (Nodes_Ptr[(N) - First_Node_Id + 2].V.EX.U.fw.flag74)
-#define Flag75(N) (Nodes_Ptr[(N) - First_Node_Id + 2].V.EX.U.fw.flag75)
-#define Flag76(N) (Nodes_Ptr[(N) - First_Node_Id + 2].V.EX.U.fw.flag76)
-#define Flag77(N) (Nodes_Ptr[(N) - First_Node_Id + 2].V.EX.U.fw.flag77)
-#define Flag78(N) (Nodes_Ptr[(N) - First_Node_Id + 2].V.EX.U.fw.flag78)
-#define Flag79(N) (Nodes_Ptr[(N) - First_Node_Id + 2].V.EX.U.fw.flag79)
-#define Flag80(N) (Nodes_Ptr[(N) - First_Node_Id + 2].V.EX.U.fw.flag80)
-#define Flag81(N) (Nodes_Ptr[(N) - First_Node_Id + 2].V.EX.U.fw.flag81)
-#define Flag82(N) (Nodes_Ptr[(N) - First_Node_Id + 2].V.EX.U.fw.flag82)
-#define Flag83(N) (Nodes_Ptr[(N) - First_Node_Id + 2].V.EX.U.fw.flag83)
-#define Flag84(N) (Nodes_Ptr[(N) - First_Node_Id + 2].V.EX.U.fw.flag84)
-#define Flag85(N) (Nodes_Ptr[(N) - First_Node_Id + 2].V.EX.U.fw.flag85)
-#define Flag86(N) (Nodes_Ptr[(N) - First_Node_Id + 2].V.EX.U.fw.flag86)
-#define Flag87(N) (Nodes_Ptr[(N) - First_Node_Id + 2].V.EX.U.fw.flag87)
-#define Flag88(N) (Nodes_Ptr[(N) - First_Node_Id + 2].V.EX.U.fw.flag88)
-#define Flag89(N) (Nodes_Ptr[(N) - First_Node_Id + 2].V.EX.U.fw.flag89)
-#define Flag90(N) (Nodes_Ptr[(N) - First_Node_Id + 2].V.EX.U.fw.flag90)
-#define Flag91(N) (Nodes_Ptr[(N) - First_Node_Id + 2].V.EX.U.fw.flag91)
-#define Flag92(N) (Nodes_Ptr[(N) - First_Node_Id + 2].V.EX.U.fw.flag92)
-#define Flag93(N) (Nodes_Ptr[(N) - First_Node_Id + 2].V.EX.U.fw.flag93)
-#define Flag94(N) (Nodes_Ptr[(N) - First_Node_Id + 2].V.EX.U.fw.flag94)
-#define Flag95(N) (Nodes_Ptr[(N) - First_Node_Id + 2].V.EX.U.fw.flag95)
-#define Flag96(N) (Nodes_Ptr[(N) - First_Node_Id + 2].V.EX.U.fw.flag96)
-#define Flag97(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.U.fw2.flag97)
-#define Flag98(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.U.fw2.flag98)
-#define Flag99(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.U.fw2.flag99)
-#define Flag100(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.U.fw2.flag100)
-#define Flag101(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.U.fw2.flag101)
-#define Flag102(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.U.fw2.flag102)
-#define Flag103(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.U.fw2.flag103)
-#define Flag104(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.U.fw2.flag104)
-#define Flag105(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.U.fw2.flag105)
-#define Flag106(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.U.fw2.flag106)
-#define Flag107(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.U.fw2.flag107)
-#define Flag108(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.U.fw2.flag108)
-#define Flag109(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.U.fw2.flag109)
-#define Flag110(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.U.fw2.flag110)
-#define Flag111(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.U.fw2.flag111)
-#define Flag112(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.U.fw2.flag112)
-#define Flag113(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.U.fw2.flag113)
-#define Flag114(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.U.fw2.flag114)
-#define Flag115(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.U.fw2.flag115)
-#define Flag116(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.U.fw2.flag116)
-#define Flag117(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.U.fw2.flag117)
-#define Flag118(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.U.fw2.flag118)
-#define Flag119(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.U.fw2.flag119)
-#define Flag120(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.U.fw2.flag120)
-#define Flag121(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.U.fw2.flag121)
-#define Flag122(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.U.fw2.flag122)
-#define Flag123(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.U.fw2.flag123)
-#define Flag124(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.U.fw2.flag124)
-#define Flag125(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.U.fw2.flag125)
-#define Flag126(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.U.fw2.flag126)
-#define Flag127(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.U.fw2.flag127)
-#define Flag128(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.U.fw2.flag128)
-
-#define Flag129(N) (Nodes_Ptr[(N) - First_Node_Id + 3].U.K.in_list)
-#define Flag130(N) (Nodes_Ptr[(N) - First_Node_Id + 3].U.K.has_aspects)
-#define Flag131(N) (Nodes_Ptr[(N) - First_Node_Id + 3].U.K.rewrite_ins)
-#define Flag132(N) (Nodes_Ptr[(N) - First_Node_Id + 3].U.K.analyzed)
-#define Flag133(N) (Nodes_Ptr[(N) - First_Node_Id + 3].U.K.c_f_s)
-#define Flag134(N) (Nodes_Ptr[(N) - First_Node_Id + 3].U.K.error_posted)
-#define Flag135(N) (Nodes_Ptr[(N) - First_Node_Id + 3].U.K.flag4)
-#define Flag136(N) (Nodes_Ptr[(N) - First_Node_Id + 3].U.K.flag5)
-#define Flag137(N) (Nodes_Ptr[(N) - First_Node_Id + 3].U.K.flag6)
-#define Flag138(N) (Nodes_Ptr[(N) - First_Node_Id + 3].U.K.flag7)
-#define Flag139(N) (Nodes_Ptr[(N) - First_Node_Id + 3].U.K.flag8)
-#define Flag140(N) (Nodes_Ptr[(N) - First_Node_Id + 3].U.K.flag9)
-#define Flag141(N) (Nodes_Ptr[(N) - First_Node_Id + 3].U.K.flag10)
-#define Flag142(N) (Nodes_Ptr[(N) - First_Node_Id + 3].U.K.flag11)
-#define Flag143(N) (Nodes_Ptr[(N) - First_Node_Id + 3].U.K.flag12)
-#define Flag144(N) (Nodes_Ptr[(N) - First_Node_Id + 3].U.K.flag13)
-#define Flag145(N) (Nodes_Ptr[(N) - First_Node_Id + 3].U.K.flag14)
-#define Flag146(N) (Nodes_Ptr[(N) - First_Node_Id + 3].U.K.flag15)
-#define Flag147(N) (Nodes_Ptr[(N) - First_Node_Id + 3].U.K.flag16)
-#define Flag148(N) (Nodes_Ptr[(N) - First_Node_Id + 3].U.K.flag17)
-#define Flag149(N) (Nodes_Ptr[(N) - First_Node_Id + 3].U.K.flag18)
-#define Flag150(N) (Nodes_Ptr[(N) - First_Node_Id + 3].U.K.pflag1)
-#define Flag151(N) (Nodes_Ptr[(N) - First_Node_Id + 3].U.K.pflag2)
+INLINE unsigned int
+Get_1_Bit_Field (Node_Id N, Field_Offset Offset)
+{
+ const Field_Offset L = Slot_Size / 1;
+ any_slot slot = *(Slots_Ptr + Node_Offsets_Ptr[N] + Offset / L);
+ return (slot >> (Offset % L) * (Slot_Size / L)) & 1;
+}
-#define Flag152(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.X.fw3.flag152)
-#define Flag153(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.X.fw3.flag153)
-#define Flag154(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.X.fw3.flag154)
-#define Flag155(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.X.fw3.flag155)
-#define Flag156(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.X.fw3.flag156)
-#define Flag157(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.X.fw3.flag157)
-#define Flag158(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.X.fw3.flag158)
-#define Flag159(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.X.fw3.flag159)
-#define Flag160(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.X.fw3.flag160)
-#define Flag161(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.X.fw3.flag161)
-#define Flag162(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.X.fw3.flag162)
-#define Flag163(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.X.fw3.flag163)
-#define Flag164(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.X.fw3.flag164)
-#define Flag165(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.X.fw3.flag165)
-#define Flag166(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.X.fw3.flag166)
-#define Flag167(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.X.fw3.flag167)
-#define Flag168(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.X.fw3.flag168)
-#define Flag169(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.X.fw3.flag169)
-#define Flag170(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.X.fw3.flag170)
-#define Flag171(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.X.fw3.flag171)
-#define Flag172(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.X.fw3.flag172)
-#define Flag173(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.X.fw3.flag173)
-#define Flag174(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.X.fw3.flag174)
-#define Flag175(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.X.fw3.flag175)
-#define Flag176(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.X.fw3.flag176)
-#define Flag177(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.X.fw3.flag177)
-#define Flag178(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.X.fw3.flag178)
-#define Flag179(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.X.fw3.flag179)
-#define Flag180(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.X.fw3.flag180)
-#define Flag181(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.X.fw3.flag181)
-#define Flag182(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.X.fw3.flag182)
-#define Flag183(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.X.fw3.flag183)
+INLINE unsigned int
+Get_2_Bit_Field (Node_Id N, Field_Offset Offset)
+{
+ const Field_Offset L = Slot_Size / 2;
+ any_slot slot = *(Slots_Ptr + Node_Offsets_Ptr[N] + Offset / L);
+ return (slot >> (Offset % L) * (Slot_Size / L)) & 3;
+}
-#define Flag184(N) (Nodes_Ptr[(N) - First_Node_Id + 4].V.EX.U.fw4.flag184)
-#define Flag185(N) (Nodes_Ptr[(N) - First_Node_Id + 4].V.EX.U.fw4.flag185)
-#define Flag186(N) (Nodes_Ptr[(N) - First_Node_Id + 4].V.EX.U.fw4.flag186)
-#define Flag187(N) (Nodes_Ptr[(N) - First_Node_Id + 4].V.EX.U.fw4.flag187)
-#define Flag188(N) (Nodes_Ptr[(N) - First_Node_Id + 4].V.EX.U.fw4.flag188)
-#define Flag189(N) (Nodes_Ptr[(N) - First_Node_Id + 4].V.EX.U.fw4.flag189)
-#define Flag190(N) (Nodes_Ptr[(N) - First_Node_Id + 4].V.EX.U.fw4.flag190)
-#define Flag191(N) (Nodes_Ptr[(N) - First_Node_Id + 4].V.EX.U.fw4.flag191)
-#define Flag192(N) (Nodes_Ptr[(N) - First_Node_Id + 4].V.EX.U.fw4.flag192)
-#define Flag193(N) (Nodes_Ptr[(N) - First_Node_Id + 4].V.EX.U.fw4.flag193)
-#define Flag194(N) (Nodes_Ptr[(N) - First_Node_Id + 4].V.EX.U.fw4.flag194)
-#define Flag195(N) (Nodes_Ptr[(N) - First_Node_Id + 4].V.EX.U.fw4.flag195)
-#define Flag196(N) (Nodes_Ptr[(N) - First_Node_Id + 4].V.EX.U.fw4.flag196)
-#define Flag197(N) (Nodes_Ptr[(N) - First_Node_Id + 4].V.EX.U.fw4.flag197)
-#define Flag198(N) (Nodes_Ptr[(N) - First_Node_Id + 4].V.EX.U.fw4.flag198)
-#define Flag199(N) (Nodes_Ptr[(N) - First_Node_Id + 4].V.EX.U.fw4.flag199)
-#define Flag200(N) (Nodes_Ptr[(N) - First_Node_Id + 4].V.EX.U.fw4.flag200)
-#define Flag201(N) (Nodes_Ptr[(N) - First_Node_Id + 4].V.EX.U.fw4.flag201)
-#define Flag202(N) (Nodes_Ptr[(N) - First_Node_Id + 4].V.EX.U.fw4.flag202)
-#define Flag203(N) (Nodes_Ptr[(N) - First_Node_Id + 4].V.EX.U.fw4.flag203)
-#define Flag204(N) (Nodes_Ptr[(N) - First_Node_Id + 4].V.EX.U.fw4.flag204)
-#define Flag205(N) (Nodes_Ptr[(N) - First_Node_Id + 4].V.EX.U.fw4.flag205)
-#define Flag206(N) (Nodes_Ptr[(N) - First_Node_Id + 4].V.EX.U.fw4.flag206)
-#define Flag207(N) (Nodes_Ptr[(N) - First_Node_Id + 4].V.EX.U.fw4.flag207)
-#define Flag208(N) (Nodes_Ptr[(N) - First_Node_Id + 4].V.EX.U.fw4.flag208)
-#define Flag209(N) (Nodes_Ptr[(N) - First_Node_Id + 4].V.EX.U.fw4.flag209)
-#define Flag210(N) (Nodes_Ptr[(N) - First_Node_Id + 4].V.EX.U.fw4.flag210)
-#define Flag211(N) (Nodes_Ptr[(N) - First_Node_Id + 4].V.EX.U.fw4.flag211)
-#define Flag212(N) (Nodes_Ptr[(N) - First_Node_Id + 4].V.EX.U.fw4.flag212)
-#define Flag213(N) (Nodes_Ptr[(N) - First_Node_Id + 4].V.EX.U.fw4.flag213)
-#define Flag214(N) (Nodes_Ptr[(N) - First_Node_Id + 4].V.EX.U.fw4.flag214)
-#define Flag215(N) (Nodes_Ptr[(N) - First_Node_Id + 4].V.EX.U.fw4.flag215)
+INLINE unsigned int
+Get_4_Bit_Field (Node_Id N, Field_Offset Offset)
+{
+ const Field_Offset L = Slot_Size / 4;
+ any_slot slot = *(Slots_Ptr + Node_Offsets_Ptr[N] + Offset / L);
+ return (slot >> (Offset % L) * (Slot_Size / L)) & 15;
+}
-#define Flag216(N) (Nodes_Ptr[(N) - First_Node_Id + 4].U.K.in_list)
-#define Flag217(N) (Nodes_Ptr[(N) - First_Node_Id + 4].U.K.has_aspects)
-#define Flag218(N) (Nodes_Ptr[(N) - First_Node_Id + 4].U.K.rewrite_ins)
-#define Flag219(N) (Nodes_Ptr[(N) - First_Node_Id + 4].U.K.analyzed)
-#define Flag220(N) (Nodes_Ptr[(N) - First_Node_Id + 4].U.K.c_f_s)
-#define Flag221(N) (Nodes_Ptr[(N) - First_Node_Id + 4].U.K.error_posted)
-#define Flag222(N) (Nodes_Ptr[(N) - First_Node_Id + 4].U.K.flag4)
-#define Flag223(N) (Nodes_Ptr[(N) - First_Node_Id + 4].U.K.flag5)
-#define Flag224(N) (Nodes_Ptr[(N) - First_Node_Id + 4].U.K.flag6)
-#define Flag225(N) (Nodes_Ptr[(N) - First_Node_Id + 4].U.K.flag7)
-#define Flag226(N) (Nodes_Ptr[(N) - First_Node_Id + 4].U.K.flag8)
-#define Flag227(N) (Nodes_Ptr[(N) - First_Node_Id + 4].U.K.flag9)
-#define Flag228(N) (Nodes_Ptr[(N) - First_Node_Id + 4].U.K.flag10)
-#define Flag229(N) (Nodes_Ptr[(N) - First_Node_Id + 4].U.K.flag11)
-#define Flag230(N) (Nodes_Ptr[(N) - First_Node_Id + 4].U.K.flag12)
-#define Flag231(N) (Nodes_Ptr[(N) - First_Node_Id + 4].U.K.flag13)
-#define Flag232(N) (Nodes_Ptr[(N) - First_Node_Id + 4].U.K.flag14)
-#define Flag233(N) (Nodes_Ptr[(N) - First_Node_Id + 4].U.K.flag15)
-#define Flag234(N) (Nodes_Ptr[(N) - First_Node_Id + 4].U.K.flag16)
-#define Flag235(N) (Nodes_Ptr[(N) - First_Node_Id + 4].U.K.flag17)
-#define Flag236(N) (Nodes_Ptr[(N) - First_Node_Id + 4].U.K.flag18)
-#define Flag237(N) (Nodes_Ptr[(N) - First_Node_Id + 4].U.K.pflag1)
-#define Flag238(N) (Nodes_Ptr[(N) - First_Node_Id + 4].U.K.pflag2)
+INLINE unsigned int
+Get_8_Bit_Field (Node_Id N, Field_Offset Offset)
+{
+ const Field_Offset L = Slot_Size / 8;
+ any_slot slot = *(Slots_Ptr + Node_Offsets_Ptr[N] + Offset / L);
+ return (slot >> (Offset % L) * (Slot_Size / L)) & 255;
+}
-#define Flag239(N) (Nodes_Ptr[(N) - First_Node_Id + 3].U.NK.flag65)
-#define Flag240(N) (Nodes_Ptr[(N) - First_Node_Id + 3].U.NK.flag66)
-#define Flag241(N) (Nodes_Ptr[(N) - First_Node_Id + 3].U.NK.flag67)
-#define Flag242(N) (Nodes_Ptr[(N) - First_Node_Id + 3].U.NK.flag68)
-#define Flag243(N) (Nodes_Ptr[(N) - First_Node_Id + 3].U.NK.flag69)
-#define Flag244(N) (Nodes_Ptr[(N) - First_Node_Id + 3].U.NK.flag70)
-#define Flag245(N) (Nodes_Ptr[(N) - First_Node_Id + 3].U.NK.flag71)
-#define Flag246(N) (Nodes_Ptr[(N) - First_Node_Id + 3].U.NK.flag72)
+INLINE unsigned int
+Get_32_Bit_Field (Node_Id N, Field_Offset Offset)
+{
+ any_slot slot = *(Slots_Ptr + Node_Offsets_Ptr[N] + Offset);
+ return slot;
+}
-#define Flag247(N) (Nodes_Ptr[(N) - First_Node_Id + 4].U.NK.flag65)
-#define Flag248(N) (Nodes_Ptr[(N) - First_Node_Id + 4].U.NK.flag66)
-#define Flag249(N) (Nodes_Ptr[(N) - First_Node_Id + 4].U.NK.flag67)
-#define Flag250(N) (Nodes_Ptr[(N) - First_Node_Id + 4].U.NK.flag68)
-#define Flag251(N) (Nodes_Ptr[(N) - First_Node_Id + 4].U.NK.flag69)
-#define Flag252(N) (Nodes_Ptr[(N) - First_Node_Id + 4].U.NK.flag70)
-#define Flag253(N) (Nodes_Ptr[(N) - First_Node_Id + 4].U.NK.flag71)
-#define Flag254(N) (Nodes_Ptr[(N) - First_Node_Id + 4].U.NK.flag72)
+INLINE unsigned int
+Get_32_Bit_Field_With_Default (Node_Id N, Field_Offset Offset,
+ unsigned int Default_Value)
+{
+ any_slot slot = *(Slots_Ptr + Node_Offsets_Ptr[N] + Offset);
+ return slot == Empty ? Default_Value : slot;
+}
-#define Flag255(N) (Nodes_Ptr[(N) - First_Node_Id + 5].V.EX.U.fw5.flag255)
-#define Flag256(N) (Nodes_Ptr[(N) - First_Node_Id + 5].V.EX.U.fw5.flag256)
-#define Flag257(N) (Nodes_Ptr[(N) - First_Node_Id + 5].V.EX.U.fw5.flag257)
-#define Flag258(N) (Nodes_Ptr[(N) - First_Node_Id + 5].V.EX.U.fw5.flag258)
-#define Flag259(N) (Nodes_Ptr[(N) - First_Node_Id + 5].V.EX.U.fw5.flag259)
-#define Flag260(N) (Nodes_Ptr[(N) - First_Node_Id + 5].V.EX.U.fw5.flag260)
-#define Flag261(N) (Nodes_Ptr[(N) - First_Node_Id + 5].V.EX.U.fw5.flag261)
-#define Flag262(N) (Nodes_Ptr[(N) - First_Node_Id + 5].V.EX.U.fw5.flag262)
-#define Flag263(N) (Nodes_Ptr[(N) - First_Node_Id + 5].V.EX.U.fw5.flag263)
-#define Flag264(N) (Nodes_Ptr[(N) - First_Node_Id + 5].V.EX.U.fw5.flag264)
-#define Flag265(N) (Nodes_Ptr[(N) - First_Node_Id + 5].V.EX.U.fw5.flag265)
-#define Flag266(N) (Nodes_Ptr[(N) - First_Node_Id + 5].V.EX.U.fw5.flag266)
-#define Flag267(N) (Nodes_Ptr[(N) - First_Node_Id + 5].V.EX.U.fw5.flag267)
-#define Flag268(N) (Nodes_Ptr[(N) - First_Node_Id + 5].V.EX.U.fw5.flag268)
-#define Flag269(N) (Nodes_Ptr[(N) - First_Node_Id + 5].V.EX.U.fw5.flag269)
-#define Flag270(N) (Nodes_Ptr[(N) - First_Node_Id + 5].V.EX.U.fw5.flag270)
-#define Flag271(N) (Nodes_Ptr[(N) - First_Node_Id + 5].V.EX.U.fw5.flag271)
-#define Flag272(N) (Nodes_Ptr[(N) - First_Node_Id + 5].V.EX.U.fw5.flag272)
-#define Flag273(N) (Nodes_Ptr[(N) - First_Node_Id + 5].V.EX.U.fw5.flag273)
-#define Flag274(N) (Nodes_Ptr[(N) - First_Node_Id + 5].V.EX.U.fw5.flag274)
-#define Flag275(N) (Nodes_Ptr[(N) - First_Node_Id + 5].V.EX.U.fw5.flag275)
-#define Flag276(N) (Nodes_Ptr[(N) - First_Node_Id + 5].V.EX.U.fw5.flag276)
-#define Flag277(N) (Nodes_Ptr[(N) - First_Node_Id + 5].V.EX.U.fw5.flag277)
-#define Flag278(N) (Nodes_Ptr[(N) - First_Node_Id + 5].V.EX.U.fw5.flag278)
-#define Flag279(N) (Nodes_Ptr[(N) - First_Node_Id + 5].V.EX.U.fw5.flag279)
-#define Flag280(N) (Nodes_Ptr[(N) - First_Node_Id + 5].V.EX.U.fw5.flag280)
-#define Flag281(N) (Nodes_Ptr[(N) - First_Node_Id + 5].V.EX.U.fw5.flag281)
-#define Flag282(N) (Nodes_Ptr[(N) - First_Node_Id + 5].V.EX.U.fw5.flag282)
-#define Flag283(N) (Nodes_Ptr[(N) - First_Node_Id + 5].V.EX.U.fw5.flag283)
-#define Flag284(N) (Nodes_Ptr[(N) - First_Node_Id + 5].V.EX.U.fw5.flag284)
-#define Flag285(N) (Nodes_Ptr[(N) - First_Node_Id + 5].V.EX.U.fw5.flag285)
-#define Flag286(N) (Nodes_Ptr[(N) - First_Node_Id + 5].V.EX.U.fw5.flag286)
-#define Flag287(N) (Nodes_Ptr[(N) - First_Node_Id + 5].U.K.in_list)
-#define Flag288(N) (Nodes_Ptr[(N) - First_Node_Id + 5].U.K.has_aspects)
-#define Flag289(N) (Nodes_Ptr[(N) - First_Node_Id + 5].U.K.rewrite_ins)
-#define Flag290(N) (Nodes_Ptr[(N) - First_Node_Id + 5].U.K.analyzed)
-#define Flag291(N) (Nodes_Ptr[(N) - First_Node_Id + 5].U.K.c_f_s)
-#define Flag292(N) (Nodes_Ptr[(N) - First_Node_Id + 5].U.K.error_posted)
-#define Flag293(N) (Nodes_Ptr[(N) - First_Node_Id + 5].U.K.flag4)
-#define Flag294(N) (Nodes_Ptr[(N) - First_Node_Id + 5].U.K.flag5)
-#define Flag295(N) (Nodes_Ptr[(N) - First_Node_Id + 5].U.K.flag6)
-#define Flag296(N) (Nodes_Ptr[(N) - First_Node_Id + 5].U.K.flag7)
-#define Flag297(N) (Nodes_Ptr[(N) - First_Node_Id + 5].U.K.flag8)
-#define Flag298(N) (Nodes_Ptr[(N) - First_Node_Id + 5].U.K.flag9)
-#define Flag299(N) (Nodes_Ptr[(N) - First_Node_Id + 5].U.K.flag10)
-#define Flag300(N) (Nodes_Ptr[(N) - First_Node_Id + 5].U.K.flag11)
-#define Flag301(N) (Nodes_Ptr[(N) - First_Node_Id + 5].U.K.flag12)
-#define Flag302(N) (Nodes_Ptr[(N) - First_Node_Id + 5].U.K.flag13)
-#define Flag303(N) (Nodes_Ptr[(N) - First_Node_Id + 5].U.K.flag14)
-#define Flag304(N) (Nodes_Ptr[(N) - First_Node_Id + 5].U.K.flag15)
-#define Flag305(N) (Nodes_Ptr[(N) - First_Node_Id + 5].U.K.flag16)
-#define Flag306(N) (Nodes_Ptr[(N) - First_Node_Id + 5].U.K.flag17)
-#define Flag307(N) (Nodes_Ptr[(N) - First_Node_Id + 5].U.K.flag18)
-#define Flag308(N) (Nodes_Ptr[(N) - First_Node_Id + 5].U.K.pflag1)
-#define Flag309(N) (Nodes_Ptr[(N) - First_Node_Id + 5].U.K.pflag2)
+INLINE unsigned int
+Get_Valid_32_Bit_Field (Node_Id N, Field_Offset Offset)
+{
+ any_slot slot = *(Slots_Ptr + Node_Offsets_Ptr[N] + Offset);
+ gcc_assert (slot != Empty);
+ return slot;
+}
#ifdef __cplusplus
}
diff --git a/gcc/ada/aux-io.c b/gcc/ada/aux-io.c
index f559c39..9f6b45b 100644
--- a/gcc/ada/aux-io.c
+++ b/gcc/ada/aux-io.c
@@ -6,7 +6,7 @@
* *
* C Implementation File *
* *
- * Copyright (C) 1992-2020, Free Software Foundation, Inc. *
+ * Copyright (C) 1992-2021, Free Software Foundation, Inc. *
* *
* GNAT is free software; you can redistribute 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 38266fc..42d837d 100644
--- a/gcc/ada/back_end.adb
+++ b/gcc/ada/back_end.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -88,8 +88,8 @@ package body Back_End is
(gnat_root : Int;
max_gnat_node : Int;
number_name : Nat;
- nodes_ptr : Address;
- flags_ptr : Address;
+ node_offsets_ptr : Address;
+ slots_ptr : Address;
next_node_ptr : Address;
prev_node_ptr : Address;
@@ -156,8 +156,8 @@ package body Back_End is
(gnat_root => Int (Cunit (Main_Unit)),
max_gnat_node => Int (Last_Node_Id - First_Node_Id + 1),
number_name => Name_Entries_Count,
- nodes_ptr => Nodes_Address,
- flags_ptr => Flags_Address,
+ node_offsets_ptr => Node_Offsets_Address,
+ slots_ptr => Slots_Address,
next_node_ptr => Next_Node_Address,
prev_node_ptr => Prev_Node_Address,
@@ -281,6 +281,14 @@ package body Back_End is
elsif Switch_Chars (First .. Last) = "fpreserve-control-flow" then
Opt.Suppress_Control_Flow_Optimizations := True;
+ -- Back end switch -fdiagnostics-format=json tells the frontend to
+ -- output its error and warning messages in the same format GCC
+ -- uses when passed -fdiagnostics-format=json.
+
+ elsif Switch_Chars (First .. Last) = "fdiagnostics-format=json"
+ then
+ Opt.JSON_Output := True;
+
-- Back end switch -fdump-scos, which exists primarily for C, is
-- also accepted for Ada as a synonym of -gnateS.
diff --git a/gcc/ada/back_end.ads b/gcc/ada/back_end.ads
index 05f6e5bc..32a0ea3 100644
--- a/gcc/ada/back_end.ads
+++ b/gcc/ada/back_end.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -70,6 +70,7 @@ package Back_End is
-- Opt.Suppress_Control_Float_Optimizations
-- Opt.Generate_SCO
-- Opt.Generate_SCO_Instance_Table
+ -- Opt.JSON_Output
-- Opt.Stack_Checking_Enabled
-- Opt.No_Stdinc
-- Opt.No_Stdlib
diff --git a/gcc/ada/bcheck.adb b/gcc/ada/bcheck.adb
index 000f73d..804e2fd 100644
--- a/gcc/ada/bcheck.adb
+++ b/gcc/ada/bcheck.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/bcheck.ads b/gcc/ada/bcheck.ads
index 3cd62b6..ee9a3f8 100644
--- a/gcc/ada/bcheck.ads
+++ b/gcc/ada/bcheck.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute 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 97b2764..3df78bf 100644
--- a/gcc/ada/binde.adb
+++ b/gcc/ada/binde.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -2327,7 +2327,7 @@ package body Binde is
-- subsumed by their parent units, but we need to list them for other
-- tools. For now they are listed after other files, rather than right
-- after their parent, since there is no easy link between the
- -- elaboration table and the ALIs table ??? As subunits may appear
+ -- elaboration table and the ALIs table. As subunits may appear
-- repeatedly in the list, if the parent unit appears in the context of
-- several units in the closure, duplicates are suppressed.
@@ -2811,7 +2811,7 @@ package body Binde is
or else Withs.Table (W).Elab_All_Desirable
then
if SCC (U) = SCC (Withed_Unit) then
- Elab_Cycle_Found := True; -- ???
+ Elab_Cycle_Found := True;
-- We could probably give better error messages
-- than Elab_Old here, but for now, to avoid
@@ -2873,10 +2873,10 @@ package body Binde is
end if;
-- If there are no nodes with predecessors, then either we are
- -- done, as indicated by Num_Left being set to zero, or we have
- -- a circularity. In the latter case, diagnose the circularity,
- -- removing it from the graph and continue.
- -- ????But Diagnose_Elaboration_Problem always raises an
+ -- done, as indicated by Num_Left being set to zero, or we have a
+ -- circularity. In the latter case, diagnose the circularity,
+ -- removing it from the graph and
+ -- continue. Diagnose_Elaboration_Problem always raises an
-- exception, so the loop never goes around more than once.
Get_No_Pred : while No_Pred = No_Unit_Id loop
@@ -3086,11 +3086,11 @@ package body Binde is
Outer : loop
-- If there are no nodes with predecessors, then either we are
- -- done, as indicated by Num_Left being set to zero, or we have
- -- a circularity. In the latter case, diagnose the circularity,
+ -- done, as indicated by Num_Left being set to zero, or we have a
+ -- circularity. In the latter case, diagnose the circularity,
-- removing it from the graph and continue.
- -- ????But Diagnose_Elaboration_Problem always raises an
- -- exception, so the loop never goes around more than once.
+ -- Diagnose_Elaboration_Problem always raises an exception, so the
+ -- loop never goes around more than once.
Get_No_Pred : while No_Pred = No_Unit_Id loop
exit Outer when Num_Left < 1;
diff --git a/gcc/ada/binde.ads b/gcc/ada/binde.ads
index c0830c9..9e0bbee 100644
--- a/gcc/ada/binde.ads
+++ b/gcc/ada/binde.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute 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 1169e43..9433a16 100644
--- a/gcc/ada/binderr.adb
+++ b/gcc/ada/binderr.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute 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 4b538fd..a40f805 100644
--- a/gcc/ada/binderr.ads
+++ b/gcc/ada/binderr.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute 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 ed0df1b..0014f6a 100644
--- a/gcc/ada/bindgen.adb
+++ b/gcc/ada/bindgen.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -2388,7 +2388,11 @@ package body Bindgen is
Gnat_Version_String &
""" & ASCII.NUL;");
WBI (" pragma Export (C, GNAT_Version, ""__gnat_version"");");
-
+ WBI ("");
+ WBI (" GNAT_Version_Address : constant System.Address := " &
+ "GNAT_Version'Address;");
+ WBI (" pragma Export (C, GNAT_Version_Address, " &
+ """__gnat_version_address"");");
WBI ("");
Set_String (" Ada_Main_Program_Name : constant String := """);
Get_Name_String (Units.Table (First_Unit_Entry).Uname);
diff --git a/gcc/ada/bindgen.ads b/gcc/ada/bindgen.ads
index c70cd09..926dd5e 100644
--- a/gcc/ada/bindgen.ads
+++ b/gcc/ada/bindgen.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute 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 a2a1de0..dcbb8d8 100644
--- a/gcc/ada/bindo-augmentors.adb
+++ b/gcc/ada/bindo-augmentors.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2019-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2019-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute 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.ads b/gcc/ada/bindo-augmentors.ads
index a8fa158..9a6f01d 100644
--- a/gcc/ada/bindo-augmentors.ads
+++ b/gcc/ada/bindo-augmentors.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2019-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2019-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute 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-builders.adb b/gcc/ada/bindo-builders.adb
index 66801f4..0017d4b 100644
--- a/gcc/ada/bindo-builders.adb
+++ b/gcc/ada/bindo-builders.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2019-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2019-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute 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-builders.ads b/gcc/ada/bindo-builders.ads
index e3cbe63..c306d60 100644
--- a/gcc/ada/bindo-builders.ads
+++ b/gcc/ada/bindo-builders.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2019-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2019-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute 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 ed1abf8..e5ee55d 100644
--- a/gcc/ada/bindo-diagnostics.adb
+++ b/gcc/ada/bindo-diagnostics.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2019-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2019-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute 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.ads b/gcc/ada/bindo-diagnostics.ads
index 24f4f52..5be5f02 100644
--- a/gcc/ada/bindo-diagnostics.ads
+++ b/gcc/ada/bindo-diagnostics.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2019-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2019-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute 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-elaborators.adb b/gcc/ada/bindo-elaborators.adb
index f36b915..a5090e6 100644
--- a/gcc/ada/bindo-elaborators.adb
+++ b/gcc/ada/bindo-elaborators.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2019-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2019-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute 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-elaborators.ads b/gcc/ada/bindo-elaborators.ads
index 7cbd9c9..8fdeda8 100644
--- a/gcc/ada/bindo-elaborators.ads
+++ b/gcc/ada/bindo-elaborators.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2019-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2019-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute 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 3b2b753..011b0f4 100644
--- a/gcc/ada/bindo-graphs.adb
+++ b/gcc/ada/bindo-graphs.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2019-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2019-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute 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.ads b/gcc/ada/bindo-graphs.ads
index e284369..1f28818 100644
--- a/gcc/ada/bindo-graphs.ads
+++ b/gcc/ada/bindo-graphs.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2019-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2019-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute 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.adb b/gcc/ada/bindo-units.adb
index 80eef3d..72f2866 100644
--- a/gcc/ada/bindo-units.adb
+++ b/gcc/ada/bindo-units.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2019-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2019-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute 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 ce29606..bb8c1ed 100644
--- a/gcc/ada/bindo-units.ads
+++ b/gcc/ada/bindo-units.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2019-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2019-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute 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 c4b2a0f..1a6188a 100644
--- a/gcc/ada/bindo-validators.adb
+++ b/gcc/ada/bindo-validators.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2019-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2019-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute 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 1325f43..e1230c9 100644
--- a/gcc/ada/bindo-validators.ads
+++ b/gcc/ada/bindo-validators.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2019-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2019-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute 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 926fb82..b124a42 100644
--- a/gcc/ada/bindo-writers.adb
+++ b/gcc/ada/bindo-writers.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2019-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2019-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -1689,8 +1689,8 @@ package body Bindo.Writers is
if Contains (Set, Source) then
return;
- -- Nothing to do for internal source files unless switch -Ra (???) is
- -- in effect.
+ -- Nothing to do for internal source files unless switch -Ra is in
+ -- effect.
elsif Is_Internal_File_Name (Source)
and then not List_Closure_All
diff --git a/gcc/ada/bindo-writers.ads b/gcc/ada/bindo-writers.ads
index cf47ffd..edadd6c 100644
--- a/gcc/ada/bindo-writers.ads
+++ b/gcc/ada/bindo-writers.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2019-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2019-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute 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 0098b2d..df0884a 100644
--- a/gcc/ada/bindo.adb
+++ b/gcc/ada/bindo.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2019-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2019-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute 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 adecc83..07cbba8 100644
--- a/gcc/ada/bindo.ads
+++ b/gcc/ada/bindo.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2019-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2019-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute 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 6fd55ee..664da34 100644
--- a/gcc/ada/bindusg.adb
+++ b/gcc/ada/bindusg.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute 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.ads b/gcc/ada/bindusg.ads
index edc6888..985e068 100644
--- a/gcc/ada/bindusg.ads
+++ b/gcc/ada/bindusg.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute 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 8cb5a07..dfbcc3c 100644
--- a/gcc/ada/butil.adb
+++ b/gcc/ada/butil.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute 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 2df4671..fed8a7a 100644
--- a/gcc/ada/butil.ads
+++ b/gcc/ada/butil.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute 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 01cabe7..4c01479 100644
--- a/gcc/ada/cal.c
+++ b/gcc/ada/cal.c
@@ -6,7 +6,7 @@
* *
* C Implementation File *
* *
- * Copyright (C) 1992-2020, Free Software Foundation, Inc. *
+ * Copyright (C) 1992-2021, Free Software Foundation, Inc. *
* *
* GNAT is free software; you can redistribute 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 db551d7..8abf11a 100644
--- a/gcc/ada/casing.adb
+++ b/gcc/ada/casing.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute 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 fe0e2f2..277b19f 100644
--- a/gcc/ada/casing.ads
+++ b/gcc/ada/casing.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute 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
deleted file mode 100644
index 8ce6b69..0000000
--- a/gcc/ada/ceinfo.adb
+++ /dev/null
@@ -1,226 +0,0 @@
-------------------------------------------------------------------------------
--- --
--- GNAT SYSTEM UTILITIES --
--- --
--- C E I N F O --
--- --
--- B o d y --
--- --
--- 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- --
--- 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. --
--- --
-------------------------------------------------------------------------------
-
--- Check consistency of einfo.ads and einfo.adb. Checks that field name usage
--- is consistent, including comments mentioning fields.
-
--- Note that this is used both as a standalone program, and as a procedure
--- called by XEinfo. This raises an unhandled exception if it finds any
--- errors; we don't attempt any sophisticated error recovery.
-
-with Ada.Strings.Unbounded; use Ada.Strings.Unbounded;
-with Ada.Strings.Unbounded.Text_IO; use Ada.Strings.Unbounded.Text_IO;
-with Ada.Text_IO; use Ada.Text_IO;
-
-with GNAT.Spitbol; use GNAT.Spitbol;
-with GNAT.Spitbol.Patterns; use GNAT.Spitbol.Patterns;
-with GNAT.Spitbol.Table_VString;
-
-procedure CEinfo is
-
- package TV renames GNAT.Spitbol.Table_VString;
- use TV;
-
- Infil : File_Type;
- Lineno : Natural := 0;
-
- Err : exception;
- -- Raised on error
-
- Fieldnm : VString;
- Accessfunc : VString;
- Line : VString;
-
- Fields : GNAT.Spitbol.Table_VString.Table (500);
- -- Maps field names to underlying field access name
-
- UC : constant Pattern := Any ("ABCDEFGHIJKLMNOPQRSTUVWXYZ");
-
- Fnam : constant Pattern := (UC & Break (' ')) * Fieldnm;
-
- Field_Def : constant Pattern :=
- "-- " & Fnam & " (" & Break (')') * Accessfunc;
-
- Field_Ref : constant Pattern :=
- " -- " & Fnam & Break ('(') & Len (1) &
- Break (')') * Accessfunc;
-
- Field_Com : constant Pattern := " -- " & Fnam & Span (' ') &
- (Break (' ') or Rest) * Accessfunc;
-
- Func_Hedr : constant Pattern := " function " & Fnam;
-
- Func_Retn : constant Pattern := " return " & Break (' ') * Accessfunc;
-
- Proc_Hedr : constant Pattern := " procedure " & Fnam;
-
- Proc_Setf : constant Pattern := " Set_" & Break (' ') * Accessfunc;
-
- procedure Next_Line;
- -- Read next line trimmed from Infil into Line and bump Lineno
-
- procedure Next_Line is
- begin
- Line := Get_Line (Infil);
- Trim (Line);
- Lineno := Lineno + 1;
- end Next_Line;
-
--- Start of processing for CEinfo
-
-begin
- Anchored_Mode := True;
- New_Line;
- Open (Infil, In_File, "einfo.ads");
-
- Put_Line ("Acquiring field names from spec");
-
- loop
- Next_Line;
-
- -- Old format of einfo.ads
-
- exit when Match (Line, " -- Access Kinds --");
-
- -- New format of einfo.ads
-
- exit when Match (Line, "-- Access Kinds --");
-
- if Match (Line, Field_Def) then
- Set (Fields, Fieldnm, Accessfunc);
- end if;
- end loop;
-
- Put_Line ("Checking consistent references in spec");
-
- loop
- Next_Line;
- exit when Match (Line, " -- Description of Defined");
- end loop;
-
- loop
- Next_Line;
- exit when Match (Line, " -- Component_Alignment Control");
-
- if Match (Line, Field_Ref) then
- if Accessfunc /= "synth"
- and then
- Accessfunc /= "special"
- and then
- Accessfunc /= Get (Fields, Fieldnm)
- then
- if Present (Fields, Fieldnm) then
- Put_Line ("*** field name incorrect at line " & Lineno);
- Put_Line (" found field " & Accessfunc);
- Put_Line (" expecting field " & Get (Fields, Fieldnm));
-
- else
- Put_Line
- ("*** unknown field name " & Fieldnm & " at line " & Lineno);
- end if;
-
- raise Err;
- end if;
- end if;
- end loop;
-
- Close (Infil);
- Open (Infil, In_File, "einfo.adb");
- Lineno := 0;
-
- Put_Line ("Check listing of fields in body");
-
- loop
- Next_Line;
- exit when Match (Line, " -- Attribute Access Functions --");
-
- if Match (Line, Field_Com)
- and then Fieldnm /= "(unused)"
- and then Accessfunc /= Get (Fields, Fieldnm)
- then
- if Present (Fields, Fieldnm) then
- Put_Line ("*** field name incorrect at line " & Lineno);
- Put_Line (" found field " & Accessfunc);
- Put_Line (" expecting field " & Get (Fields, Fieldnm));
-
- else
- Put_Line
- ("*** unknown field name " & Fieldnm & " at line " & Lineno);
- end if;
-
- raise Err;
- end if;
- end loop;
-
- Put_Line ("Check references in access routines in body");
-
- loop
- Next_Line;
- exit when Match (Line, " -- Classification Functions --");
-
- if Match (Line, Func_Hedr) then
- null;
-
- elsif Match (Line, Func_Retn)
- and then Accessfunc /= Get (Fields, Fieldnm)
- and then Fieldnm /= "Mechanism"
- then
- Put_Line ("*** incorrect field at line " & Lineno);
- Put_Line (" found field " & Accessfunc);
- Put_Line (" expecting field " & Get (Fields, Fieldnm));
- raise Err;
- end if;
- end loop;
-
- Put_Line ("Check references in set routines in body");
-
- loop
- Next_Line;
- exit when Match (Line, " -- Attribute Set Procedures");
- end loop;
-
- loop
- Next_Line;
- exit when Match (Line, " ------------");
-
- if Match (Line, Proc_Hedr) then
- null;
-
- elsif Match (Line, Proc_Setf)
- and then Accessfunc /= Get (Fields, Fieldnm)
- and then Fieldnm /= "Mechanism"
- then
- Put_Line ("*** incorrect field at line " & Lineno);
- Put_Line (" found field " & Accessfunc);
- Put_Line (" expecting field " & Get (Fields, Fieldnm));
- raise Err;
- end if;
- end loop;
-
- Close (Infil);
-
- Put_Line ("All tests completed successfully, no errors detected");
-
-end CEinfo;
diff --git a/gcc/ada/checks.adb b/gcc/ada/checks.adb
index 61e41dd..cebeac5 100644
--- a/gcc/ada/checks.adb
+++ b/gcc/ada/checks.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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,46 +23,50 @@
-- --
------------------------------------------------------------------------------
-with Atree; use Atree;
-with Casing; use Casing;
-with Debug; use Debug;
-with Einfo; use Einfo;
-with Elists; use Elists;
-with Eval_Fat; use Eval_Fat;
-with Exp_Ch11; use Exp_Ch11;
-with Exp_Ch4; use Exp_Ch4;
-with Exp_Pakd; use Exp_Pakd;
-with Exp_Util; use Exp_Util;
-with Expander; use Expander;
-with Freeze; use Freeze;
-with Lib; use Lib;
-with Nlists; use Nlists;
-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;
-with Sem_Ch3; use Sem_Ch3;
-with Sem_Ch8; use Sem_Ch8;
-with Sem_Disp; use Sem_Disp;
-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 Sem_Warn; use Sem_Warn;
-with Sinfo; use Sinfo;
-with Sinput; use Sinput;
-with Snames; use Snames;
-with Sprint; use Sprint;
-with Stand; use Stand;
-with Stringt; use Stringt;
-with Targparm; use Targparm;
-with Tbuild; use Tbuild;
-with Ttypes; use Ttypes;
-with Validsw; use Validsw;
+with Atree; use Atree;
+with Debug; use Debug;
+with Einfo; use Einfo;
+with Einfo.Entities; use Einfo.Entities;
+with Einfo.Utils; use Einfo.Utils;
+with Elists; use Elists;
+with Eval_Fat; use Eval_Fat;
+with Exp_Ch11; use Exp_Ch11;
+with Exp_Ch4; use Exp_Ch4;
+with Exp_Pakd; use Exp_Pakd;
+with Exp_Util; use Exp_Util;
+with Expander; use Expander;
+with Freeze; use Freeze;
+with Lib; use Lib;
+with Nlists; use Nlists;
+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;
+with Sem_Ch3; use Sem_Ch3;
+with Sem_Ch8; use Sem_Ch8;
+with Sem_Cat; use Sem_Cat;
+with Sem_Disp; use Sem_Disp;
+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 Sem_Warn; use Sem_Warn;
+with Sinfo; use Sinfo;
+with Sinfo.Nodes; use Sinfo.Nodes;
+with Sinfo.Utils; use Sinfo.Utils;
+with Sinput; use Sinput;
+with Snames; use Snames;
+with Sprint; use Sprint;
+with Stand; use Stand;
+with Stringt; use Stringt;
+with Targparm; use Targparm;
+with Tbuild; use Tbuild;
+with Ttypes; use Ttypes;
+with Validsw; use Validsw;
package body Checks is
@@ -81,7 +85,7 @@ package body Checks is
-- such as Apply_Scalar_Range_Check that do not insert any code can be
-- safely called even when the Expander is inactive (but Errors_Detected
-- is 0). The benefit of executing this code when expansion is off, is
- -- the ability to emit constraint error warning for static expressions
+ -- the ability to emit constraint error warnings for static expressions
-- even when we are not generating code.
-- The above is modified in gnatprove mode to ensure that proper check
@@ -376,8 +380,12 @@ package body Checks is
function Accessibility_Checks_Suppressed (E : Entity_Id) return Boolean is
begin
- if Present (E) and then Checks_May_Be_Suppressed (E) then
+ if No_Dynamic_Accessibility_Checks_Enabled (E) then
+ return True;
+
+ elsif Present (E) and then Checks_May_Be_Suppressed (E) then
return Is_Check_Suppressed (E, Accessibility_Check);
+
else
return Scope_Suppress.Suppress (Accessibility_Check);
end if;
@@ -500,9 +508,9 @@ package body Checks is
not Range_Checks_Suppressed (Suppress_Typ);
begin
- -- For now we just return if Checks_On is false, however this should be
+ -- For now we just return if Checks_On is false, however this could be
-- enhanced to check for an always True value in the condition and to
- -- generate a compilation warning???
+ -- generate a compilation warning.
if not Checks_On then
return;
@@ -552,9 +560,7 @@ package body Checks is
if Tagged_Type_Expansion
and then Present (Etype (P))
- and then RTU_Loaded (Ada_Tags)
- and then RTE_Available (RE_Offset_To_Top_Ptr)
- and then Etype (P) = RTE (RE_Offset_To_Top_Ptr)
+ and then Is_RTE (Etype (P), RE_Offset_To_Top_Ptr)
then
return;
end if;
@@ -581,6 +587,11 @@ package body Checks is
Type_Level : Node_Id;
begin
+ -- Verify we haven't tried to add a dynamic accessibility check when we
+ -- shouldn't.
+
+ pragma Assert (not No_Dynamic_Accessibility_Checks_Enabled (N));
+
if Ada_Version >= Ada_2012
and then not Present (Param_Ent)
and then Is_Entity_Name (N)
@@ -2304,6 +2315,11 @@ package body Checks is
is
Loc : constant Source_Ptr := Sloc (Call);
+ function Parameter_Passing_Mechanism_Specified
+ (Typ : Entity_Id)
+ return Boolean;
+ -- Returns True if parameter-passing mechanism is specified for type Typ
+
function May_Cause_Aliasing
(Formal_1 : Entity_Id;
Formal_2 : Entity_Id) return Boolean;
@@ -2330,6 +2346,19 @@ package body Checks is
-- Check contains all and-ed simple tests generated so far or remains
-- unchanged in the case of detailed exception messaged.
+ -------------------------------------------
+ -- Parameter_Passing_Mechanism_Specified --
+ -------------------------------------------
+
+ function Parameter_Passing_Mechanism_Specified
+ (Typ : Entity_Id)
+ return Boolean
+ is
+ begin
+ return Is_Elementary_Type (Typ)
+ or else Is_By_Reference_Type (Typ);
+ end Parameter_Passing_Mechanism_Specified;
+
------------------------
-- May_Cause_Aliasing --
------------------------
@@ -2397,9 +2426,8 @@ package body Checks is
Formal_2 : Entity_Id;
Check : in out Node_Id)
is
- Cond : Node_Id;
- ID_Casing : constant Casing_Type :=
- Identifier_Casing (Source_Index (Current_Sem_Unit));
+ Cond : Node_Id;
+ Formal_Name : Bounded_String;
begin
-- Generate:
@@ -2431,15 +2459,17 @@ package body Checks is
Store_String_Chars ("aliased parameters, actuals for """);
- Get_Name_String (Chars (Formal_1));
- Set_Casing (ID_Casing);
- Store_String_Chars (Name_Buffer (1 .. Name_Len));
+ Append (Formal_Name, Chars (Formal_1));
+ Adjust_Name_Case (Formal_Name, Sloc (Formal_1));
+ Store_String_Chars (To_String (Formal_Name));
Store_String_Chars (""" and """);
- Get_Name_String (Chars (Formal_2));
- Set_Casing (ID_Casing);
- Store_String_Chars (Name_Buffer (1 .. Name_Len));
+ Formal_Name.Length := 0;
+
+ Append (Formal_Name, Chars (Formal_2));
+ Adjust_Name_Case (Formal_Name, Sloc (Formal_2));
+ Store_String_Chars (To_String (Formal_Name));
Store_String_Chars (""" overlap");
@@ -2487,47 +2517,38 @@ package body Checks is
while Present (Actual_1) and then Present (Formal_1) loop
Orig_Act_1 := Original_Actual (Actual_1);
- -- Ensure that the actual is an object that is not passed by value.
- -- Elementary types are always passed by value, therefore actuals of
- -- such types cannot lead to aliasing. An aggregate is an object in
- -- Ada 2012, but an actual that is an aggregate cannot overlap with
- -- another actual. A type that is By_Reference (such as an array of
- -- controlled types) is not subject to the check because any update
- -- will be done in place and a subsequent read will always see the
- -- correct value, see RM 6.2 (12/3).
-
- if Nkind (Orig_Act_1) = N_Aggregate
- or else (Nkind (Orig_Act_1) = N_Qualified_Expression
- and then Nkind (Expression (Orig_Act_1)) = N_Aggregate)
- then
- null;
-
- elsif Is_Object_Reference (Orig_Act_1)
- and then not Is_Elementary_Type (Etype (Orig_Act_1))
- and then not Is_By_Reference_Type (Etype (Orig_Act_1))
- then
+ if Is_Name_Reference (Orig_Act_1) then
Actual_2 := Next_Actual (Actual_1);
Formal_2 := Next_Formal (Formal_1);
while Present (Actual_2) and then Present (Formal_2) loop
Orig_Act_2 := Original_Actual (Actual_2);
- -- The other actual we are testing against must also denote
- -- a non pass-by-value object. Generate the check only when
- -- the mode of the two formals may lead to aliasing.
+ -- Generate the check only when the mode of the two formals may
+ -- lead to aliasing.
- if Is_Object_Reference (Orig_Act_2)
- and then not Is_Elementary_Type (Etype (Orig_Act_2))
+ if Is_Name_Reference (Orig_Act_2)
and then May_Cause_Aliasing (Formal_1, Formal_2)
then
- Remove_Side_Effects (Actual_1);
- Remove_Side_Effects (Actual_2);
-
- Overlap_Check
- (Actual_1 => Actual_1,
- Actual_2 => Actual_2,
- Formal_1 => Formal_1,
- Formal_2 => Formal_2,
- Check => Check);
+
+ -- The aliasing check only applies when some of the formals
+ -- have their passing mechanism unspecified; RM 6.2 (12/3).
+
+ if Parameter_Passing_Mechanism_Specified (Etype (Orig_Act_1))
+ and then
+ Parameter_Passing_Mechanism_Specified (Etype (Orig_Act_2))
+ then
+ null;
+ else
+ Remove_Side_Effects (Actual_1);
+ Remove_Side_Effects (Actual_2);
+
+ Overlap_Check
+ (Actual_1 => Actual_1,
+ Actual_2 => Actual_2,
+ Formal_1 => Formal_1,
+ Formal_2 => Formal_2,
+ Check => Check);
+ end if;
end if;
Next_Actual (Actual_2);
@@ -2702,6 +2723,10 @@ package body Checks is
Subp_Spec := Parent (Subp);
+ if No (Subp_Spec) then
+ return;
+ end if;
+
if Nkind (Subp_Spec) = N_Defining_Program_Unit_Name then
Subp_Spec := Parent (Subp_Spec);
end if;
@@ -3299,13 +3324,6 @@ package body Checks is
Bad_Value (Warn => SPARK_Mode = On);
- -- In GNATprove mode, we enable the range check so that
- -- GNATprove will issue a message if it cannot be proved.
-
- if GNATprove_Mode then
- Enable_Range_Check (Expr);
- end if;
-
return;
end if;
@@ -3461,9 +3479,6 @@ package body Checks is
end if;
end if;
- -- If the item is a conditional raise of constraint error, then have
- -- a look at what check is being performed and ???
-
if Nkind (R_Cno) = N_Raise_Constraint_Error
and then Present (Condition (R_Cno))
then
@@ -3575,6 +3590,116 @@ package body Checks is
-- full view might have discriminants with defaults, so we need the
-- full view here to retrieve the constraints.
+ procedure Make_Discriminant_Constraint_Check
+ (Target_Type : Entity_Id;
+ Expr_Type : Entity_Id);
+ -- Generate a discriminant check based on the target type and expression
+ -- type for Expr.
+
+ ----------------------------------------
+ -- Make_Discriminant_Constraint_Check --
+ ----------------------------------------
+
+ procedure Make_Discriminant_Constraint_Check
+ (Target_Type : Entity_Id;
+ Expr_Type : Entity_Id)
+ is
+ Loc : constant Source_Ptr := Sloc (N);
+ Cond : Node_Id;
+ Constraint : Elmt_Id;
+ Discr_Value : Node_Id;
+ Discr : Entity_Id;
+
+ New_Constraints : constant Elist_Id := New_Elmt_List;
+ Old_Constraints : constant Elist_Id :=
+ Discriminant_Constraint (Expr_Type);
+
+ begin
+ -- Build an actual discriminant constraint list using the stored
+ -- constraint, to verify that the expression of the parent type
+ -- satisfies the constraints imposed by the (unconstrained) derived
+ -- type. This applies to value conversions, not to view conversions
+ -- of tagged types.
+
+ Constraint := First_Elmt (Stored_Constraint (Target_Type));
+ while Present (Constraint) loop
+ Discr_Value := Node (Constraint);
+
+ if Is_Entity_Name (Discr_Value)
+ and then Ekind (Entity (Discr_Value)) = E_Discriminant
+ then
+ Discr := Corresponding_Discriminant (Entity (Discr_Value));
+
+ if Present (Discr)
+ and then Scope (Discr) = Base_Type (Expr_Type)
+ then
+ -- Parent is constrained by new discriminant. Obtain
+ -- Value of original discriminant in expression. If the
+ -- new discriminant has been used to constrain more than
+ -- one of the stored discriminants, this will provide the
+ -- required consistency check.
+
+ Append_Elmt
+ (Make_Selected_Component (Loc,
+ Prefix =>
+ Duplicate_Subexpr_No_Checks
+ (Expr, Name_Req => True),
+ Selector_Name =>
+ Make_Identifier (Loc, Chars (Discr))),
+ New_Constraints);
+
+ else
+ -- Discriminant of more remote ancestor ???
+
+ return;
+ end if;
+
+ -- Derived type definition has an explicit value for this
+ -- stored discriminant.
+
+ else
+ Append_Elmt
+ (Duplicate_Subexpr_No_Checks (Discr_Value),
+ New_Constraints);
+ end if;
+
+ Next_Elmt (Constraint);
+ end loop;
+
+ -- Use the unconstrained expression type to retrieve the
+ -- discriminants of the parent, and apply momentarily the
+ -- discriminant constraint synthesized above.
+
+ -- Note: We use Expr_Type instead of Target_Type since the number of
+ -- actual discriminants may be different due to the presence of
+ -- stored discriminants and cause Build_Discriminant_Checks to fail.
+
+ Set_Discriminant_Constraint (Expr_Type, New_Constraints);
+ Cond := Build_Discriminant_Checks (Expr, Expr_Type);
+ Set_Discriminant_Constraint (Expr_Type, Old_Constraints);
+
+ -- Conversion between access types requires that we check for null
+ -- before checking discriminants.
+
+ if Is_Access_Type (Etype (Expr)) then
+ Cond := Make_And_Then (Loc,
+ Left_Opnd =>
+ Make_Op_Ne (Loc,
+ Left_Opnd =>
+ Duplicate_Subexpr_No_Checks
+ (Expr, Name_Req => True),
+ Right_Opnd => Make_Null (Loc)),
+ Right_Opnd => Cond);
+ end if;
+
+ Insert_Action (N,
+ Make_Raise_Constraint_Error (Loc,
+ Condition => Cond,
+ Reason => CE_Discriminant_Check_Failed));
+ end Make_Discriminant_Constraint_Check;
+
+ -- Start of processing for Apply_Type_Conversion_Checks
+
begin
if Inside_A_Generic then
return;
@@ -3704,91 +3829,42 @@ package body Checks is
end if;
end;
- elsif Comes_From_Source (N)
- and then not Discriminant_Checks_Suppressed (Target_Type)
- and then Is_Record_Type (Target_Type)
- and then Is_Derived_Type (Target_Type)
- and then not Is_Tagged_Type (Target_Type)
- and then not Is_Constrained (Target_Type)
- and then Present (Stored_Constraint (Target_Type))
- then
- -- An unconstrained derived type may have inherited discriminant.
- -- Build an actual discriminant constraint list using the stored
- -- constraint, to verify that the expression of the parent type
- -- satisfies the constraints imposed by the (unconstrained) derived
- -- type. This applies to value conversions, not to view conversions
- -- of tagged types.
-
- declare
- Loc : constant Source_Ptr := Sloc (N);
- Cond : Node_Id;
- Constraint : Elmt_Id;
- Discr_Value : Node_Id;
- Discr : Entity_Id;
-
- New_Constraints : constant Elist_Id := New_Elmt_List;
- Old_Constraints : constant Elist_Id :=
- Discriminant_Constraint (Expr_Type);
-
- begin
- Constraint := First_Elmt (Stored_Constraint (Target_Type));
- while Present (Constraint) loop
- Discr_Value := Node (Constraint);
-
- if Is_Entity_Name (Discr_Value)
- and then Ekind (Entity (Discr_Value)) = E_Discriminant
- then
- Discr := Corresponding_Discriminant (Entity (Discr_Value));
-
- if Present (Discr)
- and then Scope (Discr) = Base_Type (Expr_Type)
- then
- -- Parent is constrained by new discriminant. Obtain
- -- Value of original discriminant in expression. If the
- -- new discriminant has been used to constrain more than
- -- one of the stored discriminants, this will provide the
- -- required consistency check.
-
- Append_Elmt
- (Make_Selected_Component (Loc,
- Prefix =>
- Duplicate_Subexpr_No_Checks
- (Expr, Name_Req => True),
- Selector_Name =>
- Make_Identifier (Loc, Chars (Discr))),
- New_Constraints);
+ -- Generate discriminant constraint checks for access types on the
+ -- designated target type's stored constraints.
- else
- -- Discriminant of more remote ancestor ???
+ -- Do we need to generate subtype predicate checks here as well ???
- return;
- end if;
+ elsif Comes_From_Source (N)
+ and then Ekind (Target_Type) = E_General_Access_Type
- -- Derived type definition has an explicit value for this
- -- stored discriminant.
+ -- Check that both of the designated types have known discriminants,
+ -- and that such checks on the target type are not suppressed.
- else
- Append_Elmt
- (Duplicate_Subexpr_No_Checks (Discr_Value),
- New_Constraints);
- end if;
+ and then Has_Discriminants (Directly_Designated_Type (Target_Type))
+ and then Has_Discriminants (Directly_Designated_Type (Expr_Type))
+ and then not Discriminant_Checks_Suppressed
+ (Directly_Designated_Type (Target_Type))
- Next_Elmt (Constraint);
- end loop;
+ -- Verify the designated type of the target has stored constraints
- -- Use the unconstrained expression type to retrieve the
- -- discriminants of the parent, and apply momentarily the
- -- discriminant constraint synthesized above.
+ and then Present
+ (Stored_Constraint (Directly_Designated_Type (Target_Type)))
+ then
+ Make_Discriminant_Constraint_Check
+ (Target_Type => Directly_Designated_Type (Target_Type),
+ Expr_Type => Directly_Designated_Type (Expr_Type));
- Set_Discriminant_Constraint (Expr_Type, New_Constraints);
- Cond := Build_Discriminant_Checks (Expr, Expr_Type);
- Set_Discriminant_Constraint (Expr_Type, Old_Constraints);
+ -- Create discriminant checks for the Target_Type's stored constraints
- Insert_Action (N,
- Make_Raise_Constraint_Error (Loc,
- Condition => Cond,
- Reason => CE_Discriminant_Check_Failed));
- end;
+ elsif Comes_From_Source (N)
+ and then not Discriminant_Checks_Suppressed (Target_Type)
+ and then Is_Record_Type (Target_Type)
+ and then Is_Derived_Type (Target_Type)
+ and then not Is_Tagged_Type (Target_Type)
+ and then not Is_Constrained (Target_Type)
+ and then Present (Stored_Constraint (Target_Type))
+ then
+ Make_Discriminant_Constraint_Check (Target_Type, Expr_Type);
-- For arrays, checks are set now, but conversions are applied during
-- expansion, to take into accounts changes of representation. The
@@ -5350,8 +5426,7 @@ package body Checks is
OK1 := True;
end;
- -- No special handling for other attributes
- -- Probably more opportunities exist here???
+ -- No special handling for other attributes for now
when others =>
OK1 := False;
@@ -5547,6 +5622,10 @@ package body Checks is
-- If type is not defined, we can't determine its range
+ pragma Warnings (Off, "condition can only be True if invalid");
+ -- Otherwise the compiler warns on the check of Float_Rep below, because
+ -- there is only one value (see types.ads).
+
if No (Typ)
-- We don't deal with anything except IEEE floating-point types
@@ -5560,6 +5639,7 @@ package body Checks is
or else Error_Posted (N) or else Error_Posted (Typ)
then
+ pragma Warnings (On, "condition can only be True if invalid");
OK := False;
return;
end if;
@@ -7745,10 +7825,8 @@ package body Checks is
New_Occurrence_Of (Target_Base_Type, Loc),
Constant_Present => True,
Expression =>
- Make_Unchecked_Type_Conversion (Loc,
- Subtype_Mark =>
- New_Occurrence_Of (Target_Base_Type, Loc),
- Expression => Duplicate_Subexpr (N))),
+ Unchecked_Convert_To
+ (Target_Base_Type, Duplicate_Subexpr (N))),
Make_Raise_Constraint_Error (Loc,
Condition =>
@@ -7941,7 +8019,7 @@ package body Checks is
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
- -- generate a compilation warning???
+ -- generate a compilation warning.
if not Expander_Active or not Checks_On then
return;
@@ -8099,7 +8177,7 @@ package body Checks is
-- cause our object declaration to remain unanalyzed we must do
-- some manual decoration.
- Set_Ekind (Var_Id, E_Variable);
+ Mutate_Ekind (Var_Id, E_Variable);
Set_Etype (Var_Id, Typ);
Insert_Action (Exp,
@@ -8470,22 +8548,6 @@ package body Checks is
return;
end if;
- -- No check needed for the Get_Current_Excep.all.all idiom generated by
- -- the expander within exception handlers, since we know that the value
- -- can never be null.
-
- -- Is this really the right way to do this? Normally we generate such
- -- code in the expander with checks off, and that's how we suppress this
- -- kind of junk check ???
-
- if Nkind (N) = N_Function_Call
- and then Nkind (Name (N)) = N_Explicit_Dereference
- and then Nkind (Prefix (Name (N))) = N_Identifier
- and then Is_RTE (Entity (Prefix (Name (N))), RE_Get_Current_Excep)
- then
- return;
- end if;
-
-- In GNATprove mode, we do not apply the check
if GNATprove_Mode then
@@ -8573,7 +8635,7 @@ package body Checks is
return;
-- Do not generate an elaboration check if the related subprogram is
- -- not subjected to accessibility checks.
+ -- not subject to elaboration checks.
elsif Elaboration_Checks_Suppressed (Subp_Id) then
return;
@@ -8583,14 +8645,20 @@ package body Checks is
elsif Restriction_Active (No_Elaboration_Code) then
return;
+ -- If pragma Pure or Preelaborate applies, then these elaboration checks
+ -- cannot fail, so do not generate them.
+
+ elsif In_Preelaborated_Unit then
+ return;
+
-- Do not generate an elaboration check if exceptions cannot be used,
-- caught, or propagated.
elsif not Exceptions_OK then
return;
- -- Do not consider subprograms which act as compilation units, because
- -- they cannot be the target of a dispatching call.
+ -- Do not consider subprograms that are compilation units, because they
+ -- cannot be the target of a dispatching call.
elsif Nkind (Context) = N_Compilation_Unit then
return;
@@ -8620,10 +8688,10 @@ package body Checks is
elsif Analyzed (Subp_Body) then
return;
- -- Do not consider primitives which occur within an instance that acts
- -- as a compilation unit. Such an instance defines its spec and body out
- -- of order (body is first) within the tree, which causes the reference
- -- to the elaboration flag to appear as an undefined symbol.
+ -- Do not consider primitives that occur within an instance that is a
+ -- compilation unit. Such an instance defines its spec and body out of
+ -- order (body is first) within the tree, which causes the reference to
+ -- the elaboration flag to appear as an undefined symbol.
elsif Within_Compilation_Unit_Instance (Subp_Id) then
return;
@@ -9256,7 +9324,6 @@ package body Checks is
Append_To (New_Alts,
Make_Case_Expression_Alternative (Sloc (Alt),
- Actions => No_List,
Discrete_Choices => Discrete_Choices (Alt),
Expression => New_Exp));
@@ -9697,9 +9764,6 @@ package body Checks is
when N_Attribute_Reference =>
Set_Do_Overflow_Check (N, False);
- when N_Function_Call =>
- Set_Do_Tag_Check (N, False);
-
when N_Op =>
Set_Do_Overflow_Check (N, False);
@@ -9735,7 +9799,6 @@ package body Checks is
when N_Type_Conversion =>
Set_Do_Length_Check (N, False);
- Set_Do_Tag_Check (N, False);
Set_Do_Overflow_Check (N, False);
when others =>
@@ -9776,8 +9839,10 @@ package body Checks is
-- Adds the action given to Ret_Result if N is non-Empty
function Get_E_Length (E : Entity_Id; Indx : Nat) return Node_Id;
+ -- Return E'Length (Indx)
+
function Get_N_Length (N : Node_Id; Indx : Nat) return Node_Id;
- -- Comments required ???
+ -- Return N'Length (Indx)
function Same_Bounds (L : Node_Id; R : Node_Id) return Boolean;
-- True for equal literals and for nodes that denote the same constant
@@ -9813,8 +9878,10 @@ package body Checks is
begin
if Present (N) then
- -- For now, ignore attempt to place more than two checks ???
- -- This is really worrisome, are we really discarding checks ???
+ -- We do not support inserting more than 2 checks on the same
+ -- node. If this happens it means we have already added an
+ -- unconditional raise, so we can skip the other checks safely
+ -- since N will always raise an exception.
if Num_Checks = 2 then
return;
@@ -9867,8 +9934,7 @@ package body Checks is
declare
Indx_Type : Node_Id;
- Lo : Node_Id;
- Hi : Node_Id;
+ Bounds : Range_Nodes;
Do_Expand : Boolean := False;
begin
@@ -9878,37 +9944,38 @@ package body Checks is
Next_Index (Indx_Type);
end loop;
- Get_Index_Bounds (Indx_Type, Lo, Hi);
+ Bounds := Get_Index_Bounds (Indx_Type);
- if Nkind (Lo) = N_Identifier
- and then Ekind (Entity (Lo)) = E_In_Parameter
+ if Nkind (Bounds.First) = N_Identifier
+ and then Ekind (Entity (Bounds.First)) = E_In_Parameter
then
- Lo := Get_Discriminal (E, Lo);
+ Bounds.First := Get_Discriminal (E, Bounds.First);
Do_Expand := True;
end if;
- if Nkind (Hi) = N_Identifier
- and then Ekind (Entity (Hi)) = E_In_Parameter
+ if Nkind (Bounds.Last) = N_Identifier
+ and then Ekind (Entity (Bounds.Last)) = E_In_Parameter
then
- Hi := Get_Discriminal (E, Hi);
+ Bounds.Last := Get_Discriminal (E, Bounds.Last);
Do_Expand := True;
end if;
if Do_Expand then
- if not Is_Entity_Name (Lo) then
- Lo := Duplicate_Subexpr_No_Checks (Lo);
+ if not Is_Entity_Name (Bounds.First) then
+ Bounds.First :=
+ Duplicate_Subexpr_No_Checks (Bounds.First);
end if;
- if not Is_Entity_Name (Hi) then
- Lo := Duplicate_Subexpr_No_Checks (Hi);
+ if not Is_Entity_Name (Bounds.Last) then
+ Bounds.First := Duplicate_Subexpr_No_Checks (Bounds.Last);
end if;
N :=
Make_Op_Add (Loc,
Left_Opnd =>
Make_Op_Subtract (Loc,
- Left_Opnd => Hi,
- Right_Opnd => Lo),
+ Left_Opnd => Bounds.Last,
+ Right_Opnd => Bounds.First),
Right_Opnd => Make_Integer_Literal (Loc, 1));
return N;
@@ -10151,10 +10218,8 @@ package body Checks is
L_Index : Node_Id;
R_Index : Node_Id;
- L_Low : Node_Id;
- L_High : Node_Id;
- R_Low : Node_Id;
- R_High : Node_Id;
+ L_Bounds : Range_Nodes;
+ R_Bounds : Range_Nodes;
L_Length : Uint;
R_Length : Uint;
Ref_Node : Node_Id;
@@ -10186,29 +10251,33 @@ package body Checks is
or else
Nkind (R_Index) = N_Raise_Constraint_Error)
then
- Get_Index_Bounds (L_Index, L_Low, L_High);
- Get_Index_Bounds (R_Index, R_Low, R_High);
+ L_Bounds := Get_Index_Bounds (L_Index);
+ R_Bounds := Get_Index_Bounds (R_Index);
-- Deal with compile time length check. Note that we
-- skip this in the access case, because the access
-- value may be null, so we cannot know statically.
if not Do_Access
- and then Compile_Time_Known_Value (L_Low)
- and then Compile_Time_Known_Value (L_High)
- and then Compile_Time_Known_Value (R_Low)
- and then Compile_Time_Known_Value (R_High)
+ and then Compile_Time_Known_Value (L_Bounds.First)
+ and then Compile_Time_Known_Value (L_Bounds.Last)
+ and then Compile_Time_Known_Value (R_Bounds.First)
+ and then Compile_Time_Known_Value (R_Bounds.Last)
then
- if Expr_Value (L_High) >= Expr_Value (L_Low) then
- L_Length := Expr_Value (L_High) -
- Expr_Value (L_Low) + 1;
+ if Expr_Value (L_Bounds.Last) >=
+ Expr_Value (L_Bounds.First)
+ then
+ L_Length := Expr_Value (L_Bounds.Last) -
+ Expr_Value (L_Bounds.First) + 1;
else
L_Length := UI_From_Int (0);
end if;
- if Expr_Value (R_High) >= Expr_Value (R_Low) then
- R_Length := Expr_Value (R_High) -
- Expr_Value (R_Low) + 1;
+ if Expr_Value (R_Bounds.Last) >=
+ Expr_Value (R_Bounds.First)
+ then
+ R_Length := Expr_Value (R_Bounds.Last) -
+ Expr_Value (R_Bounds.First) + 1;
else
R_Length := UI_From_Int (0);
end if;
@@ -10240,8 +10309,9 @@ package body Checks is
(Etype (L_Index), Etype (R_Index))
and then not
- (Same_Bounds (L_Low, R_Low)
- and then Same_Bounds (L_High, R_High))
+ (Same_Bounds (L_Bounds.First, R_Bounds.First)
+ and then
+ Same_Bounds (L_Bounds.Last, R_Bounds.Last))
then
Evolve_Or_Else
(Cond, Length_E_Cond (Exptyp, T_Typ, Indx));
@@ -10384,7 +10454,10 @@ package body Checks is
begin
if Present (N) then
- -- For now, ignore attempt to place more than 2 checks ???
+ -- We do not support inserting more than 2 checks on the same
+ -- node. If this happens it means we have already added an
+ -- unconditional raise, so we can skip the other checks safely
+ -- since N will always raise an exception.
if Num_Checks = 2 then
return;
@@ -10448,16 +10521,36 @@ package body Checks is
LB := New_Occurrence_Of (Discriminal (Entity (LB)), Loc);
end if;
- Left_Opnd :=
- Make_Op_Lt (Loc,
- Left_Opnd =>
- Convert_To
- (Base_Type (Typ), Duplicate_Subexpr_No_Checks (LB)),
+ -- If the index type has a fixed lower bound, then we require an
+ -- exact match of the range's lower bound against that fixed lower
+ -- bound.
- Right_Opnd =>
- Convert_To
- (Base_Type (Typ),
- Get_E_First_Or_Last (Loc, Typ, 0, Name_First)));
+ if Is_Fixed_Lower_Bound_Index_Subtype (Typ) then
+ Left_Opnd :=
+ Make_Op_Ne (Loc,
+ Left_Opnd =>
+ Convert_To
+ (Base_Type (Typ), Duplicate_Subexpr_No_Checks (LB)),
+
+ Right_Opnd =>
+ Convert_To
+ (Base_Type (Typ),
+ Get_E_First_Or_Last (Loc, Typ, 0, Name_First)));
+
+ -- Otherwise we do the expected less-than comparison
+
+ else
+ Left_Opnd :=
+ Make_Op_Lt (Loc,
+ Left_Opnd =>
+ Convert_To
+ (Base_Type (Typ), Duplicate_Subexpr_No_Checks (LB)),
+
+ Right_Opnd =>
+ Convert_To
+ (Base_Type (Typ),
+ Get_E_First_Or_Last (Loc, Typ, 0, Name_First)));
+ end if;
if Nkind (HB) = N_Identifier
and then Ekind (Entity (HB)) = E_Discriminant
@@ -10614,6 +10707,13 @@ package body Checks is
Get_E_First_Or_Last (Loc, Typ, Indx, Name_Last)));
end Range_N_Cond;
+ function "<" (Left, Right : Node_Id) return Boolean
+ is (if Is_Floating_Point_Type (S_Typ)
+ then Expr_Value_R (Left) < Expr_Value_R (Right)
+ else Expr_Value (Left) < Expr_Value (Right));
+ -- Convenience comparison function of integer or floating point
+ -- values.
+
-- Start of processing for Selected_Range_Checks
begin
@@ -10684,14 +10784,14 @@ 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 (Expr);
- HB : Node_Id := High_Bound (Expr);
- Known_LB : Boolean := False;
- Known_HB : Boolean := False;
+ LB : Node_Id := Low_Bound (Expr);
+ HB : Node_Id := High_Bound (Expr);
+ Known_LB : Boolean := False;
+ Known_HB : Boolean := False;
+ Check_Added : Boolean := False;
- Null_Range : Boolean;
- Out_Of_Range_L : Boolean;
- Out_Of_Range_H : Boolean;
+ Out_Of_Range_L : Boolean := False;
+ Out_Of_Range_H : Boolean := False;
begin
-- Compute what is known at compile time
@@ -10724,61 +10824,62 @@ package body Checks is
end if;
end if;
- -- Check for case where everything is static and we can do the
- -- check at compile time. This is skipped if we have an access
- -- type, since the access value may be null.
-
- -- ??? This code can be improved since you only need to know that
- -- the two respective bounds (LB & T_LB or HB & T_HB) are known at
- -- compile time to emit pertinent messages.
+ -- Check for the simple cases where we can do the check at
+ -- compile time. This is skipped if we have an access type, since
+ -- the access value may be null.
- if Known_T_LB and Known_T_HB and Known_LB and Known_HB
- and not Do_Access
- then
- -- Floating-point case
-
- if Is_Floating_Point_Type (S_Typ) then
- Null_Range := Expr_Value_R (HB) < Expr_Value_R (LB);
- Out_Of_Range_L :=
- (Expr_Value_R (LB) < Expr_Value_R (T_LB))
- or else
- (Expr_Value_R (LB) > Expr_Value_R (T_HB));
-
- Out_Of_Range_H :=
- (Expr_Value_R (HB) > Expr_Value_R (T_HB))
- or else
- (Expr_Value_R (HB) < Expr_Value_R (T_LB));
-
- -- Fixed or discrete type case
-
- else
- Null_Range := Expr_Value (HB) < Expr_Value (LB);
- Out_Of_Range_L :=
- (Expr_Value (LB) < Expr_Value (T_LB))
- or else
- (Expr_Value (LB) > Expr_Value (T_HB));
+ if not Do_Access and then Not_Null_Range (LB, HB) then
+ if Known_LB then
+ if Known_T_LB then
+ Out_Of_Range_L := LB < T_LB;
+ end if;
- Out_Of_Range_H :=
- (Expr_Value (HB) > Expr_Value (T_HB))
- or else
- (Expr_Value (HB) < Expr_Value (T_LB));
- end if;
+ if Known_T_HB and not Out_Of_Range_L then
+ Out_Of_Range_L := T_HB < LB;
+ end if;
- if not Null_Range then
if Out_Of_Range_L then
if No (Warn_Node) then
Add_Check
(Compile_Time_Constraint_Error
(Low_Bound (Expr),
"static value out of range of}??", T_Typ));
+ Check_Added := True;
else
Add_Check
(Compile_Time_Constraint_Error
(Wnode,
"static range out of bounds of}??", T_Typ));
+ Check_Added := True;
end if;
end if;
+ end if;
+
+ -- Flag the case of a fixed-lower-bound index where the static
+ -- bounds are not equal.
+
+ if not Check_Added
+ and then Is_Fixed_Lower_Bound_Index_Subtype (T_Typ)
+ and then Expr_Value (LB) /= Expr_Value (T_LB)
+ then
+ Add_Check
+ (Compile_Time_Constraint_Error
+ ((if Present (Warn_Node)
+ then Warn_Node else Low_Bound (Expr)),
+ "static value does not equal lower bound of}??",
+ T_Typ));
+ Check_Added := True;
+ end if;
+
+ if Known_HB then
+ if Known_T_HB then
+ Out_Of_Range_H := T_HB < HB;
+ end if;
+
+ if Known_T_LB and not Out_Of_Range_H then
+ Out_Of_Range_H := HB < T_LB;
+ end if;
if Out_Of_Range_H then
if No (Warn_Node) then
@@ -10786,17 +10887,29 @@ package body Checks is
(Compile_Time_Constraint_Error
(High_Bound (Expr),
"static value out of range of}??", T_Typ));
+ Check_Added := True;
else
Add_Check
(Compile_Time_Constraint_Error
(Wnode,
"static range out of bounds of}??", T_Typ));
+ Check_Added := True;
end if;
end if;
end if;
+ end if;
- else
+ -- Check for the case where not everything is static
+
+ if not Check_Added
+ and then
+ (Do_Access
+ or else not Known_T_LB
+ or else not Known_LB
+ or else not Known_T_HB
+ or else not Known_HB)
+ then
declare
LB : Node_Id := Low_Bound (Expr);
HB : Node_Id := High_Bound (Expr);
@@ -10863,8 +10976,8 @@ package body Checks is
elsif Is_Scalar_Type (S_Typ) then
-- This somewhat duplicates what Apply_Scalar_Range_Check does,
- -- except the above simply sets a flag in the node and lets
- -- gigi generate the check base on the Etype of the expression.
+ -- except the above simply sets a flag in the node and lets the
+ -- check be generated based on the Etype of the expression.
-- Sometimes, however we want to do a dynamic check against an
-- arbitrary target type, so we do that here.
@@ -10878,56 +10991,24 @@ package body Checks is
-- expression. As usual, skip this for access types
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);
+ if Is_Out_Of_Range (Expr, T_Typ) then
- Out_Of_Range : Boolean;
- Static_Bounds : constant Boolean :=
- Compile_Time_Known_Value (LB)
- and Compile_Time_Known_Value (UB);
+ -- Bounds of the type are static and the literal is out of
+ -- range so output a warning message.
- begin
- -- Following range tests should use Sem_Eval routine ???
-
- if Static_Bounds then
- if Is_Floating_Point_Type (S_Typ) then
- Out_Of_Range :=
- (Expr_Value_R (Expr) < Expr_Value_R (LB))
- or else
- (Expr_Value_R (Expr) > Expr_Value_R (UB));
-
- -- Fixed or discrete type
-
- else
- Out_Of_Range :=
- Expr_Value (Expr) < Expr_Value (LB)
- or else
- Expr_Value (Expr) > Expr_Value (UB);
- end if;
-
- -- Bounds of the type are static and the literal is out of
- -- range so output a warning message.
-
- if Out_Of_Range then
- if No (Warn_Node) then
- Add_Check
- (Compile_Time_Constraint_Error
- (Expr,
- "static value out of range of}??", T_Typ));
-
- else
- Add_Check
- (Compile_Time_Constraint_Error
- (Wnode,
- "static value out of range of}??", T_Typ));
- end if;
- end if;
+ if No (Warn_Node) then
+ Add_Check
+ (Compile_Time_Constraint_Error
+ (Expr, "static value out of range of}??", T_Typ));
else
- Cond := Discrete_Expr_Cond (Expr, T_Typ);
+ Add_Check
+ (Compile_Time_Constraint_Error
+ (Wnode, "static value out of range of}??", T_Typ));
end if;
- end;
+ else
+ Cond := Discrete_Expr_Cond (Expr, T_Typ);
+ end if;
-- Here for the case of a non-static expression, we need a runtime
-- check unless the source type range is guaranteed to be in the
@@ -10942,7 +11023,6 @@ 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 (Expr);
Exptyp := Get_Actual_Subtype (Expr_Actual);
@@ -11036,6 +11116,56 @@ package body Checks is
end;
end if;
+ -- If the context is a qualified_expression where the subtype is
+ -- an unconstrained array subtype with fixed-lower-bound indexes,
+ -- then consistency checks must be done between the lower bounds
+ -- of any such indexes and the corresponding lower bounds of the
+ -- qualified array object.
+
+ elsif Is_Fixed_Lower_Bound_Array_Subtype (T_Typ)
+ and then Nkind (Parent (Expr)) = N_Qualified_Expression
+ and then not Do_Access
+ then
+ declare
+ Ndims : constant Pos := Number_Dimensions (T_Typ);
+
+ Qual_Index : Node_Id;
+ Expr_Index : Node_Id;
+
+ begin
+ Expr_Actual := Get_Referenced_Object (Expr);
+ Exptyp := Get_Actual_Subtype (Expr_Actual);
+
+ Qual_Index := First_Index (T_Typ);
+ Expr_Index := First_Index (Exptyp);
+
+ for Indx in 1 .. Ndims loop
+ if Nkind (Expr_Index) /= N_Raise_Constraint_Error then
+
+ -- If this index of the qualifying array subtype has
+ -- a fixed lower bound, then apply a check that the
+ -- corresponding lower bound of the array expression
+ -- is equal to it.
+
+ if Is_Fixed_Lower_Bound_Index_Subtype (Etype (Qual_Index))
+ then
+ Evolve_Or_Else
+ (Cond,
+ Make_Op_Ne (Loc,
+ Left_Opnd =>
+ Get_E_First_Or_Last
+ (Loc, Exptyp, Indx, Name_First),
+ Right_Opnd =>
+ New_Copy_Tree
+ (Type_Low_Bound (Etype (Qual_Index)))));
+ end if;
+
+ Next (Qual_Index);
+ Next (Expr_Index);
+ end if;
+ end loop;
+ end;
+
else
-- For a conversion to an unconstrained array type, generate an
-- Action to check that the bounds of the source value are within
diff --git a/gcc/ada/checks.ads b/gcc/ada/checks.ads
index e7b7261..3b97bd0 100644
--- a/gcc/ada/checks.ads
+++ b/gcc/ada/checks.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -357,7 +357,7 @@ package Checks is
-- if so inserts the appropriate run-time check.
procedure Install_Primitive_Elaboration_Check (Subp_Body : Node_Id);
- -- Insert a check which ensures that subprogram body Subp_Body has been
+ -- Insert a check to ensure that subprogram body Subp_Body has been
-- properly elaborated. The check is installed only when Subp_Body is the
-- body of a nonabstract library-level primitive of a tagged type. Further
-- restrictions may apply, see the body for details.
@@ -851,7 +851,7 @@ package Checks is
-- are not following the flow graph (more properly the flow of actual
-- processing only corresponds to the flow graph for local assignments).
-- For non-local variables, we preserve the current setting, i.e. a
- -- validity check is performed when assigning to a knonwn valid global.
+ -- validity check is performed when assigning to a known valid global.
-- Note: no validity checking is required if range checks are suppressed
-- regardless of the setting of the validity checking mode.
diff --git a/gcc/ada/cio.c b/gcc/ada/cio.c
index 2a9fe1a..5a097ab 100644
--- a/gcc/ada/cio.c
+++ b/gcc/ada/cio.c
@@ -6,7 +6,7 @@
* *
* C Implementation File *
* *
- * Copyright (C) 1992-2020, Free Software Foundation, Inc. *
+ * Copyright (C) 1992-2021, Free Software Foundation, Inc. *
* *
* GNAT is free software; you can redistribute 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 f5778a0..03ca7a4 100644
--- a/gcc/ada/clean.adb
+++ b/gcc/ada/clean.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2003-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2003-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute 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 4e8f6fe..e2dbdb4 100644
--- a/gcc/ada/clean.ads
+++ b/gcc/ada/clean.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2003-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2003-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute 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 06fb0a4..064fae0 100644
--- a/gcc/ada/comperr.adb
+++ b/gcc/ada/comperr.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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,21 +27,22 @@
-- is detected. Calls to these routines cause termination of the current
-- compilation with appropriate error output.
-with Atree; use Atree;
-with Debug; use Debug;
-with Errout; use Errout;
-with Gnatvsn; use Gnatvsn;
-with Lib; use Lib;
-with Namet; use Namet;
-with Opt; use Opt;
-with Osint; use Osint;
-with Output; use Output;
-with Sinfo; use Sinfo;
-with Sinput; use Sinput;
-with Sprint; use Sprint;
-with Sdefault; use Sdefault;
-with Treepr; use Treepr;
-with Types; use Types;
+with Atree; use Atree;
+with Debug; use Debug;
+with Errout; use Errout;
+with Gnatvsn; use Gnatvsn;
+with Lib; use Lib;
+with Namet; use Namet;
+with Opt; use Opt;
+with Osint; use Osint;
+with Output; use Output;
+with Sinfo; use Sinfo;
+with Sinfo.Nodes; use Sinfo.Nodes;
+with Sinput; use Sinput;
+with Sprint; use Sprint;
+with Sdefault; use Sdefault;
+with Treepr; use Treepr;
+with Types; use Types;
with Ada.Exceptions; use Ada.Exceptions;
@@ -243,12 +244,17 @@ package body Comperr is
end if;
End_Line;
+
else
Write_Str ("| Error detected at ");
Write_Location (Sloc (Current_Error_Node));
End_Line;
end if;
+ Write_Str ("| Compiling ");
+ Write_Str (Get_First_Main_File_Name);
+ End_Line;
+
-- There are two cases now. If the file gnat_bug.box exists,
-- we use the contents of this file at this point.
@@ -403,6 +409,7 @@ package body Comperr is
Set_Standard_Output;
Tree_Dump;
+ Sinput.Unlock; -- so Source_Dump can modify it
Source_Dump;
raise Unrecoverable_Error;
end if;
diff --git a/gcc/ada/comperr.ads b/gcc/ada/comperr.ads
index 3bba501..9e44237 100644
--- a/gcc/ada/comperr.ads
+++ b/gcc/ada/comperr.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute 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 29557ec..d096cbb 100644
--- a/gcc/ada/contracts.adb
+++ b/gcc/ada/contracts.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2015-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2015-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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,35 +23,39 @@
-- --
------------------------------------------------------------------------------
-with Aspects; use Aspects;
-with Atree; use Atree;
-with Einfo; use Einfo;
-with Elists; use Elists;
-with Errout; use Errout;
-with Exp_Prag; use Exp_Prag;
-with Exp_Tss; use Exp_Tss;
-with Exp_Util; use Exp_Util;
-with Freeze; use Freeze;
-with Lib; use Lib;
-with Namet; use Namet;
-with Nlists; use Nlists;
-with Nmake; use Nmake;
-with Opt; use Opt;
-with Sem; use Sem;
-with Sem_Aux; use Sem_Aux;
-with Sem_Ch6; use Sem_Ch6;
-with Sem_Ch8; use Sem_Ch8;
-with Sem_Ch12; use Sem_Ch12;
-with Sem_Ch13; use Sem_Ch13;
-with Sem_Disp; use Sem_Disp;
-with Sem_Prag; use Sem_Prag;
-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;
-with Tbuild; use Tbuild;
+with Aspects; use Aspects;
+with Atree; use Atree;
+with Einfo; use Einfo;
+with Einfo.Entities; use Einfo.Entities;
+with Einfo.Utils; use Einfo.Utils;
+with Elists; use Elists;
+with Errout; use Errout;
+with Exp_Prag; use Exp_Prag;
+with Exp_Tss; use Exp_Tss;
+with Exp_Util; use Exp_Util;
+with Freeze; use Freeze;
+with Lib; use Lib;
+with Namet; use Namet;
+with Nlists; use Nlists;
+with Nmake; use Nmake;
+with Opt; use Opt;
+with Sem; use Sem;
+with Sem_Aux; use Sem_Aux;
+with Sem_Ch6; use Sem_Ch6;
+with Sem_Ch8; use Sem_Ch8;
+with Sem_Ch12; use Sem_Ch12;
+with Sem_Ch13; use Sem_Ch13;
+with Sem_Disp; use Sem_Disp;
+with Sem_Prag; use Sem_Prag;
+with Sem_Util; use Sem_Util;
+with Sinfo; use Sinfo;
+with Sinfo.Nodes; use Sinfo.Nodes;
+with Sinfo.Utils; use Sinfo.Utils;
+with Sinput; use Sinput;
+with Snames; use Snames;
+with Stand; use Stand;
+with Stringt; use Stringt;
+with Tbuild; use Tbuild;
package body Contracts is
@@ -1576,7 +1580,7 @@ package body Contracts is
-- in its visible declarations.
if Nkind (Templ) = N_Generic_Package_Declaration then
- Set_Ekind (Templ_Id, E_Generic_Package);
+ Mutate_Ekind (Templ_Id, E_Generic_Package);
if Present (Visible_Declarations (Specification (Templ))) then
Decl := First (Visible_Declarations (Specification (Templ)));
@@ -1586,7 +1590,7 @@ package body Contracts is
-- declarations.
elsif Nkind (Templ) = N_Package_Body then
- Set_Ekind (Templ_Id, E_Package_Body);
+ Mutate_Ekind (Templ_Id, E_Package_Body);
if Present (Declarations (Templ)) then
Decl := First (Declarations (Templ));
@@ -1596,9 +1600,9 @@ package body Contracts is
elsif Nkind (Templ) = N_Generic_Subprogram_Declaration then
if Nkind (Specification (Templ)) = N_Function_Specification then
- Set_Ekind (Templ_Id, E_Generic_Function);
+ Mutate_Ekind (Templ_Id, E_Generic_Function);
else
- Set_Ekind (Templ_Id, E_Generic_Procedure);
+ Mutate_Ekind (Templ_Id, E_Generic_Procedure);
end if;
-- When the generic subprogram acts as a compilation unit, inspect
@@ -1622,7 +1626,7 @@ package body Contracts is
-- its declarations.
elsif Nkind (Templ) = N_Subprogram_Body then
- Set_Ekind (Templ_Id, E_Subprogram_Body);
+ Mutate_Ekind (Templ_Id, E_Subprogram_Body);
if Present (Declarations (Templ)) then
Decl := First (Declarations (Templ));
@@ -2367,6 +2371,10 @@ package body Contracts is
-- postconditions until finalization has been performed when cleanup
-- actions are present.
+ -- NOTE: This flag could be made into a predicate since we should be
+ -- able at compile time to recognize when finalization and cleanup
+ -- actions occur, but in practice this is not possible ???
+
-- Generate:
--
-- Postcond_Enabled : Boolean := True;
@@ -2405,16 +2413,16 @@ package body Contracts is
-- the postconditions: this would cause confusing debug info to be
-- produced, interfering with coverage-analysis tools.
- -- Also, wrap the postcondition checks in a conditional which can be
- -- used to delay their evaluation when clean-up actions are present.
+ -- NOTE: Coverage-analysis and static-analysis tools rely on the
+ -- postconditions procedure being free of internally generated code
+ -- since some of these tools, like CodePeer, treat _postconditions
+ -- as original source.
-- Generate:
--
-- procedure _postconditions is
-- begin
- -- if Postcond_Enabled and then Return_Success_For_Postcond then
- -- [Stmts];
- -- end if;
+ -- [Stmts];
-- end;
Proc_Bod :=
@@ -2425,19 +2433,7 @@ package body Contracts is
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
End_Label => Make_Identifier (Loc, Chars (Proc_Id)),
- Statements => New_List (
- Make_If_Statement (Loc,
- Condition =>
- Make_And_Then (Loc,
- Left_Opnd =>
- New_Occurrence_Of
- (Defining_Identifier
- (Postcond_Enabled_Decl), Loc),
- Right_Opnd =>
- New_Occurrence_Of
- (Defining_Identifier
- (Return_Success_Decl), Loc)),
- Then_Statements => Stmts))));
+ Statements => Stmts));
Insert_After_And_Analyze (Last_Decl, Proc_Bod);
end Build_Postconditions_Procedure;
@@ -2614,7 +2610,21 @@ package body Contracts is
for Index in Subps'Range loop
Subp_Id := Subps (Index);
- Items := Contract (Subp_Id);
+
+ if Present (Alias (Subp_Id)) then
+ Subp_Id := Ultimate_Alias (Subp_Id);
+ end if;
+
+ -- Wrappers of class-wide pre/post conditions reference the
+ -- parent primitive that has the inherited contract.
+
+ if Is_Wrapper (Subp_Id)
+ and then Present (LSP_Subprogram (Subp_Id))
+ then
+ Subp_Id := LSP_Subprogram (Subp_Id);
+ end if;
+
+ Items := Contract (Subp_Id);
if Present (Items) then
Prag := Pre_Post_Conditions (Items);
@@ -2896,7 +2906,21 @@ package body Contracts is
for Index in Subps'Range loop
Subp_Id := Subps (Index);
- Items := Contract (Subp_Id);
+
+ if Present (Alias (Subp_Id)) then
+ Subp_Id := Ultimate_Alias (Subp_Id);
+ end if;
+
+ -- Wrappers of class-wide pre/post conditions reference the
+ -- parent primitive that has the inherited contract.
+
+ if Is_Wrapper (Subp_Id)
+ and then Present (LSP_Subprogram (Subp_Id))
+ then
+ Subp_Id := LSP_Subprogram (Subp_Id);
+ end if;
+
+ Items := Contract (Subp_Id);
if Present (Items) then
Prag := Pre_Post_Conditions (Items);
diff --git a/gcc/ada/contracts.ads b/gcc/ada/contracts.ads
index b8a12ff..bfd482e 100644
--- a/gcc/ada/contracts.ads
+++ b/gcc/ada/contracts.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2015-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2015-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute 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.adb b/gcc/ada/csets.adb
index 0b77b65..29a1592 100644
--- a/gcc/ada/csets.adb
+++ b/gcc/ada/csets.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -1091,38 +1091,40 @@ package body Csets is
begin
-- Set Fold_Upper table from source code indication
- if Identifier_Character_Set = '1'
- or else Identifier_Character_Set = 'w'
- then
- Fold_Upper := Fold_Latin_1;
+ case Identifier_Character_Set is
+ when '1' | 'w' =>
+ Fold_Upper := Fold_Latin_1;
- elsif Identifier_Character_Set = '2' then
- Fold_Upper := Fold_Latin_2;
+ when '2' =>
+ Fold_Upper := Fold_Latin_2;
- elsif Identifier_Character_Set = '3' then
- Fold_Upper := Fold_Latin_3;
+ when '3' =>
+ Fold_Upper := Fold_Latin_3;
- elsif Identifier_Character_Set = '4' then
- Fold_Upper := Fold_Latin_4;
+ when '4' =>
+ Fold_Upper := Fold_Latin_4;
- elsif Identifier_Character_Set = '5' then
- Fold_Upper := Fold_Cyrillic;
+ when '5' =>
+ Fold_Upper := Fold_Cyrillic;
- elsif Identifier_Character_Set = 'p' then
- Fold_Upper := Fold_IBM_PC_437;
+ when '9' =>
+ Fold_Upper := Fold_Latin_9;
- elsif Identifier_Character_Set = '8' then
- Fold_Upper := Fold_IBM_PC_850;
+ when 'p' =>
+ Fold_Upper := Fold_IBM_PC_437;
- elsif Identifier_Character_Set = '9' then
- Fold_Upper := Fold_Latin_9;
+ when '8' =>
+ Fold_Upper := Fold_IBM_PC_850;
- elsif Identifier_Character_Set = 'f' then
- Fold_Upper := Fold_Full_Upper_Half;
+ when 'f' =>
+ Fold_Upper := Fold_Full_Upper_Half;
- else -- Identifier_Character_Set = 'n'
- Fold_Upper := Fold_No_Upper_Half;
- end if;
+ when 'n' =>
+ Fold_Upper := Fold_No_Upper_Half;
+
+ when others =>
+ raise Program_Error;
+ end case;
-- Use Fold_Upper table to compute Fold_Lower table
diff --git a/gcc/ada/csets.ads b/gcc/ada/csets.ads
index ee24926..1bdbca4 100644
--- a/gcc/ada/csets.ads
+++ b/gcc/ada/csets.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute 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
deleted file mode 100644
index 635a2a5..0000000
--- a/gcc/ada/csinfo.adb
+++ /dev/null
@@ -1,639 +0,0 @@
-------------------------------------------------------------------------------
--- --
--- GNAT SYSTEM UTILITIES --
--- --
--- C S I N F O --
--- --
--- 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. 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. --
--- --
-------------------------------------------------------------------------------
-
--- Check consistency of sinfo.ads and sinfo.adb. Checks that field name usage
--- is consistent and that assertion cross-reference lists are correct, as well
--- as making sure that all the comments on field name usage are consistent.
-
--- Note that this is used both as a standalone program, and as a procedure
--- called by XSinfo. This raises an unhandled exception if it finds any
--- errors; we don't attempt any sophisticated error recovery.
-
-with Ada.Strings.Unbounded; use Ada.Strings.Unbounded;
-with Ada.Strings.Unbounded.Text_IO; use Ada.Strings.Unbounded.Text_IO;
-with Ada.Strings.Maps; use Ada.Strings.Maps;
-with Ada.Strings.Maps.Constants; use Ada.Strings.Maps.Constants;
-with Ada.Text_IO; use Ada.Text_IO;
-
-with GNAT.Spitbol; use GNAT.Spitbol;
-with GNAT.Spitbol.Patterns; use GNAT.Spitbol.Patterns;
-with GNAT.Spitbol.Table_Boolean;
-with GNAT.Spitbol.Table_VString;
-
-procedure CSinfo is
-
- package TB renames GNAT.Spitbol.Table_Boolean;
- package TV renames GNAT.Spitbol.Table_VString;
- use TB, TV;
-
- Infil : File_Type;
- Lineno : Natural := 0;
-
- Err : exception;
- -- Raised on fatal error
-
- Done : exception;
- -- Raised after error is found to terminate run
-
- WSP : constant Pattern := Span (' ' & ASCII.HT);
-
- Fields : TV.Table (300);
- Fields1 : TV.Table (300);
- Refs : TV.Table (300);
- Refscopy : TV.Table (300);
- Special : TB.Table (50);
- Inlines : TV.Table (100);
-
- -- The following define the standard fields used for binary operator,
- -- unary operator, and other expression nodes. Numbers in the range 1-5
- -- refer to the Fieldn fields. Letters D-R refer to flags:
-
- -- D = Flag4
- -- E = Flag5
- -- F = Flag6
- -- G = Flag7
- -- H = Flag8
- -- I = Flag9
- -- J = Flag10
- -- K = Flag11
- -- L = Flag12
- -- M = Flag13
- -- N = Flag14
- -- O = Flag15
- -- P = Flag16
- -- Q = Flag17
- -- R = Flag18
-
- Flags : TV.Table (20);
- -- Maps flag numbers to letters
-
- 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;
-
- Field : constant VString := Nul;
- Fields_Used : VString := Nul;
- Name : constant VString := Nul;
- Next : constant VString := Nul;
- Node : VString := Nul;
- Ref : VString := Nul;
- Synonym : constant VString := Nul;
- Nxtref : constant VString := Nul;
-
- Which_Field : aliased VString := Nul;
-
- Node_Search : constant Pattern := WSP & "-- N_" & Rest * Node;
- Break_Punc : constant Pattern := Break (" .,");
- Plus_Binary : constant Pattern := WSP
- & "-- plus fields for binary operator";
- Plus_Unary : constant Pattern := WSP
- & "-- plus fields for unary operator";
- Plus_Expr : constant Pattern := WSP
- & "-- plus fields for expression";
- Break_Syn : constant Pattern := WSP & "-- "
- & Break (' ') * Synonym
- & " (" & Break (')') * Field;
- Break_Field : constant Pattern := BreakX ('-') * Field;
- Get_Field : constant Pattern := BreakX (Decimal_Digit_Set)
- & Span (Decimal_Digit_Set) * Which_Field;
- Break_WFld : constant Pattern := Break (Which_Field'Access);
- Get_Funcsyn : constant Pattern := WSP & "function " & Rest * Synonym;
- Extr_Field : constant Pattern := BreakX ('-') & "-- " & Rest * Field;
- Get_Procsyn : constant Pattern := WSP & "procedure Set_" & Rest * Synonym;
- Get_Inline : constant Pattern := WSP & "pragma Inline ("
- & Break (')') * Name;
- Set_Name : constant Pattern := "Set_" & Rest * Name;
- Func_Rest : constant Pattern := " function " & Rest * Synonym;
- Get_Nxtref : constant Pattern := Break (',') * Nxtref & ',';
- Test_Syn : constant Pattern := Break ('=') & "= N_"
- & (Break (" ,)") or Rest) * Next;
- Chop_Comma : constant Pattern := BreakX (',') * Next;
- Return_Fld : constant Pattern := WSP & "return " & Break (' ') * Field;
- Set_Syn : constant Pattern := " procedure Set_" & Rest * Synonym;
- Set_Fld : constant Pattern := WSP & "Set_" & Break (' ') * Field
- & " (N, Val)";
- Break_With : constant Pattern := Break ('_') ** Field & "_With_Parent";
-
- type VStringA is array (Natural range <>) of VString;
-
- procedure Next_Line;
- -- Read next line trimmed from Infil into Line and bump Lineno
-
- procedure Sort (A : in out VStringA);
- -- Sort a (small) array of VString's
-
- procedure Next_Line is
- begin
- Line := Get_Line (Infil);
- Trim (Line);
- Lineno := Lineno + 1;
- end Next_Line;
-
- procedure Sort (A : in out VStringA) is
- Temp : VString;
- begin
- <<Sort>>
- for J in 1 .. A'Length - 1 loop
- if A (J) > A (J + 1) then
- Temp := A (J);
- A (J) := A (J + 1);
- A (J + 1) := Temp;
- goto Sort;
- end if;
- end loop;
- end Sort;
-
--- Start of processing for CSinfo
-
-begin
- Anchored_Mode := True;
- New_Line;
- Open (Infil, In_File, "sinfo.ads");
- Put_Line ("Check for field name consistency");
-
- -- Setup table for mapping flag numbers to letters
-
- Set (Flags, "4", V ("D"));
- Set (Flags, "5", V ("E"));
- Set (Flags, "6", V ("F"));
- Set (Flags, "7", V ("G"));
- Set (Flags, "8", V ("H"));
- Set (Flags, "9", V ("I"));
- Set (Flags, "10", V ("J"));
- Set (Flags, "11", V ("K"));
- Set (Flags, "12", V ("L"));
- Set (Flags, "13", V ("M"));
- Set (Flags, "14", V ("N"));
- Set (Flags, "15", V ("O"));
- Set (Flags, "16", V ("P"));
- Set (Flags, "17", V ("Q"));
- Set (Flags, "18", V ("R"));
-
- -- Special fields table. The following names are not recorded or checked
- -- by Csinfo, since they are specially handled. This means that any field
- -- definition or subprogram with a matching name is ignored.
-
- Set (Special, "Analyzed", True);
- Set (Special, "Assignment_OK", True);
- Set (Special, "Associated_Node", True);
- Set (Special, "Cannot_Be_Constant", True);
- Set (Special, "Chars", True);
- Set (Special, "Comes_From_Source", True);
- Set (Special, "Do_Overflow_Check", True);
- Set (Special, "Do_Range_Check", True);
- Set (Special, "Entity", True);
- Set (Special, "Entity_Or_Associated_Node", True);
- Set (Special, "Error_Posted", True);
- Set (Special, "Etype", True);
- Set (Special, "Evaluate_Once", True);
- Set (Special, "First_Itype", True);
- Set (Special, "Has_Aspect_Specifications", True);
- Set (Special, "Has_Dynamic_Itype", True);
- Set (Special, "Has_Dynamic_Length_Check", True);
- Set (Special, "Has_Private_View", True);
- Set (Special, "Is_Controlling_Actual", True);
- Set (Special, "Is_Overloaded", True);
- Set (Special, "Is_Static_Expression", True);
- Set (Special, "Left_Opnd", True);
- Set (Special, "Must_Not_Freeze", True);
- Set (Special, "Nkind_In", True);
- Set (Special, "Parens", True);
- Set (Special, "Pragma_Name", True);
- Set (Special, "Raises_Constraint_Error", True);
- Set (Special, "Right_Opnd", True);
-
- -- Loop to acquire information from node definitions in sinfo.ads,
- -- checking for consistency in Op/Flag assignments to each synonym
-
- loop
- Bad := False;
- Next_Line;
- exit when Match (Line, " -- Node Access Functions");
-
- if Match (Line, Node_Search)
- and then not Match (Node, Break_Punc)
- then
- Fields_Used := Nul;
-
- elsif Node = "" then
- null;
-
- elsif Line = "" then
- Node := Nul;
-
- elsif Match (Line, Plus_Binary) then
- Bad := Match (Fields_Used, B_Fields);
-
- elsif Match (Line, Plus_Unary) then
- Bad := Match (Fields_Used, U_Fields);
-
- elsif Match (Line, Plus_Expr) then
- Bad := Match (Fields_Used, E_Fields);
-
- elsif not Match (Line, Break_Syn) then
- null;
-
- elsif Match (Synonym, "plus") then
- null;
-
- else
- Match (Field, Break_Field);
-
- if not Present (Special, Synonym) then
- if Present (Fields, Synonym) then
- if Field /= Get (Fields, Synonym) then
- Put_Line
- ("Inconsistent field reference at line" &
- Lineno'Img & " for " & Synonym);
- raise Done;
- end if;
-
- else
- Set (Fields, Synonym, Field);
- end if;
-
- Set (Refs, Synonym, Node & ',' & Get (Refs, Synonym));
- Match (Field, Get_Field);
-
- if Match (Field, "Flag") then
- Which_Field := Get (Flags, Which_Field);
- end if;
-
- if Match (Fields_Used, Break_WFld) then
- Put_Line
- ("Overlapping field at line " & Lineno'Img &
- " for " & Synonym);
- raise Done;
- end if;
-
- Append (Fields_Used, Which_Field);
- Bad := Bad or Match (Fields_Used, N_Fields);
- end if;
- end if;
-
- if Bad then
- Put_Line ("fields conflict with standard fields for node " & Node);
- raise Done;
- end if;
- end loop;
-
- Put_Line (" OK");
- New_Line;
- Put_Line ("Check for function consistency");
-
- -- Loop through field function definitions to make sure they are OK
-
- Fields1 := Fields;
- loop
- Next_Line;
- exit when Match (Line, " -- Node Update");
-
- if Match (Line, Get_Funcsyn)
- and then not Present (Special, Synonym)
- then
- if not Present (Fields1, Synonym) then
- Put_Line
- ("function on line " & Lineno &
- " is for unused synonym");
- raise Done;
- end if;
-
- Next_Line;
-
- if not Match (Line, Extr_Field) then
- raise Err;
- end if;
-
- if Field /= Get (Fields1, Synonym) then
- Put_Line ("Wrong field in function " & Synonym);
- raise Done;
-
- else
- Delete (Fields1, Synonym);
- end if;
- end if;
- end loop;
-
- Put_Line (" OK");
- New_Line;
- Put_Line ("Check for missing functions");
-
- declare
- List : constant TV.Table_Array := Convert_To_Array (Fields1);
-
- begin
- if List'Length > 0 then
- Put_Line ("No function for field synonym " & List (1).Name);
- raise Done;
- end if;
- end;
-
- -- Check field set procedures
-
- Put_Line (" OK");
- New_Line;
- Put_Line ("Check for set procedure consistency");
-
- Fields1 := Fields;
- loop
- Next_Line;
- exit when Match (Line, " -- Inline Pragmas");
- exit when Match (Line, " -- Iterator Procedures");
-
- if Match (Line, Get_Procsyn)
- and then not Present (Special, Synonym)
- then
- if not Present (Fields1, Synonym) then
- Put_Line
- ("procedure on line " & Lineno & " is for unused synonym");
- raise Done;
- end if;
-
- Next_Line;
-
- if not Match (Line, Extr_Field) then
- raise Err;
- end if;
-
- if Field /= Get (Fields1, Synonym) then
- Put_Line ("Wrong field in procedure Set_" & Synonym);
- raise Done;
-
- else
- Delete (Fields1, Synonym);
- end if;
- end if;
- end loop;
-
- Put_Line (" OK");
- New_Line;
- Put_Line ("Check for missing set procedures");
-
- declare
- List : constant TV.Table_Array := Convert_To_Array (Fields1);
-
- begin
- if List'Length > 0 then
- Put_Line ("No procedure for field synonym Set_" & List (1).Name);
- raise Done;
- end if;
- end;
-
- Put_Line (" OK");
- New_Line;
- Put_Line ("Check pragma Inlines are all for existing subprograms");
-
- Clear (Fields1);
- while not End_Of_File (Infil) loop
- Next_Line;
-
- if Match (Line, Get_Inline)
- and then not Present (Special, Name)
- then
- exit when Match (Name, Set_Name);
-
- if not Present (Fields, Name) then
- Put_Line
- ("Pragma Inline on line " & Lineno &
- " does not correspond to synonym");
- raise Done;
-
- else
- Set (Inlines, Name, Get (Inlines, Name) & 'r');
- end if;
- end if;
- end loop;
-
- Put_Line (" OK");
- New_Line;
- Put_Line ("Check no pragma Inlines were omitted");
-
- declare
- List : constant TV.Table_Array := Convert_To_Array (Fields);
- Nxt : VString := Nul;
-
- begin
- for M in List'Range loop
- Nxt := List (M).Name;
-
- if Get (Inlines, Nxt) /= "r" then
- Put_Line ("Incorrect pragma Inlines for " & Nxt);
- raise Done;
- end if;
- end loop;
- end;
-
- Put_Line (" OK");
- New_Line;
- Clear (Inlines);
-
- Close (Infil);
- Open (Infil, In_File, "sinfo.adb");
- Lineno := 0;
- Put_Line ("Check references in functions in body");
-
- Refscopy := Refs;
- loop
- Next_Line;
- exit when Match (Line, " -- Field Access Functions --");
- end loop;
-
- loop
- Next_Line;
- exit when Match (Line, " -- Field Set Procedures --");
-
- if Match (Line, Func_Rest)
- and then not Present (Special, Synonym)
- then
- Ref := Get (Refs, Synonym);
- Delete (Refs, Synonym);
-
- if Ref = "" then
- Put_Line
- ("Function on line " & Lineno & " is for unknown synonym");
- raise Err;
- end if;
-
- -- Alpha sort of references for this entry
-
- declare
- Refa : VStringA (1 .. 100);
- N : Natural := 0;
-
- begin
- loop
- exit when not Match (Ref, Get_Nxtref, Nul);
- N := N + 1;
- Refa (N) := Nxtref;
- end loop;
-
- Sort (Refa (1 .. N));
- Next_Line;
- Next_Line;
- Next_Line;
-
- -- Checking references for one entry
-
- for M in 1 .. N loop
- Next_Line;
-
- if not Match (Line, Test_Syn) then
- Put_Line ("Expecting N_" & Refa (M) & " at line " & Lineno);
- raise Done;
- end if;
-
- Match (Next, Chop_Comma);
-
- if Next /= Refa (M) then
- Put_Line ("Expecting N_" & Refa (M) & " at line " & Lineno);
- raise Done;
- end if;
- end loop;
-
- Next_Line;
- Match (Line, Return_Fld);
-
- if Field /= Get (Fields, Synonym) then
- Put_Line
- ("Wrong field for function " & Synonym & " at line " &
- Lineno & " should be " & Get (Fields, Synonym));
- raise Done;
- end if;
- end;
- end if;
- end loop;
-
- Put_Line (" OK");
- New_Line;
- Put_Line ("Check for missing functions in body");
-
- declare
- List : constant TV.Table_Array := Convert_To_Array (Refs);
-
- begin
- if List'Length /= 0 then
- Put_Line ("Missing function " & List (1).Name & " in body");
- raise Done;
- end if;
- end;
-
- Put_Line (" OK");
- New_Line;
- Put_Line ("Check Set procedures in body");
- Refs := Refscopy;
-
- loop
- Next_Line;
- exit when Match (Line, "end");
- exit when Match (Line, " -- Iterator Procedures");
-
- if Match (Line, Set_Syn)
- and then not Present (Special, Synonym)
- then
- Ref := Get (Refs, Synonym);
- Delete (Refs, Synonym);
-
- if Ref = "" then
- Put_Line
- ("Function on line " & Lineno & " is for unknown synonym");
- raise Err;
- end if;
-
- -- Alpha sort of references for this entry
-
- declare
- Refa : VStringA (1 .. 100);
- N : Natural;
-
- begin
- N := 0;
-
- loop
- exit when not Match (Ref, Get_Nxtref, Nul);
- N := N + 1;
- Refa (N) := Nxtref;
- end loop;
-
- Sort (Refa (1 .. N));
-
- Next_Line;
- Next_Line;
- Next_Line;
-
- -- Checking references for one entry
-
- for M in 1 .. N loop
- Next_Line;
-
- if not Match (Line, Test_Syn)
- or else Next /= Refa (M)
- then
- Put_Line ("Expecting N_" & Refa (M) & " at line " & Lineno);
- raise Err;
- end if;
- end loop;
-
- loop
- Next_Line;
- exit when Match (Line, Set_Fld);
- end loop;
-
- Match (Field, Break_With);
-
- if Field /= Get (Fields, Synonym) then
- Put_Line
- ("Wrong field for procedure Set_" & Synonym &
- " at line " & Lineno & " should be " &
- Get (Fields, Synonym));
- raise Done;
- end if;
-
- Delete (Fields1, Synonym);
- end;
- end if;
- end loop;
-
- Put_Line (" OK");
- New_Line;
- Put_Line ("Check for missing set procedures in body");
-
- declare
- List : constant TV.Table_Array := Convert_To_Array (Fields1);
- begin
- if List'Length /= 0 then
- Put_Line ("Missing procedure Set_" & List (1).Name & " in body");
- raise Done;
- end if;
- end;
-
- Put_Line (" OK");
- New_Line;
- Put_Line ("All tests completed successfully, no errors detected");
-
-end CSinfo;
diff --git a/gcc/ada/cstand.adb b/gcc/ada/cstand.adb
index 3f5389c..44cb69c 100644
--- a/gcc/ada/cstand.adb
+++ b/gcc/ada/cstand.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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,28 +23,32 @@
-- --
------------------------------------------------------------------------------
-with Atree; use Atree;
-with Csets; use Csets;
-with Debug; use Debug;
-with Einfo; use Einfo;
-with Elists; use Elists;
-with Layout; use Layout;
-with Namet; use Namet;
-with Nlists; use Nlists;
-with Nmake; use Nmake;
-with Opt; use Opt;
-with Output; use Output;
-with Set_Targ; use Set_Targ;
-with Targparm; use Targparm;
-with Tbuild; use Tbuild;
-with Ttypes; use Ttypes;
-with Sem_Mech; use Sem_Mech;
-with Sem_Util; use Sem_Util;
-with Sinfo; use Sinfo;
-with Snames; use Snames;
-with Stand; use Stand;
-with Uintp; use Uintp;
-with Urealp; use Urealp;
+with Atree; use Atree;
+with Csets; use Csets;
+with Debug; use Debug;
+with Einfo; use Einfo;
+with Einfo.Entities; use Einfo.Entities;
+with Einfo.Utils; use Einfo.Utils;
+with Elists; use Elists;
+with Layout; use Layout;
+with Namet; use Namet;
+with Nlists; use Nlists;
+with Nmake; use Nmake;
+with Opt; use Opt;
+with Output; use Output;
+with Set_Targ; use Set_Targ;
+with Targparm; use Targparm;
+with Tbuild; use Tbuild;
+with Ttypes; use Ttypes;
+with Sem_Mech; use Sem_Mech;
+with Sem_Util; use Sem_Util;
+with Sinfo; use Sinfo;
+with Sinfo.Nodes; use Sinfo.Nodes;
+with Sinfo.Utils; use Sinfo.Utils;
+with Snames; use Snames;
+with Stand; use Stand;
+with Uintp; use Uintp;
+with Urealp; use Urealp;
package body CStand is
@@ -129,12 +133,12 @@ package body CStand is
-- Returns an identifier node with the same name as the defining identifier
-- corresponding to the given Standard_Entity_Type value.
- procedure Make_Component
+ procedure Make_Aliased_Component
(Rec : Entity_Id;
Typ : Entity_Id;
Nam : String);
- -- Build a record component with the given type and name, and append to
- -- the list of components of Rec.
+ -- Build an aliased record component with the given type and name,
+ -- and append to the list of components of Rec.
function Make_Formal (Typ : Entity_Id; Nam : String) return Entity_Id;
-- Construct entity for subprogram formal with given name and type
@@ -199,7 +203,7 @@ package body CStand is
Make_Floating_Point_Definition (Stloc,
Digits_Expression => Make_Integer (UI_From_Int (Digs))));
- Set_Ekind (E, E_Floating_Point_Type);
+ Mutate_Ekind (E, E_Floating_Point_Type);
Set_Etype (E, E);
Init_Digits_Value (E, Digs);
Set_Float_Rep (E, Rep);
@@ -243,7 +247,7 @@ package body CStand is
Low_Bound => Make_Integer (Lbound),
High_Bound => Make_Integer (Ubound)));
- Set_Ekind (E, E_Signed_Integer_Type);
+ Mutate_Ekind (E, E_Signed_Integer_Type);
Set_Etype (E, E);
Init_Size (E, Siz);
Set_Elem_Alignment (E);
@@ -268,7 +272,7 @@ package body CStand is
begin
Set_Defining_Identifier (Decl, Uns);
- Set_Ekind (Uns, E_Modular_Integer_Type);
+ Mutate_Ekind (Uns, E_Modular_Integer_Type);
Set_Scope (Uns, Standard_Standard);
Set_Etype (Uns, Uns);
Init_Size (Uns, Siz);
@@ -463,7 +467,7 @@ package body CStand is
procedure Build_Exception (S : Standard_Entity_Type) is
begin
- Set_Ekind (Standard_Entity (S), E_Exception);
+ Mutate_Ekind (Standard_Entity (S), E_Exception);
Set_Etype (Standard_Entity (S), Standard_Exception_Type);
Set_Is_Public (Standard_Entity (S), True);
@@ -603,7 +607,7 @@ package body CStand is
Set_Defining_Unit_Name (Pspec, Standard_Standard);
Set_Visible_Declarations (Pspec, Decl_S);
- Set_Ekind (Standard_Standard, E_Package);
+ Mutate_Ekind (Standard_Standard, E_Package);
Set_Is_Pure (Standard_Standard);
Set_Is_Compilation_Unit (Standard_Standard);
@@ -645,7 +649,7 @@ package body CStand is
Append (Standard_True, Literals (Tdef_Node));
Set_Type_Definition (Parent (Standard_Boolean), Tdef_Node);
- Set_Ekind (Standard_Boolean, E_Enumeration_Type);
+ Mutate_Ekind (Standard_Boolean, E_Enumeration_Type);
Set_First_Literal (Standard_Boolean, Standard_False);
Set_Etype (Standard_Boolean, Standard_Boolean);
Init_Esize (Standard_Boolean, Standard_Character_Size);
@@ -656,13 +660,13 @@ package body CStand is
Set_Size_Known_At_Compile_Time (Standard_Boolean);
Set_Has_Pragma_Ordered (Standard_Boolean);
- Set_Ekind (Standard_True, E_Enumeration_Literal);
+ Mutate_Ekind (Standard_True, E_Enumeration_Literal);
Set_Etype (Standard_True, Standard_Boolean);
Set_Enumeration_Pos (Standard_True, Uint_1);
Set_Enumeration_Rep (Standard_True, Uint_1);
Set_Is_Known_Valid (Standard_True, True);
- Set_Ekind (Standard_False, E_Enumeration_Literal);
+ Mutate_Ekind (Standard_False, E_Enumeration_Literal);
Set_Etype (Standard_False, Standard_Boolean);
Set_Enumeration_Pos (Standard_False, Uint_0);
Set_Enumeration_Rep (Standard_False, Uint_0);
@@ -751,7 +755,7 @@ package body CStand is
Tdef_Node := New_Node (N_Enumeration_Type_Definition, Stloc);
Set_Type_Definition (Parent (Standard_Character), Tdef_Node);
- Set_Ekind (Standard_Character, E_Enumeration_Type);
+ Mutate_Ekind (Standard_Character, E_Enumeration_Type);
Set_Etype (Standard_Character, Standard_Character);
Init_Esize (Standard_Character, Standard_Character_Size);
Init_RM_Size (Standard_Character, 8);
@@ -798,7 +802,7 @@ package body CStand is
Tdef_Node := New_Node (N_Enumeration_Type_Definition, Stloc);
Set_Type_Definition (Parent (Standard_Wide_Character), Tdef_Node);
- Set_Ekind (Standard_Wide_Character, E_Enumeration_Type);
+ Mutate_Ekind (Standard_Wide_Character, E_Enumeration_Type);
Set_Etype (Standard_Wide_Character, Standard_Wide_Character);
Init_Size (Standard_Wide_Character, Standard_Wide_Character_Size);
@@ -817,7 +821,7 @@ package body CStand is
B_Node := New_Node (N_Character_Literal, Stloc);
Set_Is_Static_Expression (B_Node);
- Set_Chars (B_Node, No_Name); -- ???
+ Set_Chars (B_Node, No_Name);
Set_Char_Literal_Value (B_Node, Uint_0);
Set_Entity (B_Node, Empty);
Set_Etype (B_Node, Standard_Wide_Character);
@@ -827,7 +831,7 @@ package body CStand is
B_Node := New_Node (N_Character_Literal, Stloc);
Set_Is_Static_Expression (B_Node);
- Set_Chars (B_Node, No_Name); -- ???
+ Set_Chars (B_Node, No_Name);
Set_Char_Literal_Value (B_Node, UI_From_Int (16#FFFF#));
Set_Entity (B_Node, Empty);
Set_Etype (B_Node, Standard_Wide_Character);
@@ -844,7 +848,7 @@ package body CStand is
Tdef_Node := New_Node (N_Enumeration_Type_Definition, Stloc);
Set_Type_Definition (Parent (Standard_Wide_Wide_Character), Tdef_Node);
- Set_Ekind (Standard_Wide_Wide_Character, E_Enumeration_Type);
+ Mutate_Ekind (Standard_Wide_Wide_Character, E_Enumeration_Type);
Set_Etype (Standard_Wide_Wide_Character,
Standard_Wide_Wide_Character);
Init_Size (Standard_Wide_Wide_Character,
@@ -866,7 +870,7 @@ package body CStand is
B_Node := New_Node (N_Character_Literal, Stloc);
Set_Is_Static_Expression (B_Node);
- Set_Chars (B_Node, No_Name); -- ???
+ Set_Chars (B_Node, No_Name);
Set_Char_Literal_Value (B_Node, Uint_0);
Set_Entity (B_Node, Empty);
Set_Etype (B_Node, Standard_Wide_Wide_Character);
@@ -876,7 +880,7 @@ package body CStand is
B_Node := New_Node (N_Character_Literal, Stloc);
Set_Is_Static_Expression (B_Node);
- Set_Chars (B_Node, No_Name); -- ???
+ Set_Chars (B_Node, No_Name);
Set_Char_Literal_Value (B_Node, UI_From_Int (16#7FFF_FFFF#));
Set_Entity (B_Node, Empty);
Set_Etype (B_Node, Standard_Wide_Wide_Character);
@@ -904,7 +908,7 @@ package body CStand is
Append (Identifier_For (S_Positive), Subtype_Marks (Tdef_Node));
Set_Type_Definition (Parent (Standard_String), Tdef_Node);
- Set_Ekind (Standard_String, E_Array_Type);
+ Mutate_Ekind (Standard_String, E_Array_Type);
Set_Etype (Standard_String, Standard_String);
Set_Component_Type (Standard_String, Standard_Character);
Set_Component_Size (Standard_String, Uint_8);
@@ -912,9 +916,9 @@ package body CStand is
Set_Alignment (Standard_String, Uint_1);
Pack_String_Type (Standard_String);
- -- On targets where a storage unit is larger than a byte (such as AAMP),
- -- pragma Pack has a real effect on the representation of type String,
- -- and the type must be marked as having a nonstandard representation.
+ -- On targets where a storage unit is larger than a byte, pragma Pack
+ -- has a real effect on the representation of type String, and the type
+ -- must be marked as having a nonstandard representation.
if System_Storage_Unit > Uint_8 then
Set_Has_Non_Standard_Rep (Standard_String);
@@ -948,7 +952,7 @@ package body CStand is
Append (Identifier_For (S_Positive), Subtype_Marks (Tdef_Node));
Set_Type_Definition (Parent (Standard_Wide_String), Tdef_Node);
- Set_Ekind (Standard_Wide_String, E_Array_Type);
+ Mutate_Ekind (Standard_Wide_String, E_Array_Type);
Set_Etype (Standard_Wide_String, Standard_Wide_String);
Set_Component_Type (Standard_Wide_String, Standard_Wide_Character);
Set_Component_Size (Standard_Wide_String, Uint_16);
@@ -983,7 +987,7 @@ package body CStand is
Append (Identifier_For (S_Positive), Subtype_Marks (Tdef_Node));
Set_Type_Definition (Parent (Standard_Wide_Wide_String), Tdef_Node);
- Set_Ekind (Standard_Wide_Wide_String, E_Array_Type);
+ Mutate_Ekind (Standard_Wide_Wide_String, E_Array_Type);
Set_Etype (Standard_Wide_Wide_String,
Standard_Wide_Wide_String);
Set_Component_Type (Standard_Wide_Wide_String,
@@ -1005,7 +1009,7 @@ package body CStand is
-- Setup entity for Natural
- Set_Ekind (Standard_Natural, E_Signed_Integer_Subtype);
+ Mutate_Ekind (Standard_Natural, E_Signed_Integer_Subtype);
Set_Etype (Standard_Natural, Base_Type (Standard_Integer));
Init_Esize (Standard_Natural, Standard_Integer_Size);
Init_RM_Size (Standard_Natural, Standard_Integer_Size - 1);
@@ -1020,7 +1024,7 @@ package body CStand is
-- Setup entity for Positive
- Set_Ekind (Standard_Positive, E_Signed_Integer_Subtype);
+ Mutate_Ekind (Standard_Positive, E_Signed_Integer_Subtype);
Set_Etype (Standard_Positive, Base_Type (Standard_Integer));
Init_Esize (Standard_Positive, Standard_Integer_Size);
Init_RM_Size (Standard_Positive, Standard_Integer_Size - 1);
@@ -1043,7 +1047,7 @@ package body CStand is
Set_Specification (Decl, Pspec);
Set_Defining_Unit_Name (Pspec, Standard_Entity (S_ASCII));
- Set_Ekind (Standard_Entity (S_ASCII), E_Package);
+ Mutate_Ekind (Standard_Entity (S_ASCII), E_Package);
Set_Visible_Declarations (Pspec, Decl_A);
-- Create control character definitions in package ASCII. Note that
@@ -1063,7 +1067,7 @@ package body CStand is
begin
Set_Sloc (A_Char, Staloc);
- Set_Ekind (A_Char, E_Constant);
+ Mutate_Ekind (A_Char, E_Constant);
Set_Never_Set_In_Source (A_Char, True);
Set_Is_True_Constant (A_Char, True);
Set_Etype (A_Char, Standard_Character);
@@ -1105,7 +1109,7 @@ package body CStand is
-- Create semantic phase entities
Standard_Void_Type := New_Standard_Entity ("_void_type");
- Set_Ekind (Standard_Void_Type, E_Void);
+ pragma Assert (Ekind (Standard_Void_Type) = E_Void); -- it's the default
Set_Etype (Standard_Void_Type, Standard_Void_Type);
Set_Scope (Standard_Void_Type, Standard_Standard);
@@ -1118,7 +1122,7 @@ package body CStand is
-- type name that is reasonable, but does not overlap any Ada name.
Standard_A_String := New_Standard_Entity ("access_string");
- Set_Ekind (Standard_A_String, E_Access_Type);
+ Mutate_Ekind (Standard_A_String, E_Access_Type);
Set_Scope (Standard_A_String, Standard_Standard);
Set_Etype (Standard_A_String, Standard_A_String);
@@ -1134,7 +1138,7 @@ package body CStand is
(Standard_A_String, Standard_String);
Standard_A_Char := New_Standard_Entity ("access_character");
- Set_Ekind (Standard_A_Char, E_Access_Type);
+ Mutate_Ekind (Standard_A_Char, E_Access_Type);
Set_Scope (Standard_A_Char, Standard_Standard);
Set_Etype (Standard_A_Char, Standard_A_String);
Init_Size (Standard_A_Char, System_Address_Size);
@@ -1149,7 +1153,7 @@ package body CStand is
Standard_Debug_Renaming_Type := New_Standard_Entity ("_renaming_type");
- Set_Ekind (Standard_Debug_Renaming_Type, E_Signed_Integer_Subtype);
+ Mutate_Ekind (Standard_Debug_Renaming_Type, E_Signed_Integer_Subtype);
Set_Scope (Standard_Debug_Renaming_Type, Standard_Standard);
Set_Etype (Standard_Debug_Renaming_Type, Base_Type (Standard_Integer));
Init_Esize (Standard_Debug_Renaming_Type, 0);
@@ -1179,14 +1183,14 @@ package body CStand is
Build_Signed_Integer_Type (Any_Type, Standard_Integer_Size);
Any_Id := New_Standard_Entity ("any id");
- Set_Ekind (Any_Id, E_Variable);
+ Mutate_Ekind (Any_Id, E_Variable);
Set_Scope (Any_Id, Standard_Standard);
Set_Etype (Any_Id, Any_Type);
Init_Esize (Any_Id);
Init_Alignment (Any_Id);
Any_Access := New_Standard_Entity ("an access type");
- Set_Ekind (Any_Access, E_Access_Type);
+ Mutate_Ekind (Any_Access, E_Access_Type);
Set_Scope (Any_Access, Standard_Standard);
Set_Etype (Any_Access, Any_Access);
Init_Size (Any_Access, System_Address_Size);
@@ -1195,7 +1199,7 @@ package body CStand is
(Any_Access, Any_Type);
Any_Character := New_Standard_Entity ("a character type");
- Set_Ekind (Any_Character, E_Enumeration_Type);
+ Mutate_Ekind (Any_Character, E_Enumeration_Type);
Set_Scope (Any_Character, Standard_Standard);
Set_Etype (Any_Character, Any_Character);
Set_Is_Unsigned_Type (Any_Character);
@@ -1206,7 +1210,7 @@ package body CStand is
Set_Scalar_Range (Any_Character, Scalar_Range (Standard_Character));
Any_Array := New_Standard_Entity ("an array type");
- Set_Ekind (Any_Array, E_Array_Type);
+ Mutate_Ekind (Any_Array, E_Array_Type);
Set_Scope (Any_Array, Standard_Standard);
Set_Etype (Any_Array, Any_Array);
Set_Component_Type (Any_Array, Any_Character);
@@ -1214,7 +1218,7 @@ package body CStand is
Make_Dummy_Index (Any_Array);
Any_Boolean := New_Standard_Entity ("a boolean type");
- Set_Ekind (Any_Boolean, E_Enumeration_Type);
+ Mutate_Ekind (Any_Boolean, E_Enumeration_Type);
Set_Scope (Any_Boolean, Standard_Standard);
Set_Etype (Any_Boolean, Standard_Boolean);
Init_Esize (Any_Boolean, Standard_Character_Size);
@@ -1224,7 +1228,7 @@ package body CStand is
Set_Scalar_Range (Any_Boolean, Scalar_Range (Standard_Boolean));
Any_Composite := New_Standard_Entity ("a composite type");
- Set_Ekind (Any_Composite, E_Array_Type);
+ Mutate_Ekind (Any_Composite, E_Array_Type);
Set_Scope (Any_Composite, Standard_Standard);
Set_Etype (Any_Composite, Any_Composite);
Set_Component_Size (Any_Composite, Uint_0);
@@ -1232,21 +1236,21 @@ package body CStand is
Init_Size_Align (Any_Composite);
Any_Discrete := New_Standard_Entity ("a discrete type");
- Set_Ekind (Any_Discrete, E_Signed_Integer_Type);
+ Mutate_Ekind (Any_Discrete, E_Signed_Integer_Type);
Set_Scope (Any_Discrete, Standard_Standard);
Set_Etype (Any_Discrete, Any_Discrete);
Init_Size (Any_Discrete, Standard_Integer_Size);
Set_Elem_Alignment (Any_Discrete);
Any_Fixed := New_Standard_Entity ("a fixed-point type");
- Set_Ekind (Any_Fixed, E_Ordinary_Fixed_Point_Type);
+ Mutate_Ekind (Any_Fixed, E_Ordinary_Fixed_Point_Type);
Set_Scope (Any_Fixed, Standard_Standard);
Set_Etype (Any_Fixed, Any_Fixed);
Init_Size (Any_Fixed, Standard_Integer_Size);
Set_Elem_Alignment (Any_Fixed);
Any_Integer := New_Standard_Entity ("an integer type");
- Set_Ekind (Any_Integer, E_Signed_Integer_Type);
+ Mutate_Ekind (Any_Integer, E_Signed_Integer_Type);
Set_Scope (Any_Integer, Standard_Standard);
Set_Etype (Any_Integer, Standard_Long_Long_Long_Integer);
Init_Size (Any_Integer, Standard_Long_Long_Long_Integer_Size);
@@ -1259,7 +1263,7 @@ package body CStand is
Hb => Intval (High_Bound (Scalar_Range (Standard_Integer))));
Any_Modular := New_Standard_Entity ("a modular type");
- Set_Ekind (Any_Modular, E_Modular_Integer_Type);
+ Mutate_Ekind (Any_Modular, E_Modular_Integer_Type);
Set_Scope (Any_Modular, Standard_Standard);
Set_Etype (Any_Modular, Standard_Long_Long_Long_Integer);
Init_Size (Any_Modular, Standard_Long_Long_Long_Integer_Size);
@@ -1267,14 +1271,14 @@ package body CStand is
Set_Is_Unsigned_Type (Any_Modular);
Any_Numeric := New_Standard_Entity ("a numeric type");
- Set_Ekind (Any_Numeric, E_Signed_Integer_Type);
+ Mutate_Ekind (Any_Numeric, E_Signed_Integer_Type);
Set_Scope (Any_Numeric, Standard_Standard);
Set_Etype (Any_Numeric, Standard_Long_Long_Long_Integer);
Init_Size (Any_Numeric, Standard_Long_Long_Long_Integer_Size);
Set_Elem_Alignment (Any_Numeric);
Any_Real := New_Standard_Entity ("a real type");
- Set_Ekind (Any_Real, E_Floating_Point_Type);
+ Mutate_Ekind (Any_Real, E_Floating_Point_Type);
Set_Scope (Any_Real, Standard_Standard);
Set_Etype (Any_Real, Standard_Long_Long_Float);
Init_Size (Any_Real,
@@ -1282,14 +1286,14 @@ package body CStand is
Set_Elem_Alignment (Any_Real);
Any_Scalar := New_Standard_Entity ("a scalar type");
- Set_Ekind (Any_Scalar, E_Signed_Integer_Type);
+ Mutate_Ekind (Any_Scalar, E_Signed_Integer_Type);
Set_Scope (Any_Scalar, Standard_Standard);
Set_Etype (Any_Scalar, Any_Scalar);
Init_Size (Any_Scalar, Standard_Integer_Size);
Set_Elem_Alignment (Any_Scalar);
Any_String := New_Standard_Entity ("a string type");
- Set_Ekind (Any_String, E_Array_Type);
+ Mutate_Ekind (Any_String, E_Array_Type);
Set_Scope (Any_String, Standard_Standard);
Set_Etype (Any_String, Any_String);
Set_Component_Type (Any_String, Any_Character);
@@ -1401,7 +1405,7 @@ package body CStand is
Universal_Fixed := New_Standard_Entity ("universal_fixed");
Decl := New_Node (N_Full_Type_Declaration, Stloc);
Set_Defining_Identifier (Decl, Universal_Fixed);
- Set_Ekind (Universal_Fixed, E_Ordinary_Fixed_Point_Type);
+ Mutate_Ekind (Universal_Fixed, E_Ordinary_Fixed_Point_Type);
Set_Etype (Universal_Fixed, Universal_Fixed);
Set_Scope (Universal_Fixed, Standard_Standard);
Init_Size (Universal_Fixed, Standard_Long_Long_Integer_Size);
@@ -1446,7 +1450,7 @@ package body CStand is
Set_Type_Definition (Parent (Standard_Duration), Tdef_Node);
- Set_Ekind (Standard_Duration, E_Ordinary_Fixed_Point_Type);
+ Mutate_Ekind (Standard_Duration, E_Ordinary_Fixed_Point_Type);
Set_Etype (Standard_Duration, Standard_Duration);
if Duration_32_Bits_On_Target then
@@ -1491,38 +1495,40 @@ 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 ("exception");
- Set_Ekind (Standard_Exception_Type, E_Record_Type);
- Set_Etype (Standard_Exception_Type, Standard_Exception_Type);
- Set_Scope (Standard_Exception_Type, Standard_Standard);
- Set_Stored_Constraint
- (Standard_Exception_Type, No_Elist);
- Init_Size_Align (Standard_Exception_Type);
- Set_Size_Known_At_Compile_Time
- (Standard_Exception_Type, True);
-
- Make_Component
- (Standard_Exception_Type, Standard_Boolean, "Not_Handled_By_Others");
- Make_Component
- (Standard_Exception_Type, Standard_Character, "Lang");
- Make_Component
- (Standard_Exception_Type, Standard_Natural, "Name_Length");
- Make_Component
- (Standard_Exception_Type, Standard_A_Char, "Full_Name");
- Make_Component
- (Standard_Exception_Type, Standard_A_Char, "HTable_Ptr");
- Make_Component
- (Standard_Exception_Type, Standard_A_Char, "Foreign_Data");
- Make_Component
- (Standard_Exception_Type, Standard_A_Char, "Raise_Hook");
-
- -- Build tree for record declaration, for use by the back-end
-
- declare
- Comp_List : List_Id;
- Comp : Entity_Id;
+ Build_Exception_Type : declare
+ Comp_List : List_Id;
+ Comp : Entity_Id;
begin
+ Standard_Exception_Type := New_Standard_Entity ("exception");
+ Mutate_Ekind (Standard_Exception_Type, E_Record_Type);
+ Set_Etype (Standard_Exception_Type, Standard_Exception_Type);
+ Set_Scope (Standard_Exception_Type, Standard_Standard);
+ Set_Stored_Constraint
+ (Standard_Exception_Type, No_Elist);
+ Init_Size_Align (Standard_Exception_Type);
+ Set_Size_Known_At_Compile_Time
+ (Standard_Exception_Type, True);
+
+ Make_Aliased_Component (Standard_Exception_Type, Standard_Boolean,
+ "Not_Handled_By_Others");
+ Make_Aliased_Component (Standard_Exception_Type, Standard_Character,
+ "Lang");
+ Make_Aliased_Component (Standard_Exception_Type, Standard_Natural,
+ "Name_Length");
+ Make_Aliased_Component (Standard_Exception_Type, Standard_Address,
+ "Full_Name");
+ Make_Aliased_Component (Standard_Exception_Type, Standard_A_Char,
+ "HTable_Ptr");
+ Make_Aliased_Component (Standard_Exception_Type, Standard_Address,
+ "Foreign_Data");
+ Make_Aliased_Component (Standard_Exception_Type, Standard_A_Char,
+ "Raise_Hook");
+
+ Layout_Type (Standard_Exception_Type);
+
+ -- Build tree for record declaration, for use by the back-end
+
Comp := First_Entity (Standard_Exception_Type);
Comp_List := New_List;
while Present (Comp) loop
@@ -1531,9 +1537,9 @@ package body CStand is
Defining_Identifier => Comp,
Component_Definition =>
Make_Component_Definition (Stloc,
- Aliased_Present => False,
- Subtype_Indication => New_Occurrence_Of (Etype (Comp),
- Stloc))),
+ Aliased_Present => True,
+ Subtype_Indication =>
+ New_Occurrence_Of (Etype (Comp), Stloc))),
Comp_List);
Next_Entity (Comp);
@@ -1543,15 +1549,13 @@ package body CStand is
Defining_Identifier => Standard_Exception_Type,
Type_Definition =>
Make_Record_Definition (Stloc,
- End_Label => Empty,
+ End_Label => Empty,
Component_List =>
Make_Component_List (Stloc,
Component_Items => Comp_List)));
- end;
-
- Append (Decl, Decl_S);
- Layout_Type (Standard_Exception_Type);
+ Append (Decl, Decl_S);
+ end Build_Exception_Type;
-- Create declarations of standard exceptions
@@ -1572,7 +1576,7 @@ package body CStand is
Decl := New_Node (N_Exception_Renaming_Declaration, Stloc);
E_Id := Standard_Entity (S_Numeric_Error);
- Set_Ekind (E_Id, E_Exception);
+ Mutate_Ekind (E_Id, E_Exception);
Set_Etype (E_Id, Standard_Exception_Type);
Set_Is_Public (E_Id);
Set_Renamed_Entity (E_Id, Standard_Entity (S_Constraint_Error));
@@ -1590,7 +1594,7 @@ package body CStand is
Abort_Signal := New_Standard_Entity;
Set_Chars (Abort_Signal, Name_uAbort_Signal);
- Set_Ekind (Abort_Signal, E_Exception);
+ Mutate_Ekind (Abort_Signal, E_Exception);
Set_Etype (Abort_Signal, Standard_Exception_Type);
Set_Scope (Abort_Signal, Standard_Standard);
Set_Is_Public (Abort_Signal, True);
@@ -1605,24 +1609,24 @@ package body CStand is
Standard_Op_Rotate_Left := New_Standard_Entity;
Set_Chars (Standard_Op_Rotate_Left, Name_Rotate_Left);
- Set_Ekind (Standard_Op_Rotate_Left, E_Operator);
+ Mutate_Ekind (Standard_Op_Rotate_Left, E_Operator);
Standard_Op_Rotate_Right := New_Standard_Entity;
Set_Chars (Standard_Op_Rotate_Right, Name_Rotate_Right);
- Set_Ekind (Standard_Op_Rotate_Right, E_Operator);
+ Mutate_Ekind (Standard_Op_Rotate_Right, E_Operator);
Standard_Op_Shift_Left := New_Standard_Entity;
Set_Chars (Standard_Op_Shift_Left, Name_Shift_Left);
- Set_Ekind (Standard_Op_Shift_Left, E_Operator);
+ Mutate_Ekind (Standard_Op_Shift_Left, E_Operator);
Standard_Op_Shift_Right := New_Standard_Entity;
Set_Chars (Standard_Op_Shift_Right, Name_Shift_Right);
- Set_Ekind (Standard_Op_Shift_Right, E_Operator);
+ Mutate_Ekind (Standard_Op_Shift_Right, E_Operator);
Standard_Op_Shift_Right_Arithmetic := New_Standard_Entity;
Set_Chars (Standard_Op_Shift_Right_Arithmetic,
Name_Shift_Right_Arithmetic);
- Set_Ekind (Standard_Op_Shift_Right_Arithmetic,
+ Mutate_Ekind (Standard_Op_Shift_Right_Arithmetic,
E_Operator);
-- Create standard operator declarations
@@ -1677,7 +1681,7 @@ package body CStand is
New_Ent : constant Entity_Id := New_Copy (E);
begin
- Set_Ekind (E, K);
+ Mutate_Ekind (E, K);
Set_Is_Constrained (E, True);
Set_Is_First_Subtype (E, True);
Set_Etype (E, New_Ent);
@@ -1707,11 +1711,11 @@ package body CStand is
return Ident_Node;
end Identifier_For;
- --------------------
- -- Make_Component --
- --------------------
+ ----------------------------
+ -- Make_Aliased_Component --
+ ----------------------------
- procedure Make_Component
+ procedure Make_Aliased_Component
(Rec : Entity_Id;
Typ : Entity_Id;
Nam : String)
@@ -1719,13 +1723,15 @@ package body CStand is
Id : constant Entity_Id := New_Standard_Entity (Nam);
begin
- Set_Ekind (Id, E_Component);
+ Mutate_Ekind (Id, E_Component);
Set_Etype (Id, Typ);
Set_Scope (Id, Rec);
Init_Component_Location (Id);
Set_Original_Record_Component (Id, Id);
+ Set_Is_Aliased (Id);
+ Set_Is_Independent (Id);
Append_Entity (Id, Rec);
- end Make_Component;
+ end Make_Aliased_Component;
-----------------
-- Make_Formal --
@@ -1735,7 +1741,7 @@ package body CStand is
Formal : constant Entity_Id := New_Standard_Entity (Nam);
begin
- Set_Ekind (Formal, E_In_Parameter);
+ Mutate_Ekind (Formal, E_In_Parameter);
Set_Mechanism (Formal, Default_Mechanism);
Set_Scope (Formal, Standard_Standard);
Set_Etype (Formal, Typ);
@@ -1765,7 +1771,7 @@ package body CStand is
begin
Set_Is_Pure (Ident_Node, True);
- Set_Ekind (Ident_Node, E_Operator);
+ Mutate_Ekind (Ident_Node, E_Operator);
Set_Etype (Ident_Node, Typ);
Set_Scope (Ident_Node, Standard_Standard);
Set_Homonym (Ident_Node, Get_Name_Entity_Id (Op));
diff --git a/gcc/ada/cstand.ads b/gcc/ada/cstand.ads
index f2873ef..78bddc6 100644
--- a/gcc/ada/cstand.ads
+++ b/gcc/ada/cstand.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute 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 8072320..af794c7 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-2020, Free Software Foundation, Inc. *
+ * Copyright (C) 1992-2021, Free Software Foundation, Inc. *
* *
* GNAT is free software; you can redistribute 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 72d6a5b..ebb74ca 100644
--- a/gcc/ada/ctrl_c.c
+++ b/gcc/ada/ctrl_c.c
@@ -6,7 +6,7 @@
* *
* C Implementation File *
* *
- * Copyright (C) 2002-2020, Free Software Foundation, Inc. *
+ * Copyright (C) 2002-2021, Free Software Foundation, Inc. *
* *
* GNAT is free software; you can redistribute 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 2c7c712..5245feb3 100644
--- a/gcc/ada/debug.adb
+++ b/gcc/ada/debug.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -112,7 +112,7 @@ 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 Print Atree statistics
+ -- 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
@@ -125,7 +125,7 @@ package body Debug is
-- 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
+ -- d.N
-- d.O Dump internal SCO tables
-- d.P Previous (non-optimized) handling of length comparisons
-- d.Q Previous (incomplete) style check for binary operators
@@ -140,13 +140,13 @@ package body Debug is
-- d.Z Do not enable expansion in configurable run-time mode
-- d_a Stop elaboration checks on accept or select statement
- -- d_b
+ -- d_b Use designated type model under No_Dynamic_Accessibility_Checks
-- d_c CUDA compilation : compile for the host
-- d_d
-- d_e Ignore entry calls and requeue statements for elaboration
-- d_f Issue info messages related to GNATprove usage
- -- d_g
- -- d_h
+ -- d_g Disable large static aggregates
+ -- d_h Disable the use of (perfect) hash functions for enumeration Value
-- d_i Ignore activations and calls to instances for elaboration
-- d_j Read JSON files and populate Repinfo tables (opposite of -gnatRjs)
-- d_k
@@ -160,11 +160,11 @@ package body Debug is
-- d_s Stop elaboration checks on synchronous suspension
-- d_t
-- d_u
- -- d_v
+ -- d_v Enable additional checks and debug printouts in Atree
-- d_w
- -- d_x
+ -- d_x Disable inline expansion of Image attribute for enumeration types
-- d_y
- -- d_z Enable Put_Image on tagged types
+ -- d_z
-- d_A Stop generation of ALI file
-- d_B Warn on build-in-place function calls
@@ -186,7 +186,7 @@ package body Debug is
-- d_R
-- d_S
-- d_T Output trace information on invocation path recording
- -- d_U
+ -- d_U Disable prepending messages with "error:".
-- d_V Enable verifications on the expanded tree
-- d_W
-- d_X
@@ -830,8 +830,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 Print Atree statistics
-
-- 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
@@ -900,10 +898,6 @@ package body Debug is
-- d.M Relaxed RM semantics. This flag sets Opt.Relaxed_RM_Semantics
-- See Opt.Relaxed_RM_Semantics for more details.
- -- d.N Enlarge entities by one node (but don't attempt to use this extra
- -- node for storage of any flags or fields). This can be used to do
- -- experiments on the impact of increasing entity sizes.
-
-- d.O Dump internal SCO tables. Before outputting the SCO information to
-- the ALI file, the internal SCO tables (SCO_Table/SCO_Unit_Table)
-- are dumped for debugging purposes.
@@ -962,6 +956,10 @@ package body Debug is
-- behavior is similar to that of No_Entry_Calls_In_Elaboration_Code,
-- but does not penalize actual entry calls in elaboration code.
+ -- d_b When the restriction No_Dynamic_Accessibility_Checks is enabled,
+ -- use the simple "designated type" accessibility model, instead of
+ -- using the implicit level of the anonymous access type declaration.
+
-- d_e The compiler ignores simple entry calls, asynchronous transfer of
-- control, conditional entry calls, timed entry calls, and requeue
-- statements in both the static and dynamic elaboration models.
@@ -971,6 +969,13 @@ package body Debug is
-- beginners find them confusing. Set automatically by GNATprove when
-- switch --info is used.
+ -- d_g Disable large static aggregates. The maximum size for a static
+ -- aggregate will be fairly modest, which is useful if the compiler
+ -- is using too much memory and time at compile time.
+
+ -- d_h The compiler does not make use of (perfect) hash functions in the
+ -- implementation of the Value attribute for enumeration types.
+
-- d_i The compiler ignores calls and task activations when they target a
-- subprogram or task type defined in an external instance for both
-- the static and dynamic elaboration models.
@@ -987,8 +992,10 @@ 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_v Enable additional checks and debug printouts in Atree
+
+ -- d_x The compiler does not expand in line the Image attribute for user-
+ -- defined enumeration types and the standard boolean type.
-- d_A Do not generate ALI files by setting Opt.Disable_ALI_File.
@@ -1011,6 +1018,9 @@ package body Debug is
-- d_T The compiler outputs trace information to standard output whenever
-- an invocation path is recorded.
+ -- d_U Disable prepending 'error:' to error messages. This used to be the
+ -- default and can be seen as the opposite of -gnatU.
+
-- d_V Enable verification of the expanded code before calling the backend
-- and generate error messages on each inconsistency found.
@@ -1091,7 +1101,7 @@ package body Debug is
-- issues (e.g., assuming that a low bound of an array parameter
-- of an unconstrained subtype belongs to the index subtype).
- -- d.9 Enable build-in-place for function calls returning some nonlimited
+ -- d.9 Disable build-in-place for function calls returning nonlimited
-- types.
------------------------------------------
diff --git a/gcc/ada/debug.ads b/gcc/ada/debug.ads
index 83ad187..c8f2c22 100644
--- a/gcc/ada/debug.ads
+++ b/gcc/ada/debug.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute 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 d3a1424..8a8ccc6 100644
--- a/gcc/ada/debug_a.adb
+++ b/gcc/ada/debug_a.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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,11 +23,12 @@
-- --
------------------------------------------------------------------------------
-with Atree; use Atree;
-with Debug; use Debug;
-with Sinfo; use Sinfo;
-with Sinput; use Sinput;
-with Output; use Output;
+with Atree; use Atree;
+with Debug; use Debug;
+with Sinfo; use Sinfo;
+with Sinfo.Nodes; use Sinfo.Nodes;
+with Sinput; use Sinput;
+with Output; use Output;
package body Debug_A is
@@ -46,6 +47,12 @@ package body Debug_A is
-- recursion levels, we just don't reset the right value on exit, which
-- is not crucial, since this is only for debugging.
+ -- Note that Current_Error_Node must be maintained unconditionally (not
+ -- only when Debug_Flag_A is True), because we want to print a correct sloc
+ -- in bug boxes. Also, Current_Error_Node is not just used for printing bug
+ -- boxes. For example, an incorrect Current_Error_Node can cause some code
+ -- in Rtsfind to malfunction.
+
-----------------------
-- Local Subprograms --
-----------------------
@@ -75,8 +82,6 @@ package body Debug_A is
-- Now push the new element
- -- Why is this done unconditionally???
-
Debug_A_Depth := Debug_A_Depth + 1;
if Debug_A_Depth <= Max_Node_Ids then
@@ -103,8 +108,6 @@ package body Debug_A is
-- We look down the stack to find something with a decent Sloc. (If
-- we find nothing, just leave it unchanged which is not so terrible)
- -- This seems nasty overhead for the normal case ???
-
for J in reverse 1 .. Integer'Min (Max_Node_Ids, Debug_A_Depth) loop
if Sloc (Node_Ids (J)) > No_Location then
Current_Error_Node := Node_Ids (J);
@@ -130,8 +133,6 @@ package body Debug_A is
procedure Debug_Output_Astring is
Vbars : constant String := "|||||||||||||||||||||||||";
- -- Should be constant, removed because of GNAT 1.78 bug ???
-
begin
if Debug_A_Depth > Vbars'Length then
for I in Vbars'Length .. Debug_A_Depth loop
diff --git a/gcc/ada/debug_a.ads b/gcc/ada/debug_a.ads
index d352525..1c165de 100644
--- a/gcc/ada/debug_a.ads
+++ b/gcc/ada/debug_a.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute 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/Makefile b/gcc/ada/doc/Makefile
index 9a435eb..4adfd36 100644
--- a/gcc/ada/doc/Makefile
+++ b/gcc/ada/doc/Makefile
@@ -14,7 +14,7 @@ ALLSPHINXOPTS = $(PAPEROPT_$(PAPER)) $(SPHINXOPTS) \
-c $(SOURCEDIR)/share \
-d $(BUILDDIR)/$*/doctrees \
$(SOURCEDIR)
-DOC_LIST=gnat_rm gnat_ugn
+DOC_LIST=gnat_rm gnat_ugn gnat-style
FMT_LIST=html pdf txt info
.PHONY: help clean
diff --git a/gcc/ada/doc/gnat-style.rst b/gcc/ada/doc/gnat-style.rst
new file mode 100644
index 0000000..527e7ba
--- /dev/null
+++ b/gcc/ada/doc/gnat-style.rst
@@ -0,0 +1,691 @@
+GNAT Coding Style: A Guide for GNAT Developers
+==============================================
+
+General
+-------
+
+Most of GNAT is written in Ada using a consistent style to ensure
+readability of the code. This document has been written to help
+maintain this consistent style, while having a large group of developers
+work on the compiler.
+
+For the coding style in the C parts of the compiler and run time,
+see the GNU Coding Guidelines.
+
+This document is structured after the Ada Reference Manual.
+Those familiar with that document should be able to quickly
+lookup style rules for particular constructs.
+
+Lexical Elements
+----------------
+
+Character Set and Separators
+****************************
+
+.. index:: Character set
+.. index:: ASCII
+.. index:: Separators
+.. index:: End-of-line
+.. index:: Line length
+.. index:: Indentation
+
+* The character set used should be plain 7-bit ASCII.
+ The only separators allowed are space and the end-of-line sequence.
+ No other control character or format effector (such as ``HT``,
+ ``VT``, ``FF`` )
+ should be used.
+ The normal end-of-line sequence is used, which may be
+ ``LF``, ``CR/LF`` or ``CR``,
+ depending on the host system. An optional ``SUB``
+ ( ``16#1A#`` ) may be present as the
+ last character in the file on hosts using that character as file terminator.
+
+* Files that are checked in or distributed should be in host format.
+
+* A line should never be longer than 79 characters, not counting the line
+ separator.
+
+* Lines must not have trailing blanks.
+
+* Indentation is 3 characters per level for ``if`` statements, loops, and
+ ``case`` statements.
+ For exact information on required spacing between lexical
+ elements, see file style.adb.
+
+ .. index:: style.adb file
+
+Identifiers
+***********
+
+* Identifiers will start with an upper case letter, and each letter following
+ an underscore will be upper case.
+
+ .. index:: Casing (for identifiers)
+
+ Short acronyms may be all upper case.
+ All other letters are lower case.
+ An exception is for identifiers matching a foreign language. In particular,
+ we use all lower case where appropriate for C.
+
+* Use underscores to separate words in an identifier.
+
+ .. index:: Underscores
+
+* Try to limit your use of abbreviations in identifiers.
+ It is ok to make a few abbreviations, explain what they mean, and then
+ use them frequently, but don't use lots of obscure abbreviations. An
+ example is the ``ALI`` word which stands for Ada Library
+ Information and is by convention always written in upper-case when
+ used in entity names.
+
+ .. code-block:: ada
+
+ procedure Find_ALI_Files;
+
+* Don't use the variable name ``I``, use ``J`` instead; ``I`` is too
+ easily confused with ``1`` in some fonts. Similarly don't use the
+ variable ``O``, which is too easily mistaken for the number ``0``.
+
+Numeric Literals
+****************
+
+* Numeric literals should include underscores where helpful for
+ readability.
+
+ .. index:: Underscores
+
+ .. code-block:: ada
+
+ 1_000_000
+ 16#8000_0000#
+ 3.14159_26535_89793_23846
+
+Reserved Words
+**************
+
+* Reserved words use all lower case.
+
+ .. index:: Casing (for reserved words)
+
+ .. code-block:: ada
+
+ return else
+
+* The words ``Access``, ``Delta`` and ``Digits`` are
+ capitalized when used as attribute_designator.
+
+Comments
+********
+
+* A comment starts with ``--`` followed by two spaces.
+ The only exception to this rule (i.e. one space is tolerated) is when the
+ comment ends with a single space followed by ``--``.
+ It is also acceptable to have only one space between ``--`` and the start
+ of the comment when the comment is at the end of a line,
+ after some Ada code.
+
+* Every sentence in a comment should start with an upper-case letter (including
+ the first letter of the comment).
+
+ .. index:: Casing (in comments)
+
+* When declarations are commented with 'hanging' comments, i.e.
+ comments after the declaration, there is no blank line before the
+ comment, and if it is absolutely necessary to have blank lines within
+ the comments, e.g. to make paragraph separations within a single comment,
+ these blank lines *do* have a ``--`` (unlike the
+ normal rule, which is to use entirely blank lines for separating
+ comment paragraphs). The comment starts at same level of indentation
+ as code it is commenting.
+
+ .. index:: Blank lines (in comments)
+ .. index:: Indentation
+
+ .. code-block:: ada
+
+ z : Integer;
+ -- Integer value for storing value of z
+ --
+ -- The previous line was a blank line.
+
+* Comments that are dubious or incomplete, or that comment on possibly
+ wrong or incomplete code, should be preceded or followed by ``???``.
+
+* Comments in a subprogram body must generally be surrounded by blank lines.
+ An exception is a comment that follows a line containing a single keyword
+ ( ``begin``, ``else``, ``loop`` ):
+
+ .. code-block:: ada
+
+ begin
+ -- Comment for the next statement
+
+ A := 5;
+
+ -- Comment for the B statement
+
+ B := 6;
+ end;
+
+* In sequences of statements, comments at the end of the lines should be
+ aligned.
+
+ .. index:: Alignment (in comments)
+
+ .. code-block:: ada
+
+ My_Identifier := 5; -- First comment
+ Other_Id := 6; -- Second comment
+
+* Short comments that fit on a single line are *not* ended with a
+ period. Comments taking more than a line are punctuated in the normal
+ manner.
+
+* Comments should focus on *why* instead of *what*.
+ Descriptions of what subprograms do go with the specification.
+
+* Comments describing a subprogram spec should specifically mention the
+ formal argument names. General rule: write a comment that does not
+ depend on the names of things. The names are supplementary, not
+ sufficient, as comments.
+
+* *Do not* put two spaces after periods in comments.
+
+Declarations and Types
+----------------------
+
+* In entity declarations, colons must be surrounded by spaces. Colons
+ should be aligned.
+
+ .. index:: Alignment (in declarations)
+
+ .. code-block:: ada
+
+ Entity1 : Integer;
+ My_Entity : Integer;
+
+* Declarations should be grouped in a logical order.
+ Related groups of declarations may be preceded by a header comment.
+
+* All local subprograms in a subprogram or package body should be declared
+ before the first local subprogram body.
+
+* Do not declare local entities that hide global entities.
+
+ .. index:: Hiding of outer entities
+
+* Do not declare multiple variables in one declaration that spans lines.
+ Start a new declaration on each line, instead.
+
+* The defining_identifiers of global declarations serve as
+ comments of a sort. So don't choose terse names, but look for names
+ that give useful information instead.
+
+* Local names can be shorter, because they are used only within
+ one context, where comments explain their purpose.
+
+* When starting an initialization or default expression on the line that follows
+ the declaration line, use 2 characters for indentation.
+
+ .. code-block:: ada
+
+ Entity1 : Integer :=
+ Function_Name (Parameters, For_Call);
+
+* If an initialization or default expression needs to be continued on subsequent
+ lines, the continuations should be indented from the start of the expression.
+
+ .. code-block:: ada
+
+ Entity1 : Integer := Long_Function_Name
+ (parameters for call);
+
+Expressions and Names
+---------------------
+
+* Every operator must be surrounded by spaces. An exception is that
+ this rule does not apply to the exponentiation operator, for which
+ there are no specific layout rules. The reason for this exception
+ is that sometimes it makes clearer reading to leave out the spaces
+ around exponentiation.
+
+ .. index:: Operators
+
+ .. code-block:: ada
+
+ E := A * B**2 + 3 * (C - D);
+
+* Use parentheses where they clarify the intended association of operands
+ with operators:
+
+ .. index:: Parenthesization of expressions
+
+ .. code-block:: ada
+
+ (A / B) * C
+
+Statements
+----------
+
+Simple and Compound Statements
+******************************
+
+* Use only one statement or label per line.
+
+* A longer sequence_of_statements may be divided in logical
+ groups or separated from surrounding code using a blank line.
+
+
+If Statements
+*************
+
+* When the ``if``, ``elsif`` or ``else`` keywords fit on the
+ same line with the condition and the ``then`` keyword, then the
+ statement is formatted as follows:
+
+ .. index:: Alignment (in an if statement)
+
+ .. code-block:: ada
+
+ if condition then
+ ...
+ elsif condition then
+ ...
+ else
+ ...
+ end if;
+
+ When the above layout is not possible, ``then`` should be aligned
+ with ``if``, and conditions should preferably be split before an
+ ``and`` or ``or`` keyword a follows:
+
+ .. code-block:: ada
+
+ if long_condition_that_has_to_be_split
+ and then continued_on_the_next_line
+ then
+ ...
+ end if;
+
+ The ``elsif``, ``else`` and ``end if`` always line up with
+ the ``if`` keyword. The preferred location for splitting the line
+ is before ``and`` or ``or``. The continuation of a condition is
+ indented with two spaces or as many as needed to make nesting clear.
+ As an exception, if conditions are closely related either of the
+ following is allowed:
+
+ .. code-block:: ada
+
+ if x = lakdsjfhlkashfdlkflkdsalkhfsalkdhflkjdsahf
+ or else
+ x = asldkjhalkdsjfhhfd
+ or else
+ x = asdfadsfadsf
+ then
+ ...
+ end if;
+
+ if x = lakdsjfhlkashfdlkflkdsalkhfsalkdhflkjdsahf or else
+ x = asldkjhalkdsjfhhfd or else
+ x = asdfadsfadsf
+ then
+ ...
+ end if;
+
+* Conditions should use short-circuit forms ( ``and then``,
+ ``or else`` ), except when the operands are boolean variables
+ or boolean constants.
+
+ .. index:: Short-circuit forms
+
+* Complex conditions in ``if`` statements are indented two characters:
+
+ .. index:: Indentation (in if statements)
+
+ .. code-block:: ada
+
+ if this_complex_condition
+ and then that_other_one
+ and then one_last_one
+ then
+ ...
+ end if;
+
+ There are some cases where complex conditionals can be laid out
+ in manners that do not follow these rules to preserve better
+ parallelism between branches, e.g.
+
+ .. code-block:: ada
+
+ if xyz.abc (gef) = 'c'
+ or else
+ xyz.abc (gef) = 'x'
+ then
+ ...
+ end if;
+
+* Every ``if`` block is preceded and followed by a blank line, except
+ where it begins or ends a sequence_of_statements.
+
+ .. index:: Blank lines (in an if statement)
+
+ .. code-block:: ada
+
+ A := 5;
+
+ if A = 5 then
+ null;
+ end if;
+
+ A := 6;
+
+Case Statements
+***************
+
+* Layout is as below. For long ``case`` statements, the extra indentation
+ can be saved by aligning the ``when`` clauses with the opening ``case``.
+
+ .. code-block:: ada
+
+ case expression is
+ when condition =>
+ ...
+ when condition =>
+ ...
+ end case;
+
+Loop Statements
+***************
+
+* When possible, have ``for`` or ``while`` on one line with the
+ condition and the ``loop`` keyword.
+
+ .. code-block:: ada
+
+ for J in S'Range loop
+ ...
+ end loop;
+
+ If the condition is too long, split the condition (see 'If
+ statements' above) and align ``loop`` with the ``for`` or
+ ``while`` keyword.
+
+ .. index:: Alignment (in a loop statement)
+
+ .. code-block:: ada
+
+ while long_condition_that_has_to_be_split
+ and then continued_on_the_next_line
+ loop
+ ...
+ end loop;
+
+ If the loop_statement has an identifier, it is laid out as follows:
+
+ .. code-block:: ada
+
+ Outer : while not condition loop
+ ...
+ end Outer;
+
+Block Statements
+****************
+
+* The ``declare`` (optional), ``begin`` and ``end`` words
+ are aligned, except when the block_statement is named. There
+ is a blank line before the ``begin`` keyword:
+
+ .. index:: Alignment (in a block statement)
+
+ .. code-block:: ada
+
+ Some_Block : declare
+ ...
+
+ begin
+ ...
+ end Some_Block;
+
+Subprograms
+-----------
+
+Subprogram Declarations
+***********************
+
+* Do not write the ``in`` for parameters.
+
+ .. code-block:: ada
+
+ function Length (S : String) return Integer;
+
+* When the declaration line for a procedure or a function is too long to fit
+ the entire declaration (including the keyword procedure or function) on a
+ single line, then fold it, putting a single parameter on a line, aligning
+ the colons, as in:
+
+ .. code-block:: ada
+
+ procedure Set_Heading
+ (Source : String;
+ Count : Natural;
+ Pad : Character := Space;
+ Fill : Boolean := True);
+
+ In the case of a function, if the entire spec does not fit on one line, then
+ the return may appear after the last parameter, as in:
+
+ .. code-block:: ada
+
+ function Head
+ (Source : String;
+ Count : Natural;
+ Pad : Character := Space) return String;
+
+ Or it may appear on its own as a separate line. This form is preferred when
+ putting the return on the same line as the last parameter would result in
+ an overlong line. The return type may optionally be aligned with the types
+ of the parameters (usually we do this aligning if it results only in a small
+ number of extra spaces, and otherwise we don't attempt to align). So two
+ alternative forms for the above spec are:
+
+ .. code-block:: ada
+
+ function Head
+ (Source : String;
+ Count : Natural;
+ Pad : Character := Space)
+ return String;
+
+ function Head
+ (Source : String;
+ Count : Natural;
+ Pad : Character := Space)
+ return String;
+
+Subprogram Bodies
+*****************
+
+* Function and procedure bodies should usually be sorted alphabetically. Do
+ not attempt to sort them in some logical order by functionality. For a
+ sequence of subprogram specs, a general alphabetical sorting is also
+ usually appropriate, but occasionally it makes sense to group by major
+ function, with appropriate headers.
+
+* All subprograms have a header giving the function name, with the following
+ format:
+
+ .. code-block:: ada
+
+ -----------------
+ -- My_Function --
+ -----------------
+
+ procedure My_Function is
+ begin
+ ...
+ end My_Function;
+
+ Note that the name in the header is preceded by a single space,
+ not two spaces as for other comments. These headers are used on
+ nested subprograms as well as outer level subprograms. They may
+ also be used as headers for sections of comments, or collections
+ of declarations that are related.
+
+* Every subprogram body must have a preceding subprogram_declaration,
+ which includes proper client documentation so that you do not need to
+ read the subprogram body in order to understand what the subprogram does and
+ how to call it. All subprograms should be documented, without exceptions.
+
+ .. index:: Blank lines (in subprogram bodies)
+
+* A sequence of declarations may optionally be separated from the following
+ begin by a blank line. Just as we optionally allow blank lines in general
+ between declarations, this blank line should be present only if it improves
+ readability. Generally we avoid this blank line if the declarative part is
+ small (one or two lines) and the body has no blank lines, and we include it
+ if the declarative part is long or if the body has blank lines.
+
+* If the declarations in a subprogram contain at least one nested
+ subprogram body, then just before the ``begin`` of the enclosing
+ subprogram, there is a comment line and a blank line:
+
+ .. code-block:: ada
+
+ -- Start of processing for Enclosing_Subprogram
+
+ begin
+ ...
+ end Enclosing_Subprogram;
+
+* When nested subprograms are present, variables that are referenced by any
+ nested subprogram should precede the nested subprogram specs. For variables
+ that are not referenced by nested procedures, the declarations can either also
+ be before any of the nested subprogram specs (this is the old style, more
+ generally used). Or then can come just before the begin, with a header. The
+ following example shows the two possible styles:
+
+ .. code-block:: ada
+
+ procedure Style1 is
+ Var_Referenced_In_Nested : Integer;
+ Var_Referenced_Only_In_Style1 : Integer;
+
+ proc Nested;
+ -- Comments ...
+
+ ------------
+ -- Nested --
+ ------------
+
+ procedure Nested is
+ begin
+ ...
+ end Nested;
+
+ -- Start of processing for Style1
+
+ begin
+ ...
+ end Style1;
+
+ procedure Style2 is
+ Var_Referenced_In_Nested : Integer;
+
+ proc Nested;
+ -- Comments ...
+
+ ------------
+ -- Nested --
+ ------------
+
+ procedure Nested is
+ begin
+ ...
+ end Nested;
+
+ -- Local variables
+
+ Var_Referenced_Only_In_Style2 : Integer;
+
+ -- Start of processing for Style2
+
+ begin
+ ...
+ end Style2;
+
+ For new code, we generally prefer Style2, but we do not insist on
+ modifying all legacy occurrences of Style1, which is still much
+ more common in the sources.
+
+Packages and Visibility Rules
+-----------------------------
+
+* All program units and subprograms have their name at the end:
+
+ .. code-block:: ada
+
+ package P is
+ ...
+ end P;
+
+* We will use the style of ``use`` -ing ``with`` -ed packages, with
+ the context clauses looking like:
+
+ .. index:: use clauses
+
+ .. code-block:: ada
+
+ with A; use A;
+ with B; use B;
+
+* Names declared in the visible part of packages should be
+ unique, to prevent name clashes when the packages are ``use`` d.
+
+ .. index:: Name clash avoidance
+
+ .. code-block:: ada
+
+ package Entity is
+ type Entity_Kind is ...;
+ ...
+ end Entity;
+
+* After the file header comment, the context clause and unit specification
+ should be the first thing in a program_unit.
+
+* Preelaborate, Pure and Elaborate_Body pragmas should be added right after the
+ package name, indented an extra level and using the parameterless form:
+
+ .. code-block:: ada
+
+ package Preelaborate_Package is
+ pragma Preelaborate;
+ ...
+ end Preelaborate_Package;
+
+Program Structure and Compilation Issues
+----------------------------------------
+
+* Every GNAT source file must be compiled with the ``-gnatg``
+ switch to check the coding style.
+ (Note that you should look at
+ style.adb to see the lexical rules enforced by ``-gnatg`` ).
+
+ .. index:: -gnatg option (to gcc)
+ .. index:: style.adb file
+
+* Each source file should contain only one compilation unit.
+
+* Filenames should be 8 or fewer characters, followed by the ``.adb``
+ extension for a body or ``.ads`` for a spec.
+
+ .. index:: File name length
+
+* Unit names should be distinct when 'krunch'ed to 8 characters
+ (see krunch.ads) and the filenames should match the unit name,
+ except that they are all lower case.
+
+ .. index:: krunch.ads file
+
+.. toctree::
+ share/gnu_free_documentation_license
diff --git a/gcc/ada/doc/gnat_rm/implementation_advice.rst b/gcc/ada/doc/gnat_rm/implementation_advice.rst
index e86ad0a..e7649b0 100644
--- a/gcc/ada/doc/gnat_rm/implementation_advice.rst
+++ b/gcc/ada/doc/gnat_rm/implementation_advice.rst
@@ -799,6 +799,22 @@ flushed before the ``Get_Immediate`` call. A special unit
``Interfaces.Vxworks.IO`` is provided that contains routines to enable
this functionality.
+.. index:: Containers
+
+RM A.18: ``Containers``
+================================
+
+All implementation advice pertaining to Ada.Containers and its
+child units (that is, all implementation advice occurring within
+section A.18 and its subsections) is followed except for A.18.24(17):
+
+ "Bounded ordered set objects should be implemented without implicit pointers or dynamic allocation. "
+
+The implementations of the two Reference_Preserving_Key functions of
+the generic package Ada.Containers.Bounded_Ordered_Sets each currently make
+use of dynamic allocation; other operations on bounded ordered set objects
+follow the implementation advice.
+
.. index:: Export
RM B.1(39-41): Pragma ``Export``
diff --git a/gcc/ada/doc/gnat_rm/implementation_defined_aspects.rst b/gcc/ada/doc/gnat_rm/implementation_defined_aspects.rst
index 6f39de6..b09a4bb 100644
--- a/gcc/ada/doc/gnat_rm/implementation_defined_aspects.rst
+++ b/gcc/ada/doc/gnat_rm/implementation_defined_aspects.rst
@@ -397,6 +397,19 @@ This aspect is equivalent to :ref:`pragma No_Tagged_Streams<Pragma-No_Tagged_Str
argument specifying a root tagged type (thus this aspect can only be
applied to such a type).
+Aspect No_Task_Parts
+========================
+.. index:: No_Task_Parts
+
+Applies to a type. If True, requires that the type and any descendants
+do not have any task parts. The rules for this aspect are the same as
+for the language-defined No_Controlled_Parts aspect (see RM-H.4.1),
+replacing "controlled" with "task".
+
+If No_Task_Parts is True for a type T, then the compiler can optimize
+away certain tasking-related code that would otherwise be needed
+for T'Class, because descendants of T might contain tasks.
+
Aspect Object_Size
==================
.. index:: Object_Size
@@ -548,12 +561,6 @@ Aspect Universal_Aliasing
This boolean aspect is equivalent to :ref:`pragma Universal_Aliasing<Pragma-Universal_Aliasing>`.
-Aspect Universal_Data
-=====================
-.. index:: Universal_Data
-
-This aspect is equivalent to :ref:`pragma Universal_Data<Pragma-Universal_Data>`.
-
Aspect Unmodified
=================
.. index:: Unmodified
@@ -566,7 +573,7 @@ Aspect Unreferenced
This boolean aspect is equivalent to :ref:`pragma Unreferenced<Pragma-Unreferenced>`.
-When using the ``-gnat2020`` switch, this aspect is also supported on formal
+When using the ``-gnat2022`` switch, this aspect is also supported on formal
parameters, which is in particular the only form possible for expression
functions.
diff --git a/gcc/ada/doc/gnat_rm/implementation_defined_attributes.rst b/gcc/ada/doc/gnat_rm/implementation_defined_attributes.rst
index f8d41ea..665170c 100644
--- a/gcc/ada/doc/gnat_rm/implementation_defined_attributes.rst
+++ b/gcc/ada/doc/gnat_rm/implementation_defined_attributes.rst
@@ -196,7 +196,7 @@ Attribute Default_Bit_Order
.. index:: Default_Bit_Order
``Standard'Default_Bit_Order`` (``Standard`` is the only
-permissible prefix), provides the value ``System.Default_Bit_Order``
+allowed prefix), provides the value ``System.Default_Bit_Order``
as a ``Pos`` value (0 for ``High_Order_First``, 1 for
``Low_Order_First``). This is used to construct the definition of
``Default_Bit_Order`` in package ``System``.
@@ -210,7 +210,7 @@ Attribute Default_Scalar_Storage_Order
.. index:: Default_Scalar_Storage_Order
``Standard'Default_Scalar_Storage_Order`` (``Standard`` is the only
-permissible prefix), provides the current value of the default scalar storage
+allowed prefix), provides the current value of the default scalar storage
order (as specified using pragma ``Default_Scalar_Storage_Order``, or
equal to ``Default_Bit_Order`` if unspecified) as a
``System.Bit_Order`` value. This is a static attribute.
@@ -665,7 +665,7 @@ Attribute Maximum_Alignment
.. index:: Maximum_Alignment
``Standard'Maximum_Alignment`` (``Standard`` is the only
-permissible prefix) provides the maximum useful alignment value for the
+allowed prefix) provides the maximum useful alignment value for the
target. This is a static value that can be used to specify the alignment
for an object, guaranteeing that it is properly aligned in all
cases.
@@ -674,7 +674,7 @@ Attribute Max_Integer_Size
==========================
.. index:: Max_Integer_Size
-``Standard'Max_Integer_Size`` (``Standard`` is the only permissible
+``Standard'Max_Integer_Size`` (``Standard`` is the only allowed
prefix) provides the size of the largest supported integer type for
the target. The result is a static constant.
@@ -1057,6 +1057,46 @@ If a component of ``T`` is itself of a record or array type, the specfied
attribute definition clause must be provided for the component type as well
if desired.
+Representation changes that explicitly or implicitly toggle the scalar storage
+order are not supported and may result in erroneous execution of the program,
+except when performed by means of an instance of ``Ada.Unchecked_Conversion``.
+
+In particular, overlays are not supported and a warning is given for them:
+
+.. code-block:: ada
+
+ type Rec_LE is record
+ I : Integer;
+ end record;
+
+ for Rec_LE use record
+ I at 0 range 0 .. 31;
+ end record;
+
+ for Rec_LE'Bit_Order use System.Low_Order_First;
+ for Rec_LE'Scalar_Storage_Order use System.Low_Order_First;
+
+ type Rec_BE is record
+ I : Integer;
+ end record;
+
+ for Rec_BE use record
+ I at 0 range 0 .. 31;
+ end record;
+
+ for Rec_BE'Bit_Order use System.High_Order_First;
+ for Rec_BE'Scalar_Storage_Order use System.High_Order_First;
+
+ R_LE : Rec_LE;
+
+ R_BE : Rec_BE;
+ for R_BE'Address use R_LE'Address;
+
+``warning: overlay changes scalar storage order [enabled by default]``
+
+In most cases, such representation changes ought to be replaced by an
+instantiation of a function or procedure provided by ``GNAT.Byte_Swapping``.
+
Note that the scalar storage order only affects the in-memory data
representation. It has no effect on the representation used by stream
attributes.
@@ -1164,7 +1204,7 @@ Attribute Storage_Unit
======================
.. index:: Storage_Unit
-``Standard'Storage_Unit`` (``Standard`` is the only permissible
+``Standard'Storage_Unit`` (``Standard`` is the only allowed
prefix) provides the same value as ``System.Storage_Unit``.
Attribute Stub_Type
@@ -1195,7 +1235,7 @@ Attribute System_Allocator_Alignment
.. index:: System_Allocator_Alignment
``Standard'System_Allocator_Alignment`` (``Standard`` is the only
-permissible prefix) provides the observable guaranted to be honored by
+allowed prefix) provides the observable guaranted to be honored by
the system allocator (malloc). This is a static value that can be used
in user storage pools based on malloc either to reject allocation
with alignment too large or to enable a realignment circuitry if the
@@ -1205,7 +1245,7 @@ Attribute Target_Name
=====================
.. index:: Target_Name
-``Standard'Target_Name`` (``Standard`` is the only permissible
+``Standard'Target_Name`` (``Standard`` is the only allowed
prefix) provides a static string value that identifies the target
for the current compilation. For GCC implementations, this is the
standard gcc target name without the terminating slash (for
@@ -1216,7 +1256,7 @@ Attribute To_Address
.. index:: To_Address
The ``System'To_Address``
-(``System`` is the only permissible prefix)
+(``System`` is the only allowed prefix)
denotes a function identical to
``System.Storage_Elements.To_Address`` except that
it is a static attribute. This means that if its argument is
@@ -1587,6 +1627,15 @@ Multi-dimensional arrays can be modified, as shown by this example:
which changes element (1,2) to 20 and (3,4) to 30.
+Attribute Valid_Image
+=======================
+.. index:: Valid_Image
+
+The ``'Valid_Image`` attribute is defined for enumeration types other than
+those in package Standard. This attribute is a function that takes
+a String, and returns Boolean. ``T'Valid_Image (S)`` returns True
+if and only if ``T'Value (S)`` would not raise Constraint_Error.
+
Attribute Valid_Scalars
=======================
.. index:: Valid_Scalars
@@ -1650,7 +1699,7 @@ Attribute Wchar_T_Size
======================
.. index:: Wchar_T_Size
-``Standard'Wchar_T_Size`` (``Standard`` is the only permissible
+``Standard'Wchar_T_Size`` (``Standard`` is the only allowed
prefix) provides the size in bits of the C ``wchar_t`` type
primarily for constructing the definition of this type in
package ``Interfaces.C``. The result is a static constant.
@@ -1659,6 +1708,6 @@ Attribute Word_Size
===================
.. index:: Word_Size
-``Standard'Word_Size`` (``Standard`` is the only permissible
+``Standard'Word_Size`` (``Standard`` is the only allowed
prefix) provides the value ``System.Word_Size``. The result is
a static constant.
diff --git a/gcc/ada/doc/gnat_rm/implementation_defined_characteristics.rst b/gcc/ada/doc/gnat_rm/implementation_defined_characteristics.rst
index 10fcfc9..8d0be38 100644
--- a/gcc/ada/doc/gnat_rm/implementation_defined_characteristics.rst
+++ b/gcc/ada/doc/gnat_rm/implementation_defined_characteristics.rst
@@ -129,20 +129,29 @@ There are no nonstandard real types.
"What combinations of requested decimal precision and range
are supported for floating point types. See 3.5.7(7)."
-The precision and range is as defined by the IEEE standard.
+The precision and range are defined by the IEEE Standard for Floating-Point
+Arithmetic (IEEE 754-2019).
*
"The predefined floating point types declared in
``Standard``. See 3.5.7(16)."
-====================== ====================================================
+====================== ===============================================
Type Representation
-====================== ====================================================
-*Short_Float* 32 bit IEEE short
-*Float* (Short) 32 bit IEEE short
-*Long_Float* 64 bit IEEE long
-*Long_Long_Float* 64 bit IEEE long (80 bit IEEE long on x86 processors)
-====================== ====================================================
+====================== ===============================================
+*Short_Float* IEEE Binary32 (Single)
+*Float* IEEE Binary32 (Single)
+*Long_Float* IEEE Binary64 (Double)
+*Long_Long_Float* IEEE Binary64 (Double) on non-x86 architectures
+ IEEE 80-bit Extended on x86 architecture
+====================== ===============================================
+
+The default rounding mode specified by the IEEE 754 Standard is assumed for
+static computations, i.e. round to nearest, ties to even. The input routines
+yield correctly rounded values for Short_Float, Float and Long_Float at least.
+The output routines can compute up to twice as many exact digits as the value
+of ``T'Digits`` for any type, for example 30 digits for Long_Float; if more
+digits are requested, zeros are printed.
*
"The small of an ordinary fixed point type. See 3.5.9(8)."
diff --git a/gcc/ada/doc/gnat_rm/implementation_defined_pragmas.rst b/gcc/ada/doc/gnat_rm/implementation_defined_pragmas.rst
index 74b9718..6c81ca7 100644
--- a/gcc/ada/doc/gnat_rm/implementation_defined_pragmas.rst
+++ b/gcc/ada/doc/gnat_rm/implementation_defined_pragmas.rst
@@ -2062,27 +2062,6 @@ string or a static string expressions that evaluates to the null
string. In this case, no external name is generated. This form
still allows the specification of parameter mechanisms.
-Pragma Export_Value
-===================
-
-Syntax:
-
-
-::
-
- pragma Export_Value (
- [Value =>] static_integer_EXPRESSION,
- [Link_Name =>] static_string_EXPRESSION);
-
-
-This pragma serves to export a static integer value for external use.
-The first argument specifies the value to be exported. The Link_Name
-argument specifies the symbolic name to be associated with the integer
-value. This pragma is useful for defining a named static value in Ada
-that can be referenced in assembly language units to be linked with
-the application. This pragma is currently supported only for the
-AAMP target and is ignored for other targets.
-
Pragma Export_Valued_Procedure
==============================
@@ -2210,7 +2189,7 @@ 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 202x), and in addition a small number
+implemented (currently Ada 2022), and in addition a number
of GNAT specific extensions are recognized as follows:
* Constrained attribute for generic objects
@@ -2235,6 +2214,169 @@ of GNAT specific extensions are recognized as follows:
This new aggregate syntax for arrays and containers is provided under -gnatX
to experiment and confirm this new language syntax.
+* Additional ``when`` constructs
+
+ In addition to the ``exit when CONDITION`` control structure, several
+ additional constructs are allowed following this format. Including
+ ``return when CONDITION``, ``goto when CONDITION``, and
+ ``raise [with EXCEPTION_MESSAGE] when CONDITION.``
+
+ Some examples:
+
+ .. code-block:: ada
+
+ return Result when Variable > 10;
+
+ raise Program_Error with "Element is null" when Element = null;
+
+ goto End_Of_Subprogram when Variable = -1;
+
+* Casing on composite values (aka pattern matching)
+
+ The selector for a case statement may be of a composite type, subject to
+ some restrictions (described below). Aggregate syntax is used for choices
+ of such a case statement; however, in cases where a "normal" aggregate would
+ require a discrete value, a discrete subtype may be used instead; box
+ notation can also be used to match all values.
+
+ Consider this example:
+
+ .. code-block:: ada
+
+ type Rec is record
+ F1, F2 : Integer;
+ end record;
+
+ procedure Caser_1 (X : Rec) is
+ begin
+ case X is
+ when (F1 => Positive, F2 => Positive) =>
+ Do_This;
+ when (F1 => Natural, F2 => <>) | (F1 => <>, F2 => Natural) =>
+ Do_That;
+ when others =>
+ Do_The_Other_Thing;
+ end case;
+ end Caser_1;
+
+ If Caser_1 is called and both components of X are positive, then
+ Do_This will be called; otherwise, if either component is nonnegative
+ then Do_That will be called; otherwise, Do_The_Other_Thing will be called.
+
+ If the set of values that match the choice(s) of an earlier alternative
+ overlaps the corresponding set of a later alternative, then the first
+ set shall be a proper subset of the second (and the later alternative
+ will not be executed if the earlier alternative "matches"). All possible
+ values of the composite type shall be covered. The composite type of the
+ selector shall be a nonlimited untagged (but possibly discriminated)
+ record type, all of whose subcomponent subtypes are either static discrete
+ subtypes or record types that meet the same restrictions. Support for arrays
+ is planned, but not yet implemented.
+
+ In addition, pattern bindings are supported. This is a mechanism
+ for binding a name to a component of a matching value for use within
+ an alternative of a case statement. For a component association
+ that occurs within a case choice, the expression may be followed by
+ "is <identifier>". In the special case of a "box" component association,
+ the identifier may instead be provided within the box. Either of these
+ indicates that the given identifer denotes (a constant view of) the matching
+ subcomponent of the case selector.
+
+ Consider this example (which uses type Rec from the previous example):
+
+ .. code-block:: ada
+
+ procedure Caser_2 (X : Rec) is
+ begin
+ case X is
+ when (F1 => Positive is Abc, F2 => Positive) =>
+ Do_This (Abc)
+ when (F1 => Natural is N1, F2 => <N2>) |
+ (F1 => <N2>, F2 => Natural is N1) =>
+ Do_That (Param_1 => N1, Param_2 => N2);
+ when others =>
+ Do_The_Other_Thing;
+ end case;
+ end Caser_2;
+
+ This example is the same as the previous one with respect to
+ determining whether Do_This, Do_That, or Do_The_Other_Thing will
+ be called. But for this version, Do_This takes a parameter and Do_That
+ takes two parameters. If Do_This is called, the actual parameter in the
+ call will be X.F1.
+
+ If Do_That is called, the situation is more complex because there are two
+ choices for that alternative. If Do_That is called because the first choice
+ matched (i.e., because X.F1 is nonnegative and either X.F1 or X.F2 is zero
+ or negative), then the actual parameters of the call will be (in order)
+ X.F1 and X.F2. If Do_That is called because the second choice matched (and
+ the first one did not), then the actual parameters will be reversed.
+
+ Within the choice list for single alternative, each choice must
+ define the same set of bindings and the component subtypes for
+ for a given identifer must all statically match. Currently, the case
+ of a binding for a nondiscrete component is not implemented.
+
+* Fixed lower bounds for array types and subtypes
+
+ Unconstrained array types and subtypes can be specified with a lower bound
+ that is fixed to a certain value, by writing an index range that uses the
+ syntax "<lower-bound-expression> .. <>". This guarantees that all objects
+ of the type or subtype will have the specified lower bound.
+
+ For example, a matrix type with fixed lower bounds of zero for each
+ dimension can be declared by the following:
+
+ .. code-block:: ada
+
+ type Matrix is
+ array (Natural range 0 .. <>, Natural range 0 .. <>) of Integer;
+
+ Objects of type Matrix declared with an index constraint must have index
+ ranges starting at zero:
+
+ .. code-block:: ada
+
+ M1 : Matrix (0 .. 9, 0 .. 19);
+ M2 : Matrix (2 .. 11, 3 .. 22); -- Warning about bounds; will raise CE
+
+ Similarly, a subtype of String can be declared that specifies the lower
+ bound of objects of that subtype to be 1:
+
+ .. code-block:: ada
+
+ subtype String_1 is String (1 .. <>);
+
+ If a string slice is passed to a formal of subtype String_1 in a call to
+ a subprogram S, the slice's bounds will "slide" so that the lower bound
+ is 1. Within S, the lower bound of the formal is known to be 1, so, unlike
+ a normal unconstrained String formal, there is no need to worry about
+ accounting for other possible lower-bound values. Sliding of bounds also
+ occurs in other contexts, such as for object declarations with an
+ unconstrained subtype with fixed lower bound, as well as in subtype
+ conversions.
+
+ Use of this feature increases safety by simplifying code, and can also
+ improve the efficiency of indexing operations, since the compiler statically
+ knows the lower bound of unconstrained array formals when the formal's
+ subtype has index ranges with static fixed lower bounds.
+
+* Prefixed-view notation for calls to primitive subprograms of untagged types
+
+ Since Ada 2005, calls to primitive subprograms of a tagged type that
+ have a "prefixed view" (see RM 4.1.3(9.2)) have been allowed to be
+ written using the form of a selected_component, with the first actual
+ parameter given as the prefix and the name of the subprogram as a
+ selector. This prefixed-view notation for calls is extended so as to
+ also allow such syntax for calls to primitive subprograms of untagged
+ types. The primitives of an untagged type T that have a prefixed view
+ are those where the first formal parameter of the subprogram either
+ is of type T or is an anonymous access parameter whose designated type
+ is T. For a type that has a component that happens to have the same
+ simple name as one of the type's primitive subprograms, where the
+ component is visible at the point of a selected_component using that
+ name, preference is given to the component in a selected_component
+ (as is currently the case for tagged types with such component names).
.. _Pragma-Extensions_Visible:
@@ -3114,13 +3256,7 @@ Syntax:
This program unit pragma is supported for parameterless protected procedures
-as described in Annex C of the Ada Reference Manual. On the AAMP target
-the pragma can also be specified for nonprotected parameterless procedures
-that are declared at the library level (which includes procedures
-declared at the top level of a library package). In the case of AAMP,
-when this pragma is applied to a nonprotected procedure, the instruction
-``IERET`` is generated for returns from the procedure, enabling
-maskable interrupts, in place of the normal return instruction.
+as described in Annex C of the Ada Reference Manual.
Pragma Interrupt_State
======================
@@ -6914,32 +7050,6 @@ For a detailed description of the strict aliasing optimization, and the
situations in which it must be suppressed, see the section on
``Optimization and Strict Aliasing`` in the :title:`GNAT User's Guide`.
-.. _Pragma-Universal_Data:
-
-Pragma Universal_Data
-=====================
-
-Syntax:
-
-
-::
-
- pragma Universal_Data [(library_unit_Name)];
-
-
-This pragma is supported only for the AAMP target and is ignored for
-other targets. The pragma specifies that all library-level objects
-(Counter 0 data) associated with the library unit are to be accessed
-and updated using universal addressing (24-bit addresses for AAMP5)
-rather than the default of 16-bit Data Environment (DENV) addressing.
-Use of this pragma will generally result in less efficient code for
-references to global data associated with the library unit, but
-allows such data to be located anywhere in memory. This pragma is
-a library unit pragma, but can also be used as a configuration pragma
-(including use in the :file:`gnat.adc` file). The functionality
-of this pragma is also available by applying the -univ switch on the
-compilations of units where universal addressing of the data is desired.
-
.. _Pragma-Unmodified:
Pragma Unmodified
diff --git a/gcc/ada/doc/gnat_rm/implementation_of_specific_ada_features.rst b/gcc/ada/doc/gnat_rm/implementation_of_specific_ada_features.rst
index e818ab5..9f419a7 100644
--- a/gcc/ada/doc/gnat_rm/implementation_of_specific_ada_features.rst
+++ b/gcc/ada/doc/gnat_rm/implementation_of_specific_ada_features.rst
@@ -672,6 +672,26 @@ aliasing all views of the object (which may be manipulated by different tasks,
say) must be consistent, so it is imperative that the object, once created,
remain invariant.
+.. _Image_Values_For_Nonscalar_Types:
+
+Image Values For Nonscalar Types
+================================
+
+Ada 2022 defines the Image, Wide_Image, and Wide_Wide image attributes
+for nonscalar types; earlier Ada versions defined these attributes only
+for scalar types. Ada RM 4.10 provides some general guidance regarding
+the default implementation of these attributes and the GNAT compiler
+follows that guidance. However, beyond that the precise details of the
+image text generated in these cases are deliberately not documented and are
+subject to change. In particular, users should not rely on formatting details
+(such as spaces or line breaking), record field order, image values for access
+types, image values for types that have ancestor or subcomponent types
+declared in non-Ada2022 code, image values for predefined types, or the
+compiler's choices regarding the implementation permissions described in
+Ada RM 4.10. This list is not intended to be exhaustive. If more precise
+control of image text is required for some type T, then T'Put_Image should be
+explicitly specified.
+
.. _Strict_Conformance_to_the_Ada_Reference_Manual:
Strict Conformance to the Ada Reference Manual
diff --git a/gcc/ada/doc/gnat_rm/intrinsic_subprograms.rst b/gcc/ada/doc/gnat_rm/intrinsic_subprograms.rst
index e448816..355b139 100644
--- a/gcc/ada/doc/gnat_rm/intrinsic_subprograms.rst
+++ b/gcc/ada/doc/gnat_rm/intrinsic_subprograms.rst
@@ -203,7 +203,8 @@ type (signed or modular), as in this example:
function Shift_Left
(Value : T;
- Amount : Natural) return T;
+ Amount : Natural) return T
+ with Import, Convention => Intrinsic;
The function name must be one of
@@ -215,11 +216,12 @@ The result type must be the same as the type of ``Value``.
The shift amount must be Natural.
The formal parameter names can be anything.
-A more convenient way of providing these shift operators is to use
-the Provide_Shift_Operators pragma, which provides the function declarations
-and corresponding pragma Import's for all five shift functions. Note that in
-using these provided shift operations, shifts performed on negative numbers
-will result in modification of the sign bit.
+A more convenient way of providing these shift operators is to use the
+Provide_Shift_Operators pragma, which provides the function declarations and
+corresponding pragma Import's for all five shift functions. For signed types
+the semantics of these operators is to interpret the bitwise result of the
+corresponding operator for modular type. In particular, shifting a negative
+number may change its sign bit to positive.
.. _Source_Location:
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 c13a882..f755fc1 100644
--- a/gcc/ada/doc/gnat_rm/representation_clauses_and_pragmas.rst
+++ b/gcc/ada/doc/gnat_rm/representation_clauses_and_pragmas.rst
@@ -1738,7 +1738,7 @@ of the use of this pragma. This may cause an overlay to have this
unintended clobbering effect. The compiler avoids this for scalar
types, but not for composite objects (where in general the effect
of ``Initialize_Scalars`` is part of the initialization routine
-for the composite object:
+for the composite object):
::
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 82e992a..07c38df 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
@@ -1233,6 +1233,13 @@ Alphabetical List of All Switches
marker is specified, the callgraph is decorated with information about
dynamically allocated objects.
+.. index:: -fdiagnostics-format (gcc)
+
+:switch:`-fdiagnostics-format=json`
+ Makes GNAT emit warning and error messages as JSON. Inhibits printing of
+ text warning and errors messages except if :switch:`-gnatv` or
+ :switch:`-gnatl` are present.
+
.. index:: -fdump-scos (gcc)
@@ -1380,6 +1387,12 @@ Alphabetical List of All Switches
Allow full Ada 2012 features (same as :switch:`-gnat12`)
+.. index:: -gnat2022 (gcc)
+
+:switch:`-gnat2022`
+ Allow full Ada 2022 features
+
+
:switch:`-gnat83`
Enforce Ada 83 restrictions.
@@ -1463,9 +1476,9 @@ Alphabetical List of All Switches
:switch:`-gnatd`
Specify debug options for the compiler. The string of characters after
- the :switch:`-gnatd` specify the specific debug options. The possible
- characters are 0-9, a-z, A-Z, optionally preceded by a dot. See
- compiler source file :file:`debug.adb` for details of the implemented
+ the :switch:`-gnatd` specifies the specific debug options. The possible
+ characters are 0-9, a-z, A-Z, optionally preceded by a dot or underscore.
+ See compiler source file :file:`debug.adb` for details of the implemented
debug options. Certain debug options are relevant to applications
programmers, and these are documented at appropriate points in this
users guide.
@@ -1735,8 +1748,7 @@ Alphabetical List of All Switches
in bits.`
``Max_Unaligned_Field`` is the maximum size for unaligned bit field, which is
- 64 for the majority of GCC targets (but can be different on some targets like
- AAMP).
+ 64 for the majority of GCC targets (but can be different on some targets).
``Strict_Alignment`` is the equivalent of GCC macro ``STRICT_ALIGNMENT``
documented as follows: `Define this macro to be the value 1 if instructions
@@ -1775,8 +1787,9 @@ Alphabetical List of All Switches
where ``name`` is the string name of the type (which can have
single spaces embedded in the name (e.g. long double), ``digs`` is
the number of digits for the floating-point type, ``float_rep`` is
- the float representation (I/V/A for IEEE-754-Binary, Vax_Native,
- AAMP), ``size`` is the size in bits, ``alignment`` is the
+ the float representation (I for IEEE-754-Binary, which is
+ the only one supported at this time),
+ ``size`` is the size in bits, ``alignment`` is the
alignment in bits. The name is followed by at least two blanks, fields
are separated by at least one blank, and a LF character immediately
follows the alignment field.
@@ -1896,7 +1909,7 @@ Alphabetical List of All Switches
.. index:: -gnati (gcc)
:switch:`-gnati{c}`
- Identifier character set (``c`` = 1/2/3/4/8/9/p/f/n/w).
+ Identifier character set (``c`` = 1/2/3/4/5/9/p/8/f/n/w).
For details of the possible selections for ``c``,
see :ref:`Character_Set_Control`.
@@ -1997,8 +2010,7 @@ Alphabetical List of All Switches
by the front end and will be visible in the
:switch:`-gnatG` output.
- When using a gcc-based back end (in practice this means using any version
- of GNAT other than the JGNAT, .NET or GNAAMP versions), then the use of
+ When using a gcc-based back end, then the use of
:switch:`-gnatN` is deprecated, and the use of :switch:`-gnatn` is preferred.
Historically front end inlining was more extensive than the gcc back end
inlining, but that is no longer the case.
@@ -3247,7 +3259,7 @@ of the pragma in the :title:`GNAT_Reference_manual`).
:switch:`-gnatw.I`
*Disable warnings on overlapping actuals.*
- This switch disables warnings on overlapping actuals in a call..
+ This switch disables warnings on overlapping actuals in a call.
.. index:: -gnatwj (gcc)
@@ -3424,7 +3436,10 @@ of the pragma in the :title:`GNAT_Reference_manual`).
with no size clause. The guess in both cases is that 2**x was intended
rather than x. In addition expressions of the form 2*x for small x
generate a warning (the almost certainly accurate guess being that
- 2**x was intended). The default is that these warnings are given.
+ 2**x was intended). This switch also activates warnings for negative
+ literal values of a modular type, which are interpreted as large positive
+ integers after wrap-around. The default is that these warnings are given.
+
.. index:: -gnatw.M (gcc)
@@ -4620,8 +4635,18 @@ checks to be performed. The following checks are defined:
in the string after :switch:`-gnaty`
then proper indentation is checked, with the digit indicating the
indentation level required. A value of zero turns off this style check.
- The general style of required indentation is as specified by
- the examples in the Ada Reference Manual. Full line comments must be
+ The rule checks that the following constructs start on a column that is
+ a multiple of the alignment level:
+
+ * beginnings of declarations (except record component declarations)
+ and statements;
+
+ * beginnings of the structural components of compound statements;
+
+ * ``end`` keyword that completes the declaration of a program unit declaration
+ or body or that completes a compound statement.
+
+ Full line comments must be
aligned with the ``--`` starting on a column that is a multiple of
the alignment level, or they may be aligned the same way as the following
non-blank line (this is useful when full line comments appear in the middle
@@ -5499,15 +5524,23 @@ indicate Ada 83 compatibility mode.
for further information).
+.. index:: -gnat2022 (gcc)
+.. index:: Ada 2022 mode
+
+:switch:`-gnat2022` (Ada 2022 mode)
+ This switch directs the compiler to implement the Ada 2022 version of the
+ language.
+
+
.. index:: -gnatX (gcc)
.. index:: Ada language extensions
.. index:: GNAT extensions
:switch:`-gnatX` (Enable GNAT Extensions)
This switch directs the compiler to implement the latest version of the
- language (currently Ada 2012) and also to enable certain GNAT implementation
+ language (currently Ada 2022) and also to enable certain GNAT implementation
extensions that are not part of any Ada standard. For a full list of these
- extensions, see the GNAT reference manual.
+ extensions, see the GNAT reference manual, ``Pragma Extensions_Allowed``.
.. _Character_Set_Control:
@@ -5660,8 +5693,7 @@ Subprogram Inlining Control
This switch activates front-end inlining which also
generates additional dependencies.
- When using a gcc-based back end (in practice this means using any version
- of GNAT other than the JGNAT, .NET or GNAAMP versions), then the use of
+ When using a gcc-based back end, then the use of
:switch:`-gnatN` is deprecated, and the use of :switch:`-gnatn` is preferred.
Historically front end inlining was more extensive than the gcc back end
inlining, but that is no longer the case.
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 46d589a..39b9ca1 100644
--- a/gcc/ada/doc/gnat_ugn/the_gnat_compilation_model.rst
+++ b/gcc/ada/doc/gnat_ugn/the_gnat_compilation_model.rst
@@ -1672,8 +1672,7 @@ additional source files as follows:
not require that the code generation be optimized. Like :switch:`-gnatn`,
the use of this switch generates additional dependencies.
- When using a gcc-based back end (in practice this means using any version
- of GNAT other than for the JVM, .NET or GNAAMP platforms), then the use of
+ When using a gcc-based back end, then the use of
:switch:`-gnatN` is deprecated, and the use of :switch:`-gnatn` is preferred.
Historically front end inlining was more extensive than the gcc back end
inlining, but that is no longer the case.
diff --git a/gcc/ada/doc/share/conf.py b/gcc/ada/doc/share/conf.py
index e6fafcf..0f7f963 100644
--- a/gcc/ada/doc/share/conf.py
+++ b/gcc/ada/doc/share/conf.py
@@ -18,9 +18,11 @@ import latex_elements
DOCS = {
'gnat_rm': {
- 'title': u'GNAT Reference Manual'},
+ 'title': 'GNAT Reference Manual'},
'gnat_ugn': {
- 'title': u'GNAT User\'s Guide for Native Platforms'}}
+ 'title': 'GNAT User\'s Guide for Native Platforms'},
+ 'gnat-style': {
+ 'title': 'GNAT Coding Style: A Guide for GNAT Developers'}}
# Then retrieve the source directory
root_source_dir = os.path.dirname(os.path.dirname(os.path.abspath(__file__)))
@@ -28,12 +30,12 @@ gnatvsn_spec = os.path.join(root_source_dir, '..', 'gnatvsn.ads')
basever = os.path.join(root_source_dir, '..', '..', 'BASE-VER')
texi_fsf = True # Set to False when FSF doc is switched to sphinx by default
-with open(gnatvsn_spec, 'rb') as fd:
+with open(gnatvsn_spec, 'r') as fd:
gnatvsn_content = fd.read()
def get_copyright():
- return u'2008-%s, Free Software Foundation' % time.strftime('%Y')
+ return '2008-%s, Free Software Foundation' % time.strftime('%Y')
def get_gnat_version():
@@ -41,18 +43,18 @@ def get_gnat_version():
r'constant String := "([^\(\)]+)\(.*\)?";',
gnatvsn_content)
if m:
- return m.group(1).strip()
+ return m.group(1).strip().decode()
else:
if texi_fsf and os.path.exists(basever):
return ''
try:
- with open(basever, 'rb') as fd:
+ with open(basever) as fd:
return fd.read()
- except:
+ except Exception:
pass
- print 'cannot find GNAT version in gnatvsn.ads or in ' + basever
+ print('cannot find GNAT version in gnatvsn.ads or in ' + basever)
sys.exit(1)
@@ -64,18 +66,18 @@ def get_gnat_build_type():
'FSF': 'FSF',
'GPL': 'GPL'}[m.group(1).strip()]
else:
- print 'cannot compute GNAT build type'
+ print('cannot compute GNAT build type')
sys.exit(1)
# First retrieve the name of the documentation we are building
doc_name = os.environ.get('DOC_NAME', None)
if doc_name is None:
- print 'DOC_NAME environment variable should be set'
+ print('DOC_NAME environment variable should be set')
sys.exit(1)
if doc_name not in DOCS:
- print '%s is not a valid documentation name' % doc_name
+ print('%s is not a valid documentation name' % doc_name)
sys.exit(1)
@@ -84,11 +86,11 @@ exclude_patterns = []
for d in os.listdir(root_source_dir):
if d not in ('share', doc_name, doc_name + '.rst'):
exclude_patterns.append(d)
- print 'ignoring %s' % d
+ print('ignoring %s' % d)
if doc_name == 'gnat_rm':
exclude_patterns.append('share/gnat_project_manager.rst')
- print 'ignoring share/gnat_project_manager.rst'
+ print('ignoring share/gnat_project_manager.rst')
extensions = []
templates_path = ['_templates']
@@ -103,7 +105,7 @@ copyright = get_copyright()
version = get_gnat_version()
release = get_gnat_version()
-pygments_style = 'sphinx'
+pygments_style = None
tags.add(get_gnat_build_type())
html_theme = 'sphinxdoc'
if os.path.isfile('adacore_transparent.png'):
@@ -119,8 +121,8 @@ copyright_macros = {
'date': time.strftime("%b %d, %Y"),
'edition': 'GNAT %s Edition' % 'Pro' if get_gnat_build_type() == 'PRO'
else 'GPL',
- 'name': u'GNU Ada',
- 'tool': u'GNAT',
+ 'name': 'GNU Ada',
+ 'tool': 'GNAT',
'version': version}
latex_elements = {
@@ -134,13 +136,13 @@ latex_elements = {
'tableofcontents': latex_elements.TOC % copyright_macros}
latex_documents = [
- (master_doc, '%s.tex' % doc_name, project, u'AdaCore', 'manual')]
+ (master_doc, '%s.tex' % doc_name, project, 'AdaCore', 'manual')]
texinfo_documents = [
(master_doc, doc_name, project,
- u'AdaCore', doc_name, doc_name, '')]
+ 'AdaCore', doc_name, doc_name, '')]
def setup(app):
- app.add_lexer('ada', ada_pygments.AdaLexer())
- app.add_lexer('gpr', ada_pygments.GNATProjectLexer())
+ app.add_lexer('ada', ada_pygments.AdaLexer)
+ app.add_lexer('gpr', ada_pygments.GNATProjectLexer)
diff --git a/gcc/ada/doc/share/gnat.sty b/gcc/ada/doc/share/gnat.sty
new file mode 100644
index 0000000..1a152fb
--- /dev/null
+++ b/gcc/ada/doc/share/gnat.sty
@@ -0,0 +1,72 @@
+% Needed to generate footers with total number of pages
+\RequirePackage{lastpage}
+
+% AdaCore specific maketitle
+\renewcommand{\maketitle}{%
+ \begin{titlepage}%
+ \let\footnotesize\small
+ \let\footnoterule\relax
+ \rule{\textwidth}{1pt}%
+ \ifsphinxpdfoutput
+ \begingroup
+ % These \defs are required to deal with multi-line authors; it
+ % changes \\ to ', ' (comma-space), making it pass muster for
+ % generating document info in the PDF file.
+ \def\\{, }
+ \def\and{and }
+ \pdfinfo{
+ /Author (\@author)
+ /Title (\@title)
+ }
+ \endgroup
+ \fi
+ \begin{flushright}%
+ \sphinxlogo%
+ {\rm\Huge \@title \par}%
+ {\em\LARGE\py@HeaderFamily \py@release\releaseinfo \par}
+ \vfill
+ {\LARGE\py@HeaderFamily
+ \par}
+ \vfill\vfill
+ {\large
+ \@date \par
+ \vfill
+ \py@authoraddress \par
+ }%
+ \end{flushright}%\par
+ \@thanks
+ \end{titlepage}%
+ \cleardoublepage%
+ \setcounter{footnote}{0}%
+ \let\thanks\relax\let\maketitle\relax
+}
+
+% AdaCore specific headers/footers
+% Redefine the 'normal' header/footer style when using "fancyhdr" package:
+\@ifundefined{fancyhf}{}{
+ % Use \pagestyle{normal} as the primary pagestyle for text.
+ \fancypagestyle{normal}{
+ \fancyhf{}
+ \fancyfoot[LE,RO]{{\py@HeaderFamily\thepage\ of \pageref*{LastPage}}}
+ \fancyfoot[LO]{{\py@HeaderFamily\nouppercase{\rightmark}}}
+ \fancyfoot[RE]{{\py@HeaderFamily\nouppercase{\leftmark}}}
+ \fancyhead[LE,RO]{{\py@HeaderFamily \@title, \py@release}}
+ \renewcommand{\headrulewidth}{0.4pt}
+ \renewcommand{\footrulewidth}{0.4pt}
+ % define chaptermark with \@chappos when \@chappos is available for Japanese
+ \ifx\@chappos\undefined\else
+ \def\chaptermark##1{\markboth{\@chapapp\space\thechapter\space\@chappos\space ##1}{}}
+ \fi
+ }
+ % Update the plain style so we get the page number & footer line,
+ % but not a chapter or section title. This is to keep the first
+ % page of a chapter and the blank page between chapters `clean.'
+ \fancypagestyle{plain}{
+ \fancyhf{}
+ \fancyfoot[LE,RO]{{\py@HeaderFamily\thepage\ of \pageref*{LastPage}}}
+ \fancyfoot[LO,RE]{{\py@HeaderFamily \GNATFullDocumentName}}
+ \fancyhead[LE,RO]{{\py@HeaderFamily \@title\ \GNATVersion}}
+ \renewcommand{\headrulewidth}{0.0pt}
+ \renewcommand{\footrulewidth}{0.4pt}
+ }
+}
diff --git a/gcc/ada/einfo-utils.adb b/gcc/ada/einfo-utils.adb
new file mode 100644
index 0000000..4690c8f
--- /dev/null
+++ b/gcc/ada/einfo-utils.adb
@@ -0,0 +1,3331 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- E I N F O . U T I L S --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 2020-2021, Free Software Foundation, Inc. --
+-- --
+-- GNAT is 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 Elists; use Elists;
+with Nlists; use Nlists;
+with Output; use Output;
+with Sinfo; use Sinfo;
+with Sinfo.Nodes; use Sinfo.Nodes;
+with Sinfo.Utils; use Sinfo.Utils;
+
+package body Einfo.Utils is
+
+ -----------------------
+ -- Local subprograms --
+ -----------------------
+
+ function Has_Option
+ (State_Id : Entity_Id;
+ Option_Nam : Name_Id) return Boolean;
+ -- Determine whether abstract state State_Id has particular option denoted
+ -- by the name Option_Nam.
+
+ -----------------------------------
+ -- Renamings of Renamed_Or_Alias --
+ -----------------------------------
+
+ function Alias (N : Entity_Id) return Node_Id is
+ begin
+ pragma Assert
+ (Is_Overloadable (N) or else Ekind (N) = E_Subprogram_Type);
+ return Renamed_Or_Alias (N);
+ end Alias;
+
+ procedure Set_Alias (N : Entity_Id; Val : Node_Id) is
+ begin
+ pragma Assert
+ (Is_Overloadable (N) or else Ekind (N) = E_Subprogram_Type);
+ Set_Renamed_Or_Alias (N, Val);
+ end Set_Alias;
+
+ ----------------
+ -- Has_Option --
+ ----------------
+
+ function Has_Option
+ (State_Id : Entity_Id;
+ Option_Nam : Name_Id) return Boolean
+ is
+ Decl : constant Node_Id := Parent (State_Id);
+ Opt : Node_Id;
+ Opt_Nam : Node_Id;
+
+ begin
+ pragma Assert (Ekind (State_Id) = E_Abstract_State);
+
+ -- The declaration of abstract states with options appear as an
+ -- extension aggregate. If this is not the case, the option is not
+ -- available.
+
+ if Nkind (Decl) /= N_Extension_Aggregate then
+ return False;
+ end if;
+
+ -- Simple options
+
+ Opt := First (Expressions (Decl));
+ while Present (Opt) loop
+ if Nkind (Opt) = N_Identifier and then Chars (Opt) = Option_Nam then
+ return True;
+ end if;
+
+ Next (Opt);
+ end loop;
+
+ -- Complex options with various specifiers
+
+ Opt := First (Component_Associations (Decl));
+ while Present (Opt) loop
+ Opt_Nam := First (Choices (Opt));
+
+ if Nkind (Opt_Nam) = N_Identifier
+ and then Chars (Opt_Nam) = Option_Nam
+ then
+ return True;
+ end if;
+
+ Next (Opt);
+ end loop;
+
+ return False;
+ end Has_Option;
+
+ ------------------------------
+ -- Classification Functions --
+ ------------------------------
+
+ function Is_Access_Object_Type (Id : E) return B is
+ begin
+ return Is_Access_Type (Id)
+ and then Ekind (Directly_Designated_Type (Id)) /= E_Subprogram_Type;
+ end Is_Access_Object_Type;
+
+ function Is_Access_Type (Id : E) return B is
+ begin
+ return Ekind (Id) in Access_Kind;
+ end Is_Access_Type;
+
+ function Is_Access_Protected_Subprogram_Type (Id : E) return B is
+ begin
+ return Ekind (Id) in Access_Protected_Kind;
+ end Is_Access_Protected_Subprogram_Type;
+
+ function Is_Access_Subprogram_Type (Id : E) return B is
+ begin
+ return Is_Access_Type (Id)
+ and then Ekind (Directly_Designated_Type (Id)) = E_Subprogram_Type;
+ end Is_Access_Subprogram_Type;
+
+ function Is_Aggregate_Type (Id : E) return B is
+ begin
+ return Ekind (Id) in Aggregate_Kind;
+ end Is_Aggregate_Type;
+
+ function Is_Anonymous_Access_Type (Id : E) return B is
+ begin
+ return Ekind (Id) in Anonymous_Access_Kind;
+ end Is_Anonymous_Access_Type;
+
+ function Is_Array_Type (Id : E) return B is
+ begin
+ return Ekind (Id) in Array_Kind;
+ end Is_Array_Type;
+
+ function Is_Assignable (Id : E) return B is
+ begin
+ return Ekind (Id) in Assignable_Kind;
+ end Is_Assignable;
+
+ function Is_Class_Wide_Type (Id : E) return B is
+ begin
+ return Ekind (Id) in Class_Wide_Kind;
+ end Is_Class_Wide_Type;
+
+ function Is_Composite_Type (Id : E) return B is
+ begin
+ return Ekind (Id) in Composite_Kind;
+ end Is_Composite_Type;
+
+ function Is_Concurrent_Body (Id : E) return B is
+ begin
+ return Ekind (Id) in Concurrent_Body_Kind;
+ end Is_Concurrent_Body;
+
+ function Is_Concurrent_Type (Id : E) return B is
+ begin
+ return Ekind (Id) in Concurrent_Kind;
+ end Is_Concurrent_Type;
+
+ function Is_Decimal_Fixed_Point_Type (Id : E) return B is
+ begin
+ return Ekind (Id) in Decimal_Fixed_Point_Kind;
+ end Is_Decimal_Fixed_Point_Type;
+
+ function Is_Digits_Type (Id : E) return B is
+ begin
+ return Ekind (Id) in Digits_Kind;
+ end Is_Digits_Type;
+
+ function Is_Discrete_Or_Fixed_Point_Type (Id : E) return B is
+ begin
+ return Ekind (Id) in Discrete_Or_Fixed_Point_Kind;
+ end Is_Discrete_Or_Fixed_Point_Type;
+
+ function Is_Discrete_Type (Id : E) return B is
+ begin
+ return Ekind (Id) in Discrete_Kind;
+ end Is_Discrete_Type;
+
+ function Is_Elementary_Type (Id : E) return B is
+ begin
+ return Ekind (Id) in Elementary_Kind;
+ end Is_Elementary_Type;
+
+ function Is_Entry (Id : E) return B is
+ begin
+ return Ekind (Id) in Entry_Kind;
+ end Is_Entry;
+
+ function Is_Enumeration_Type (Id : E) return B is
+ begin
+ return Ekind (Id) in Enumeration_Kind;
+ end Is_Enumeration_Type;
+
+ function Is_Fixed_Point_Type (Id : E) return B is
+ begin
+ return Ekind (Id) in Fixed_Point_Kind;
+ end Is_Fixed_Point_Type;
+
+ function Is_Floating_Point_Type (Id : E) return B is
+ begin
+ return Ekind (Id) in Float_Kind;
+ end Is_Floating_Point_Type;
+
+ function Is_Formal (Id : E) return B is
+ begin
+ return Ekind (Id) in Formal_Kind;
+ end Is_Formal;
+
+ function Is_Formal_Object (Id : E) return B is
+ begin
+ return Ekind (Id) in Formal_Object_Kind;
+ end Is_Formal_Object;
+
+ function Is_Generic_Subprogram (Id : E) return B is
+ begin
+ return Ekind (Id) in Generic_Subprogram_Kind;
+ end Is_Generic_Subprogram;
+
+ function Is_Generic_Unit (Id : E) return B is
+ begin
+ return Ekind (Id) in Generic_Unit_Kind;
+ end Is_Generic_Unit;
+
+ function Is_Ghost_Entity (Id : Entity_Id) return Boolean is
+ begin
+ return Is_Checked_Ghost_Entity (Id) or else Is_Ignored_Ghost_Entity (Id);
+ end Is_Ghost_Entity;
+
+ function Is_Incomplete_Or_Private_Type (Id : E) return B is
+ begin
+ return Ekind (Id) in Incomplete_Or_Private_Kind;
+ end Is_Incomplete_Or_Private_Type;
+
+ function Is_Incomplete_Type (Id : E) return B is
+ begin
+ return Ekind (Id) in Incomplete_Kind;
+ end Is_Incomplete_Type;
+
+ function Is_Integer_Type (Id : E) return B is
+ begin
+ return Ekind (Id) in Integer_Kind;
+ end Is_Integer_Type;
+
+ function Is_Modular_Integer_Type (Id : E) return B is
+ begin
+ 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 Named_Access_Kind;
+ end Is_Named_Access_Type;
+
+ function Is_Named_Number (Id : E) return B is
+ begin
+ return Ekind (Id) in Named_Kind;
+ end Is_Named_Number;
+
+ function Is_Numeric_Type (Id : E) return B is
+ begin
+ return Ekind (Id) in Numeric_Kind;
+ end Is_Numeric_Type;
+
+ function Is_Object (Id : E) return B is
+ begin
+ return Ekind (Id) in Object_Kind;
+ end Is_Object;
+
+ function Is_Ordinary_Fixed_Point_Type (Id : E) return B is
+ begin
+ return Ekind (Id) in Ordinary_Fixed_Point_Kind;
+ end Is_Ordinary_Fixed_Point_Type;
+
+ function Is_Overloadable (Id : E) return B is
+ begin
+ return Ekind (Id) in Overloadable_Kind;
+ end Is_Overloadable;
+
+ function Is_Private_Type (Id : E) return B is
+ begin
+ return Ekind (Id) in Private_Kind;
+ end Is_Private_Type;
+
+ function Is_Protected_Type (Id : E) return B is
+ begin
+ return Ekind (Id) in Protected_Kind;
+ end Is_Protected_Type;
+
+ function Is_Real_Type (Id : E) return B is
+ begin
+ return Ekind (Id) in Real_Kind;
+ end Is_Real_Type;
+
+ function Is_Record_Type (Id : E) return B is
+ begin
+ return Ekind (Id) in Record_Kind;
+ end Is_Record_Type;
+
+ function Is_Scalar_Type (Id : E) return B is
+ begin
+ return Ekind (Id) in Scalar_Kind;
+ end Is_Scalar_Type;
+
+ function Is_Signed_Integer_Type (Id : E) return B is
+ begin
+ return Ekind (Id) in Signed_Integer_Kind;
+ end Is_Signed_Integer_Type;
+
+ function Is_Subprogram (Id : E) return B is
+ begin
+ return Ekind (Id) in Subprogram_Kind;
+ end Is_Subprogram;
+
+ function Is_Subprogram_Or_Entry (Id : E) return B is
+ begin
+ return Ekind (Id) in Subprogram_Kind
+ or else
+ Ekind (Id) in Entry_Kind;
+ end Is_Subprogram_Or_Entry;
+
+ function Is_Subprogram_Or_Generic_Subprogram (Id : E) return B is
+ begin
+ return Ekind (Id) in Subprogram_Kind
+ or else
+ Ekind (Id) in Generic_Subprogram_Kind;
+ end Is_Subprogram_Or_Generic_Subprogram;
+
+ function Is_Task_Type (Id : E) return B is
+ begin
+ return Ekind (Id) in Task_Kind;
+ end Is_Task_Type;
+
+ function Is_Type (Id : E) return B is
+ begin
+ return Ekind (Id) in Type_Kind;
+ end Is_Type;
+
+ -----------------------------------
+ -- Field Initialization Routines --
+ -----------------------------------
+
+ procedure Init_Alignment (Id : E) is
+ begin
+ Reinit_Field_To_Zero (Id, F_Alignment);
+ end Init_Alignment;
+
+ procedure Init_Alignment (Id : E; V : Int) is
+ begin
+ Set_Alignment (Id, UI_From_Int (V));
+ end Init_Alignment;
+
+ procedure Init_Component_Bit_Offset (Id : E) is
+ begin
+ Set_Component_Bit_Offset (Id, No_Uint);
+ end Init_Component_Bit_Offset;
+
+ procedure Init_Component_Bit_Offset (Id : E; V : Int) is
+ begin
+ Set_Component_Bit_Offset (Id, UI_From_Int (V));
+ end Init_Component_Bit_Offset;
+
+ procedure Init_Component_Size (Id : E) is
+ begin
+ Set_Component_Size (Id, Uint_0);
+ end Init_Component_Size;
+
+ procedure Init_Component_Size (Id : E; V : Int) is
+ begin
+ Set_Component_Size (Id, UI_From_Int (V));
+ end Init_Component_Size;
+
+ procedure Init_Digits_Value (Id : E) is
+ begin
+ Set_Digits_Value (Id, Uint_0);
+ end Init_Digits_Value;
+
+ procedure Init_Digits_Value (Id : E; V : Int) is
+ begin
+ Set_Digits_Value (Id, UI_From_Int (V));
+ end Init_Digits_Value;
+
+ procedure Init_Esize (Id : E) is
+ begin
+ Set_Esize (Id, Uint_0);
+ end Init_Esize;
+
+ procedure Init_Esize (Id : E; V : Int) is
+ begin
+ Set_Esize (Id, UI_From_Int (V));
+ end Init_Esize;
+
+ procedure Init_Normalized_First_Bit (Id : E) is
+ begin
+ Set_Normalized_First_Bit (Id, No_Uint);
+ end Init_Normalized_First_Bit;
+
+ procedure Init_Normalized_First_Bit (Id : E; V : Int) is
+ begin
+ Set_Normalized_First_Bit (Id, UI_From_Int (V));
+ end Init_Normalized_First_Bit;
+
+ procedure Init_Normalized_Position (Id : E) is
+ begin
+ Set_Normalized_Position (Id, No_Uint);
+ end Init_Normalized_Position;
+
+ procedure Init_Normalized_Position (Id : E; V : Int) is
+ begin
+ Set_Normalized_Position (Id, UI_From_Int (V));
+ end Init_Normalized_Position;
+
+ procedure Init_Normalized_Position_Max (Id : E) is
+ begin
+ Set_Normalized_Position_Max (Id, No_Uint);
+ end Init_Normalized_Position_Max;
+
+ procedure Init_Normalized_Position_Max (Id : E; V : Int) is
+ begin
+ Set_Normalized_Position_Max (Id, UI_From_Int (V));
+ end Init_Normalized_Position_Max;
+
+ procedure Init_RM_Size (Id : E) is
+ begin
+ Set_RM_Size (Id, Uint_0);
+ end Init_RM_Size;
+
+ procedure Init_RM_Size (Id : E; V : Int) is
+ begin
+ Set_RM_Size (Id, UI_From_Int (V));
+ end Init_RM_Size;
+
+ procedure Copy_Alignment (To, From : E) is
+ begin
+ if Known_Alignment (From) then
+ Set_Alignment (To, Alignment (From));
+ else
+ Init_Alignment (To);
+ end if;
+ end Copy_Alignment;
+
+ -----------------------------
+ -- Init_Component_Location --
+ -----------------------------
+
+ procedure Init_Component_Location (Id : E) is
+ begin
+ Set_Normalized_First_Bit (Id, No_Uint);
+ Set_Normalized_Position_Max (Id, No_Uint);
+ Set_Component_Bit_Offset (Id, No_Uint);
+ Set_Esize (Id, Uint_0);
+ Set_Normalized_Position (Id, No_Uint);
+ end Init_Component_Location;
+
+ ----------------------------
+ -- Init_Object_Size_Align --
+ ----------------------------
+
+ procedure Init_Object_Size_Align (Id : E) is
+ begin
+ Init_Esize (Id);
+ Init_Alignment (Id);
+ end Init_Object_Size_Align;
+
+ ---------------
+ -- Init_Size --
+ ---------------
+
+ procedure Init_Size (Id : E; V : Int) is
+ begin
+ pragma Assert (Is_Type (Id));
+ pragma Assert
+ (not Known_Esize (Id) or else Esize (Id) = V);
+ pragma Assert
+ (RM_Size (Id) = No_Uint
+ or else RM_Size (Id) = Uint_0
+ or else RM_Size (Id) = V);
+ Set_Esize (Id, UI_From_Int (V));
+ Set_RM_Size (Id, UI_From_Int (V));
+ end Init_Size;
+
+ ---------------------
+ -- Init_Size_Align --
+ ---------------------
+
+ procedure Init_Size_Align (Id : E) is
+ begin
+ pragma Assert (Ekind (Id) in Type_Kind | E_Void);
+ Init_Esize (Id);
+ Init_RM_Size (Id);
+ Init_Alignment (Id);
+ end Init_Size_Align;
+
+ ----------------------------------------------
+ -- Type Representation Attribute Predicates --
+ ----------------------------------------------
+
+ function Known_Alignment (E : Entity_Id) return B is
+ Result : constant B := not Field_Is_Initial_Zero (E, F_Alignment);
+ begin
+ return Result;
+ end Known_Alignment;
+
+ function Known_Component_Bit_Offset (E : Entity_Id) return B is
+ begin
+ return Component_Bit_Offset (E) /= No_Uint;
+ end Known_Component_Bit_Offset;
+
+ function Known_Component_Size (E : Entity_Id) return B is
+ begin
+ return Component_Size (E) /= Uint_0
+ and then Component_Size (E) /= No_Uint;
+ end Known_Component_Size;
+
+ function Known_Esize (E : Entity_Id) return B is
+ begin
+ return Esize (E) /= Uint_0
+ and then Esize (E) /= No_Uint;
+ end Known_Esize;
+
+ function Known_Normalized_First_Bit (E : Entity_Id) return B is
+ begin
+ return Normalized_First_Bit (E) /= No_Uint;
+ end Known_Normalized_First_Bit;
+
+ function Known_Normalized_Position (E : Entity_Id) return B is
+ begin
+ return Normalized_Position (E) /= No_Uint;
+ end Known_Normalized_Position;
+
+ function Known_Normalized_Position_Max (E : Entity_Id) return B is
+ begin
+ return Normalized_Position_Max (E) /= No_Uint;
+ end Known_Normalized_Position_Max;
+
+ function Known_RM_Size (E : Entity_Id) return B is
+ begin
+ return RM_Size (E) /= No_Uint
+ and then (RM_Size (E) /= Uint_0
+ or else Is_Discrete_Type (E)
+ or else Is_Fixed_Point_Type (E));
+ end Known_RM_Size;
+
+ function Known_Static_Component_Bit_Offset (E : Entity_Id) return B is
+ begin
+ return Component_Bit_Offset (E) /= No_Uint
+ and then Component_Bit_Offset (E) >= Uint_0;
+ end Known_Static_Component_Bit_Offset;
+
+ function Known_Static_Component_Size (E : Entity_Id) return B is
+ begin
+ return Component_Size (E) > Uint_0;
+ end Known_Static_Component_Size;
+
+ function Known_Static_Esize (E : Entity_Id) return B is
+ begin
+ return Esize (E) > Uint_0
+ and then not Is_Generic_Type (E);
+ end Known_Static_Esize;
+
+ function Known_Static_Normalized_First_Bit (E : Entity_Id) return B is
+ begin
+ return Normalized_First_Bit (E) /= No_Uint
+ and then Normalized_First_Bit (E) >= Uint_0;
+ end Known_Static_Normalized_First_Bit;
+
+ function Known_Static_Normalized_Position (E : Entity_Id) return B is
+ begin
+ return Normalized_Position (E) /= No_Uint
+ and then Normalized_Position (E) >= Uint_0;
+ end Known_Static_Normalized_Position;
+
+ function Known_Static_Normalized_Position_Max (E : Entity_Id) return B is
+ begin
+ return Normalized_Position_Max (E) /= No_Uint
+ and then Normalized_Position_Max (E) >= Uint_0;
+ end Known_Static_Normalized_Position_Max;
+
+ function Known_Static_RM_Size (E : Entity_Id) return B is
+ begin
+ return (RM_Size (E) > Uint_0
+ or else Is_Discrete_Type (E)
+ or else Is_Fixed_Point_Type (E))
+ and then not Is_Generic_Type (E);
+ end Known_Static_RM_Size;
+
+ --------------------
+ -- Address_Clause --
+ --------------------
+
+ function Address_Clause (Id : E) return N is
+ begin
+ return Get_Attribute_Definition_Clause (Id, Attribute_Address);
+ end Address_Clause;
+
+ ---------------
+ -- Aft_Value --
+ ---------------
+
+ function Aft_Value (Id : E) return U is
+ Result : Nat := 1;
+ Delta_Val : Ureal := Delta_Value (Id);
+ begin
+ while Delta_Val < Ureal_Tenth loop
+ Delta_Val := Delta_Val * Ureal_10;
+ Result := Result + 1;
+ end loop;
+
+ return UI_From_Int (Result);
+ end Aft_Value;
+
+ ----------------------
+ -- Alignment_Clause --
+ ----------------------
+
+ function Alignment_Clause (Id : E) return N is
+ begin
+ return Get_Attribute_Definition_Clause (Id, Attribute_Alignment);
+ end Alignment_Clause;
+
+ -------------------
+ -- Append_Entity --
+ -------------------
+
+ procedure Append_Entity (Id : Entity_Id; Scop : Entity_Id) is
+ Last : constant Entity_Id := Last_Entity (Scop);
+
+ begin
+ Set_Scope (Id, Scop);
+ Set_Prev_Entity (Id, Empty); -- Empty <-- Id
+
+ -- The entity chain is empty
+
+ if No (Last) then
+ Set_First_Entity (Scop, Id);
+
+ -- Otherwise the entity chain has at least one element
+
+ else
+ Link_Entities (Last, Id); -- Last <-- Id, Last --> Id
+ end if;
+
+ -- NOTE: The setting of the Next_Entity attribute of Id must happen
+ -- here as opposed to at the beginning of the routine because doing
+ -- so causes the binder to hang. It is not clear why ???
+
+ Set_Next_Entity (Id, Empty); -- Id --> Empty
+
+ Set_Last_Entity (Scop, Id);
+ end Append_Entity;
+
+ ---------------
+ -- Base_Type --
+ ---------------
+
+ function Base_Type (Id : E) return E is
+ begin
+ if Is_Base_Type (Id) then
+ return Id;
+ else
+ pragma Assert (Is_Type (Id));
+ return Etype (Id);
+ end if;
+ end Base_Type;
+
+ ----------------------
+ -- Declaration_Node --
+ ----------------------
+
+ function Declaration_Node (Id : E) return N is
+ P : Node_Id;
+
+ begin
+ if Ekind (Id) = E_Incomplete_Type
+ and then Present (Full_View (Id))
+ then
+ P := Parent (Full_View (Id));
+ else
+ P := Parent (Id);
+ end if;
+
+ loop
+ 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
+ P := Parent (P);
+ else
+ return P;
+ end if;
+ end loop;
+ end Declaration_Node;
+
+ ---------------------
+ -- Designated_Type --
+ ---------------------
+
+ function Designated_Type (Id : E) return E is
+ Desig_Type : Entity_Id;
+
+ begin
+ Desig_Type := Directly_Designated_Type (Id);
+
+ if No (Desig_Type) then
+ pragma Assert (Error_Posted (Id));
+ return Any_Type;
+ end if;
+
+ if Is_Incomplete_Type (Desig_Type)
+ and then Present (Full_View (Desig_Type))
+ then
+ return Full_View (Desig_Type);
+ end if;
+
+ if Is_Class_Wide_Type (Desig_Type)
+ and then Is_Incomplete_Type (Etype (Desig_Type))
+ and then Present (Full_View (Etype (Desig_Type)))
+ and then Present (Class_Wide_Type (Full_View (Etype (Desig_Type))))
+ then
+ return Class_Wide_Type (Full_View (Etype (Desig_Type)));
+ end if;
+
+ return Desig_Type;
+ end Designated_Type;
+
+ ----------------------
+ -- Entry_Index_Type --
+ ----------------------
+
+ function Entry_Index_Type (Id : E) return N is
+ begin
+ pragma Assert (Ekind (Id) = E_Entry_Family);
+ return Etype (Discrete_Subtype_Definition (Parent (Id)));
+ end Entry_Index_Type;
+
+ ---------------------
+ -- First_Component --
+ ---------------------
+
+ function First_Component (Id : E) return E is
+ Comp_Id : Entity_Id;
+
+ begin
+ pragma Assert
+ (Is_Concurrent_Type (Id)
+ or else Is_Incomplete_Or_Private_Type (Id)
+ or else Is_Record_Type (Id));
+
+ Comp_Id := First_Entity (Id);
+ while Present (Comp_Id) loop
+ exit when Ekind (Comp_Id) = E_Component;
+ Next_Entity (Comp_Id);
+ end loop;
+
+ return Comp_Id;
+ end First_Component;
+
+ -------------------------------------
+ -- First_Component_Or_Discriminant --
+ -------------------------------------
+
+ function First_Component_Or_Discriminant (Id : E) return E is
+ Comp_Id : Entity_Id;
+
+ begin
+ pragma Assert
+ (Is_Concurrent_Type (Id)
+ or else Is_Incomplete_Or_Private_Type (Id)
+ or else Is_Record_Type (Id)
+ or else Has_Discriminants (Id));
+
+ Comp_Id := First_Entity (Id);
+ while Present (Comp_Id) loop
+ exit when Ekind (Comp_Id) in E_Component | E_Discriminant;
+ Next_Entity (Comp_Id);
+ end loop;
+
+ return Comp_Id;
+ end First_Component_Or_Discriminant;
+
+ ------------------
+ -- First_Formal --
+ ------------------
+
+ function First_Formal (Id : E) return E is
+ Formal : Entity_Id;
+
+ begin
+ pragma Assert
+ (Is_Generic_Subprogram (Id)
+ or else Is_Overloadable (Id)
+ or else Ekind (Id) in E_Entry_Family
+ | E_Subprogram_Body
+ | E_Subprogram_Type);
+
+ if Ekind (Id) = E_Enumeration_Literal then
+ return Empty;
+
+ else
+ Formal := First_Entity (Id);
+
+ -- Deal with the common, non-generic case first
+
+ if No (Formal) or else Is_Formal (Formal) then
+ return Formal;
+ end if;
+
+ -- The first/next entity chain of a generic subprogram contains all
+ -- generic formal parameters, followed by the formal parameters.
+
+ if Is_Generic_Subprogram (Id) then
+ while Present (Formal) and then not Is_Formal (Formal) loop
+ Next_Entity (Formal);
+ end loop;
+ return Formal;
+ else
+ return Empty;
+ end if;
+ end if;
+ end First_Formal;
+
+ ------------------------------
+ -- First_Formal_With_Extras --
+ ------------------------------
+
+ function First_Formal_With_Extras (Id : E) return E is
+ Formal : Entity_Id;
+
+ begin
+ pragma Assert
+ (Is_Generic_Subprogram (Id)
+ or else Is_Overloadable (Id)
+ or else Ekind (Id) in E_Entry_Family
+ | E_Subprogram_Body
+ | E_Subprogram_Type);
+
+ if Ekind (Id) = E_Enumeration_Literal then
+ return Empty;
+
+ else
+ Formal := First_Entity (Id);
+
+ -- The first/next entity chain of a generic subprogram contains all
+ -- generic formal parameters, followed by the formal parameters. Go
+ -- directly to the parameters by skipping the formal part.
+
+ if Is_Generic_Subprogram (Id) then
+ while Present (Formal) and then not Is_Formal (Formal) loop
+ Next_Entity (Formal);
+ end loop;
+ end if;
+
+ if Present (Formal) and then Is_Formal (Formal) then
+ return Formal;
+ else
+ return Extra_Formals (Id); -- Empty if no extra formals
+ end if;
+ end if;
+ end First_Formal_With_Extras;
+
+ ---------------
+ -- Float_Rep --
+ ---------------
+
+ function Float_Rep (N : Entity_Id) return Float_Rep_Kind is
+ pragma Unreferenced (N);
+ pragma Assert (Float_Rep_Kind'First = Float_Rep_Kind'Last);
+
+ -- There is only one value, so we don't need to store it, see types.ads.
+
+ Val : constant Float_Rep_Kind := IEEE_Binary;
+
+ begin
+ return Val;
+ end Float_Rep;
+
+ -------------------------------------
+ -- Get_Attribute_Definition_Clause --
+ -------------------------------------
+
+ function Get_Attribute_Definition_Clause
+ (E : Entity_Id;
+ Id : Attribute_Id) return Node_Id
+ is
+ N : Node_Id;
+
+ begin
+ N := First_Rep_Item (E);
+ while Present (N) loop
+ if Nkind (N) = N_Attribute_Definition_Clause
+ and then Get_Attribute_Id (Chars (N)) = Id
+ then
+ return N;
+ else
+ Next_Rep_Item (N);
+ end if;
+ end loop;
+
+ return Empty;
+ end Get_Attribute_Definition_Clause;
+
+ ---------------------------
+ -- Get_Class_Wide_Pragma --
+ ---------------------------
+
+ function Get_Class_Wide_Pragma
+ (E : Entity_Id;
+ Id : Pragma_Id) return Node_Id
+ is
+ Item : Node_Id;
+ Items : Node_Id;
+
+ begin
+ Items := Contract (E);
+
+ if No (Items) then
+ return Empty;
+ end if;
+
+ Item := Pre_Post_Conditions (Items);
+ while Present (Item) loop
+ if Nkind (Item) = N_Pragma
+ and then Get_Pragma_Id (Pragma_Name_Unmapped (Item)) = Id
+ and then Class_Present (Item)
+ then
+ return Item;
+ end if;
+
+ Item := Next_Pragma (Item);
+ end loop;
+
+ return Empty;
+ end Get_Class_Wide_Pragma;
+
+ -------------------
+ -- Get_Full_View --
+ -------------------
+
+ function Get_Full_View (T : Entity_Id) return Entity_Id is
+ begin
+ if Is_Incomplete_Type (T) and then Present (Full_View (T)) then
+ return Full_View (T);
+
+ elsif Is_Class_Wide_Type (T)
+ and then Is_Incomplete_Type (Root_Type (T))
+ and then Present (Full_View (Root_Type (T)))
+ then
+ return Class_Wide_Type (Full_View (Root_Type (T)));
+
+ else
+ return T;
+ end if;
+ end Get_Full_View;
+
+ ----------------
+ -- Get_Pragma --
+ ----------------
+
+ function Get_Pragma (E : Entity_Id; Id : Pragma_Id) return Node_Id is
+
+ -- Classification pragmas
+
+ Is_CLS : constant Boolean :=
+ Id = Pragma_Abstract_State or else
+ Id = Pragma_Attach_Handler or else
+ Id = Pragma_Async_Readers or else
+ Id = Pragma_Async_Writers or else
+ Id = Pragma_Constant_After_Elaboration or else
+ Id = Pragma_Depends or else
+ Id = Pragma_Effective_Reads or else
+ Id = Pragma_Effective_Writes or else
+ Id = Pragma_Extensions_Visible or else
+ Id = Pragma_Global or else
+ Id = Pragma_Initial_Condition or else
+ Id = Pragma_Initializes or else
+ Id = Pragma_Interrupt_Handler or else
+ Id = Pragma_No_Caching or else
+ Id = Pragma_Part_Of or else
+ Id = Pragma_Refined_Depends or else
+ Id = Pragma_Refined_Global or else
+ Id = Pragma_Refined_State or else
+ Id = Pragma_Volatile_Function;
+
+ -- Contract / subprogram variant / test case pragmas
+
+ Is_CTC : constant Boolean :=
+ Id = Pragma_Contract_Cases or else
+ Id = Pragma_Subprogram_Variant or else
+ Id = Pragma_Test_Case;
+
+ -- Pre / postcondition pragmas
+
+ Is_PPC : constant Boolean :=
+ Id = Pragma_Precondition or else
+ Id = Pragma_Postcondition or else
+ Id = Pragma_Refined_Post;
+
+ In_Contract : constant Boolean := Is_CLS or Is_CTC or Is_PPC;
+
+ Item : Node_Id;
+ Items : Node_Id;
+
+ begin
+ -- Handle pragmas that appear in N_Contract nodes. Those have to be
+ -- extracted from their specialized list.
+
+ if In_Contract then
+ Items := Contract (E);
+
+ if No (Items) then
+ return Empty;
+
+ elsif Is_CLS then
+ Item := Classifications (Items);
+
+ elsif Is_CTC then
+ Item := Contract_Test_Cases (Items);
+
+ else
+ Item := Pre_Post_Conditions (Items);
+ end if;
+
+ -- Regular pragmas
+
+ else
+ Item := First_Rep_Item (E);
+ end if;
+
+ while Present (Item) loop
+ if Nkind (Item) = N_Pragma
+ and then Get_Pragma_Id (Pragma_Name_Unmapped (Item)) = Id
+ then
+ return Item;
+
+ -- All nodes in N_Contract are chained using Next_Pragma
+
+ elsif In_Contract then
+ Item := Next_Pragma (Item);
+
+ -- Regular pragmas
+
+ else
+ Next_Rep_Item (Item);
+ end if;
+ end loop;
+
+ return Empty;
+ end Get_Pragma;
+
+ --------------------------------------
+ -- Get_Record_Representation_Clause --
+ --------------------------------------
+
+ function Get_Record_Representation_Clause (E : Entity_Id) return Node_Id is
+ N : Node_Id;
+
+ begin
+ N := First_Rep_Item (E);
+ while Present (N) loop
+ if Nkind (N) = N_Record_Representation_Clause then
+ return N;
+ end if;
+
+ Next_Rep_Item (N);
+ end loop;
+
+ return Empty;
+ end Get_Record_Representation_Clause;
+
+ ------------------------
+ -- Has_Attach_Handler --
+ ------------------------
+
+ function Has_Attach_Handler (Id : E) return B is
+ Ritem : Node_Id;
+
+ begin
+ pragma Assert (Is_Protected_Type (Id));
+
+ Ritem := First_Rep_Item (Id);
+ while Present (Ritem) loop
+ if Nkind (Ritem) = N_Pragma
+ and then Pragma_Name (Ritem) = Name_Attach_Handler
+ then
+ return True;
+ else
+ Next_Rep_Item (Ritem);
+ end if;
+ end loop;
+
+ return False;
+ end Has_Attach_Handler;
+
+ -------------
+ -- Has_DIC --
+ -------------
+
+ function Has_DIC (Id : E) return B is
+ begin
+ return Has_Own_DIC (Id) or else Has_Inherited_DIC (Id);
+ end Has_DIC;
+
+ -----------------
+ -- Has_Entries --
+ -----------------
+
+ function Has_Entries (Id : E) return B is
+ Ent : Entity_Id;
+
+ begin
+ pragma Assert (Is_Concurrent_Type (Id));
+
+ Ent := First_Entity (Id);
+ while Present (Ent) loop
+ if Is_Entry (Ent) then
+ return True;
+ end if;
+
+ Next_Entity (Ent);
+ end loop;
+
+ return False;
+ end Has_Entries;
+
+ ----------------------------
+ -- Has_Foreign_Convention --
+ ----------------------------
+
+ function Has_Foreign_Convention (Id : E) return B is
+ begin
+ -- While regular Intrinsics such as the Standard operators fit in the
+ -- "Ada" convention, those with an Interface_Name materialize GCC
+ -- builtin imports for which Ada special treatments shouldn't apply.
+
+ return Convention (Id) in Foreign_Convention
+ or else (Convention (Id) = Convention_Intrinsic
+ and then Present (Interface_Name (Id)));
+ end Has_Foreign_Convention;
+
+ ---------------------------
+ -- Has_Interrupt_Handler --
+ ---------------------------
+
+ function Has_Interrupt_Handler (Id : E) return B is
+ Ritem : Node_Id;
+
+ begin
+ pragma Assert (Is_Protected_Type (Id));
+
+ Ritem := First_Rep_Item (Id);
+ while Present (Ritem) loop
+ if Nkind (Ritem) = N_Pragma
+ and then Pragma_Name (Ritem) = Name_Interrupt_Handler
+ then
+ return True;
+ else
+ Next_Rep_Item (Ritem);
+ end if;
+ end loop;
+
+ return False;
+ end Has_Interrupt_Handler;
+
+ --------------------
+ -- Has_Invariants --
+ --------------------
+
+ function Has_Invariants (Id : E) return B is
+ begin
+ return Has_Own_Invariants (Id) or else Has_Inherited_Invariants (Id);
+ end Has_Invariants;
+
+ --------------------------
+ -- Has_Limited_View --
+ --------------------------
+
+ function Has_Limited_View (Id : E) return B is
+ begin
+ return Ekind (Id) = E_Package
+ and then not Is_Generic_Instance (Id)
+ and then Present (Limited_View (Id));
+ end Has_Limited_View;
+
+ --------------------------
+ -- Has_Non_Limited_View --
+ --------------------------
+
+ function Has_Non_Limited_View (Id : E) return B is
+ begin
+ return (Ekind (Id) in Incomplete_Kind
+ or else Ekind (Id) in Class_Wide_Kind
+ or else Ekind (Id) = E_Abstract_State)
+ and then Present (Non_Limited_View (Id));
+ end Has_Non_Limited_View;
+
+ ---------------------------------
+ -- Has_Non_Null_Abstract_State --
+ ---------------------------------
+
+ function Has_Non_Null_Abstract_State (Id : E) return B is
+ begin
+ pragma Assert (Is_Package_Or_Generic_Package (Id));
+
+ return
+ Present (Abstract_States (Id))
+ and then
+ not Is_Null_State (Node (First_Elmt (Abstract_States (Id))));
+ end Has_Non_Null_Abstract_State;
+
+ -------------------------------------
+ -- Has_Non_Null_Visible_Refinement --
+ -------------------------------------
+
+ function Has_Non_Null_Visible_Refinement (Id : E) return B is
+ Constits : Elist_Id;
+
+ begin
+ -- "Refinement" is a concept applicable only to abstract states
+
+ pragma Assert (Ekind (Id) = E_Abstract_State);
+ Constits := Refinement_Constituents (Id);
+
+ -- A partial refinement is always non-null. For a full refinement to be
+ -- non-null, the first constituent must be anything other than null.
+
+ return
+ Has_Partial_Visible_Refinement (Id)
+ or else (Has_Visible_Refinement (Id)
+ and then Present (Constits)
+ and then Nkind (Node (First_Elmt (Constits))) /= N_Null);
+ end Has_Non_Null_Visible_Refinement;
+
+ -----------------------------
+ -- Has_Null_Abstract_State --
+ -----------------------------
+
+ function Has_Null_Abstract_State (Id : E) return B is
+ pragma Assert (Is_Package_Or_Generic_Package (Id));
+
+ States : constant Elist_Id := Abstract_States (Id);
+
+ begin
+ -- Check first available state of related package. A null abstract
+ -- state always appears as the sole element of the state list.
+
+ return
+ Present (States)
+ and then Is_Null_State (Node (First_Elmt (States)));
+ end Has_Null_Abstract_State;
+
+ ---------------------------------
+ -- Has_Null_Visible_Refinement --
+ ---------------------------------
+
+ function Has_Null_Visible_Refinement (Id : E) return B is
+ Constits : Elist_Id;
+
+ begin
+ -- "Refinement" is a concept applicable only to abstract states
+
+ pragma Assert (Ekind (Id) = E_Abstract_State);
+ Constits := Refinement_Constituents (Id);
+
+ -- For a refinement to be null, the state's sole constituent must be a
+ -- null.
+
+ return
+ Has_Visible_Refinement (Id)
+ and then Present (Constits)
+ and then Nkind (Node (First_Elmt (Constits))) = N_Null;
+ end Has_Null_Visible_Refinement;
+
+ --------------------
+ -- Has_Unmodified --
+ --------------------
+
+ function Has_Unmodified (E : Entity_Id) return Boolean is
+ begin
+ if Has_Pragma_Unmodified (E) then
+ return True;
+ elsif Warnings_Off (E) then
+ Set_Warnings_Off_Used_Unmodified (E);
+ return True;
+ else
+ return False;
+ end if;
+ end Has_Unmodified;
+
+ ---------------------
+ -- Has_Unreferenced --
+ ---------------------
+
+ function Has_Unreferenced (E : Entity_Id) return Boolean is
+ begin
+ if Has_Pragma_Unreferenced (E) then
+ return True;
+ elsif Warnings_Off (E) then
+ Set_Warnings_Off_Used_Unreferenced (E);
+ return True;
+ else
+ return False;
+ end if;
+ end Has_Unreferenced;
+
+ ----------------------
+ -- Has_Warnings_Off --
+ ----------------------
+
+ function Has_Warnings_Off (E : Entity_Id) return Boolean is
+ begin
+ if Warnings_Off (E) then
+ Set_Warnings_Off_Used (E);
+ return True;
+ else
+ return False;
+ end if;
+ end Has_Warnings_Off;
+
+ ------------------------------
+ -- Implementation_Base_Type --
+ ------------------------------
+
+ function Implementation_Base_Type (Id : E) return E is
+ Bastyp : Entity_Id;
+ Imptyp : Entity_Id;
+
+ begin
+ Bastyp := Base_Type (Id);
+
+ if Is_Incomplete_Or_Private_Type (Bastyp) then
+ Imptyp := Underlying_Type (Bastyp);
+
+ -- If we have an implementation type, then just return it,
+ -- otherwise we return the Base_Type anyway. This can only
+ -- happen in error situations and should avoid some error bombs.
+
+ if Present (Imptyp) then
+ return Base_Type (Imptyp);
+ else
+ return Bastyp;
+ end if;
+
+ else
+ return Bastyp;
+ end if;
+ end Implementation_Base_Type;
+
+ -------------------------
+ -- Invariant_Procedure --
+ -------------------------
+
+ function Invariant_Procedure (Id : E) return E is
+ Subp_Elmt : Elmt_Id;
+ Subp_Id : Entity_Id;
+ Subps : Elist_Id;
+
+ begin
+ pragma Assert (Is_Type (Id));
+
+ Subps := Subprograms_For_Type (Base_Type (Id));
+
+ if Present (Subps) then
+ Subp_Elmt := First_Elmt (Subps);
+ while Present (Subp_Elmt) loop
+ Subp_Id := Node (Subp_Elmt);
+
+ if Is_Invariant_Procedure (Subp_Id) then
+ return Subp_Id;
+ end if;
+
+ Next_Elmt (Subp_Elmt);
+ end loop;
+ end if;
+
+ return Empty;
+ end Invariant_Procedure;
+
+ ------------------
+ -- Is_Base_Type --
+ ------------------
+
+ -- Global flag table allowing rapid computation of this function
+
+ Entity_Is_Base_Type : constant array (Entity_Kind) of Boolean :=
+ (E_Enumeration_Subtype |
+ E_Incomplete_Subtype |
+ E_Signed_Integer_Subtype |
+ E_Modular_Integer_Subtype |
+ E_Floating_Point_Subtype |
+ E_Ordinary_Fixed_Point_Subtype |
+ E_Decimal_Fixed_Point_Subtype |
+ E_Array_Subtype |
+ E_Record_Subtype |
+ E_Private_Subtype |
+ E_Record_Subtype_With_Private |
+ E_Limited_Private_Subtype |
+ E_Access_Subtype |
+ E_Protected_Subtype |
+ E_Task_Subtype |
+ E_String_Literal_Subtype |
+ E_Class_Wide_Subtype => False,
+ others => True);
+
+ function Is_Base_Type (Id : E) return Boolean is
+ begin
+ return Entity_Is_Base_Type (Ekind (Id));
+ end Is_Base_Type;
+
+ ---------------------
+ -- Is_Boolean_Type --
+ ---------------------
+
+ function Is_Boolean_Type (Id : E) return B is
+ begin
+ return Root_Type (Id) = Standard_Boolean;
+ end Is_Boolean_Type;
+
+ ------------------------
+ -- Is_Constant_Object --
+ ------------------------
+
+ function Is_Constant_Object (Id : E) return B is
+ begin
+ return Ekind (Id) in E_Constant | E_In_Parameter | E_Loop_Parameter;
+ end Is_Constant_Object;
+
+ -------------------
+ -- Is_Controlled --
+ -------------------
+
+ function Is_Controlled (Id : E) return B is
+ begin
+ return Is_Controlled_Active (Id) and then not Disable_Controlled (Id);
+ end Is_Controlled;
+
+ --------------------
+ -- Is_Discriminal --
+ --------------------
+
+ function Is_Discriminal (Id : E) return B is
+ begin
+ return Ekind (Id) in E_Constant | E_In_Parameter
+ and then Present (Discriminal_Link (Id));
+ end Is_Discriminal;
+
+ ----------------------
+ -- Is_Dynamic_Scope --
+ ----------------------
+
+ function Is_Dynamic_Scope (Id : E) return B is
+ begin
+ return
+ Ekind (Id) = E_Block
+ or else
+ Ekind (Id) = E_Function
+ or else
+ Ekind (Id) = E_Procedure
+ or else
+ Ekind (Id) = E_Subprogram_Body
+ or else
+ Ekind (Id) = E_Task_Type
+ or else
+ (Ekind (Id) = E_Limited_Private_Type
+ and then Present (Full_View (Id))
+ and then Ekind (Full_View (Id)) = E_Task_Type)
+ or else
+ Ekind (Id) = E_Entry
+ or else
+ Ekind (Id) = E_Entry_Family
+ or else
+ Ekind (Id) = E_Return_Statement;
+ end Is_Dynamic_Scope;
+
+ --------------------
+ -- Is_Entity_Name --
+ --------------------
+
+ function Is_Entity_Name (N : Node_Id) return Boolean is
+ Kind : constant Node_Kind := Nkind (N);
+
+ begin
+ -- Identifiers, operator symbols, expanded names are entity names
+
+ return Kind = N_Identifier
+ or else Kind = N_Operator_Symbol
+ or else Kind = N_Expanded_Name
+
+ -- Attribute references are entity names if they refer to an entity.
+ -- Note that we don't do this by testing for the presence of the
+ -- Entity field in the N_Attribute_Reference node, since it may not
+ -- have been set yet.
+
+ or else (Kind = N_Attribute_Reference
+ and then Is_Entity_Attribute_Name (Attribute_Name (N)));
+ end Is_Entity_Name;
+
+ ---------------------------
+ -- Is_Elaboration_Target --
+ ---------------------------
+
+ function Is_Elaboration_Target (Id : Entity_Id) return Boolean is
+ begin
+ return
+ 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)
+ or else Is_Task_Type (Id);
+ end Is_Elaboration_Target;
+
+ -----------------------
+ -- Is_External_State --
+ -----------------------
+
+ function Is_External_State (Id : E) return B is
+ begin
+ -- To qualify, the abstract state must appear with option "external" or
+ -- "synchronous" (SPARK RM 7.1.4(7) and (9)).
+
+ return
+ Ekind (Id) = E_Abstract_State
+ and then (Has_Option (Id, Name_External)
+ or else
+ Has_Option (Id, Name_Synchronous));
+ end Is_External_State;
+
+ ------------------
+ -- Is_Finalizer --
+ ------------------
+
+ function Is_Finalizer (Id : E) return B is
+ begin
+ return Ekind (Id) = E_Procedure and then Chars (Id) = Name_uFinalizer;
+ end Is_Finalizer;
+
+ ----------------------
+ -- Is_Full_Access --
+ ----------------------
+
+ function Is_Full_Access (Id : E) return B is
+ begin
+ return Is_Atomic (Id) or else Is_Volatile_Full_Access (Id);
+ end Is_Full_Access;
+
+ -------------------
+ -- Is_Null_State --
+ -------------------
+
+ function Is_Null_State (Id : E) return B is
+ begin
+ return
+ 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 --
+ ---------------------
+
+ function Is_Packed_Array (Id : E) return B is
+ begin
+ return Is_Array_Type (Id) and then Is_Packed (Id);
+ end Is_Packed_Array;
+
+ ---------------
+ -- Is_Prival --
+ ---------------
+
+ function Is_Prival (Id : E) return B is
+ begin
+ return Ekind (Id) in E_Constant | E_Variable
+ and then Present (Prival_Link (Id));
+ end Is_Prival;
+
+ ----------------------------
+ -- Is_Protected_Component --
+ ----------------------------
+
+ function Is_Protected_Component (Id : E) return B is
+ begin
+ return Ekind (Id) = E_Component and then Is_Protected_Type (Scope (Id));
+ end Is_Protected_Component;
+
+ ----------------------------
+ -- Is_Protected_Interface --
+ ----------------------------
+
+ function Is_Protected_Interface (Id : E) return B is
+ Typ : constant Entity_Id := Base_Type (Id);
+ begin
+ if not Is_Interface (Typ) then
+ return False;
+ elsif Is_Class_Wide_Type (Typ) then
+ return Is_Protected_Interface (Etype (Typ));
+ else
+ return Protected_Present (Type_Definition (Parent (Typ)));
+ end if;
+ end Is_Protected_Interface;
+
+ ------------------------------
+ -- Is_Protected_Record_Type --
+ ------------------------------
+
+ function Is_Protected_Record_Type (Id : E) return B is
+ begin
+ return
+ Is_Concurrent_Record_Type (Id)
+ 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 --
+ --------------------------------
+
+ function Is_Standard_Character_Type (Id : E) return B is
+ begin
+ return Is_Type (Id)
+ and then Root_Type (Id) in Standard_Character
+ | Standard_Wide_Character
+ | Standard_Wide_Wide_Character;
+ end Is_Standard_Character_Type;
+
+ -----------------------------
+ -- Is_Standard_String_Type --
+ -----------------------------
+
+ function Is_Standard_String_Type (Id : E) return B is
+ begin
+ return Is_Type (Id)
+ and then Root_Type (Id) in Standard_String
+ | Standard_Wide_String
+ | Standard_Wide_Wide_String;
+ end Is_Standard_String_Type;
+
+ --------------------
+ -- Is_String_Type --
+ --------------------
+
+ function Is_String_Type (Id : E) return B is
+ begin
+ return Is_Array_Type (Id)
+ and then Id /= Any_Composite
+ and then Number_Dimensions (Id) = 1
+ and then Is_Character_Type (Component_Type (Id));
+ end Is_String_Type;
+
+ -------------------------------
+ -- Is_Synchronized_Interface --
+ -------------------------------
+
+ function Is_Synchronized_Interface (Id : E) return B is
+ Typ : constant Entity_Id := Base_Type (Id);
+
+ begin
+ if not Is_Interface (Typ) then
+ return False;
+
+ elsif Is_Class_Wide_Type (Typ) then
+ return Is_Synchronized_Interface (Etype (Typ));
+
+ else
+ return Protected_Present (Type_Definition (Parent (Typ)))
+ or else Synchronized_Present (Type_Definition (Parent (Typ)))
+ or else Task_Present (Type_Definition (Parent (Typ)));
+ end if;
+ end Is_Synchronized_Interface;
+
+ ---------------------------
+ -- Is_Synchronized_State --
+ ---------------------------
+
+ function Is_Synchronized_State (Id : E) return B is
+ begin
+ -- To qualify, the abstract state must appear with simple option
+ -- "synchronous" (SPARK RM 7.1.4(9)).
+
+ return
+ Ekind (Id) = E_Abstract_State
+ and then Has_Option (Id, Name_Synchronous);
+ end Is_Synchronized_State;
+
+ -----------------------
+ -- Is_Task_Interface --
+ -----------------------
+
+ function Is_Task_Interface (Id : E) return B is
+ Typ : constant Entity_Id := Base_Type (Id);
+ begin
+ if not Is_Interface (Typ) then
+ return False;
+ elsif Is_Class_Wide_Type (Typ) then
+ return Is_Task_Interface (Etype (Typ));
+ else
+ return Task_Present (Type_Definition (Parent (Typ)));
+ end if;
+ end Is_Task_Interface;
+
+ -------------------------
+ -- Is_Task_Record_Type --
+ -------------------------
+
+ function Is_Task_Record_Type (Id : E) return B is
+ begin
+ return
+ Is_Concurrent_Record_Type (Id)
+ and then Is_Task_Type (Corresponding_Concurrent_Type (Id));
+ end Is_Task_Record_Type;
+
+ ------------------------
+ -- Is_Wrapper_Package --
+ ------------------------
+
+ function Is_Wrapper_Package (Id : E) return B is
+ begin
+ return Ekind (Id) = E_Package and then Present (Related_Instance (Id));
+ end Is_Wrapper_Package;
+
+ -----------------
+ -- Last_Formal --
+ -----------------
+
+ function Last_Formal (Id : E) return E is
+ Formal : Entity_Id;
+
+ begin
+ pragma Assert
+ (Is_Overloadable (Id)
+ or else Ekind (Id) in E_Entry_Family
+ | E_Subprogram_Body
+ | E_Subprogram_Type);
+
+ if Ekind (Id) = E_Enumeration_Literal then
+ return Empty;
+
+ else
+ Formal := First_Formal (Id);
+
+ if Present (Formal) then
+ while Present (Next_Formal (Formal)) loop
+ Next_Formal (Formal);
+ end loop;
+ end if;
+
+ return Formal;
+ end if;
+ end Last_Formal;
+
+ -------------------
+ -- Link_Entities --
+ -------------------
+
+ procedure Link_Entities (First : Entity_Id; Second : Node_Id) is
+ begin
+ if Present (Second) then
+ Set_Prev_Entity (Second, First); -- First <-- Second
+ end if;
+
+ Set_Next_Entity (First, Second); -- First --> Second
+ end Link_Entities;
+
+ ------------------------
+ -- Machine_Emax_Value --
+ ------------------------
+
+ function Machine_Emax_Value (Id : E) return Uint is
+ Digs : constant Pos := UI_To_Int (Digits_Value (Base_Type (Id)));
+
+ begin
+ case Float_Rep (Id) is
+ when IEEE_Binary =>
+ case Digs is
+ when 1 .. 6 => return Uint_128;
+ when 7 .. 15 => return 2**10;
+ when 16 .. 33 => return 2**14;
+ when others => return No_Uint;
+ end case;
+ end case;
+ end Machine_Emax_Value;
+
+ ------------------------
+ -- Machine_Emin_Value --
+ ------------------------
+
+ function Machine_Emin_Value (Id : E) return Uint is
+ begin
+ case Float_Rep (Id) is
+ when IEEE_Binary => return Uint_3 - Machine_Emax_Value (Id);
+ end case;
+ end Machine_Emin_Value;
+
+ ----------------------------
+ -- Machine_Mantissa_Value --
+ ----------------------------
+
+ function Machine_Mantissa_Value (Id : E) return Uint is
+ Digs : constant Pos := UI_To_Int (Digits_Value (Base_Type (Id)));
+
+ begin
+ case Float_Rep (Id) is
+ when IEEE_Binary =>
+ case Digs is
+ when 1 .. 6 => return Uint_24;
+ when 7 .. 15 => return UI_From_Int (53);
+ when 16 .. 18 => return Uint_64;
+ when 19 .. 33 => return UI_From_Int (113);
+ when others => return No_Uint;
+ end case;
+ end case;
+ end Machine_Mantissa_Value;
+
+ -------------------------
+ -- Machine_Radix_Value --
+ -------------------------
+
+ function Machine_Radix_Value (Id : E) return U is
+ begin
+ case Float_Rep (Id) is
+ when IEEE_Binary =>
+ return Uint_2;
+ 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 --
+ --------------------
+
+ function Next_Component (Id : E) return E is
+ Comp_Id : Entity_Id;
+
+ begin
+ Comp_Id := Next_Entity (Id);
+ while Present (Comp_Id) loop
+ exit when Ekind (Comp_Id) = E_Component;
+ Next_Entity (Comp_Id);
+ end loop;
+
+ return Comp_Id;
+ end Next_Component;
+
+ ------------------------------------
+ -- Next_Component_Or_Discriminant --
+ ------------------------------------
+
+ function Next_Component_Or_Discriminant (Id : E) return E is
+ Comp_Id : Entity_Id;
+
+ begin
+ Comp_Id := Next_Entity (Id);
+ while Present (Comp_Id) loop
+ exit when Ekind (Comp_Id) in E_Component | E_Discriminant;
+ Next_Entity (Comp_Id);
+ end loop;
+
+ return Comp_Id;
+ end Next_Component_Or_Discriminant;
+
+ -----------------------
+ -- Next_Discriminant --
+ -----------------------
+
+ -- This function actually implements both Next_Discriminant and
+ -- Next_Stored_Discriminant by making sure that the Discriminant
+ -- returned is of the same variety as Id.
+
+ function Next_Discriminant (Id : E) return E is
+
+ -- Derived Tagged types with private extensions look like this...
+
+ -- E_Discriminant d1
+ -- E_Discriminant d2
+ -- E_Component _tag
+ -- E_Discriminant d1
+ -- E_Discriminant d2
+ -- ...
+
+ -- so it is critical not to go past the leading discriminants
+
+ D : E := Id;
+
+ begin
+ pragma Assert (Ekind (Id) = E_Discriminant);
+
+ loop
+ Next_Entity (D);
+ if No (D)
+ or else (Ekind (D) /= E_Discriminant
+ and then not Is_Itype (D))
+ then
+ return Empty;
+ end if;
+
+ exit when Ekind (D) = E_Discriminant
+ and then (Is_Completely_Hidden (D) = Is_Completely_Hidden (Id));
+ end loop;
+
+ return D;
+ end Next_Discriminant;
+
+ -----------------
+ -- Next_Formal --
+ -----------------
+
+ function Next_Formal (Id : E) return E is
+ P : Entity_Id;
+
+ begin
+ -- Follow the chain of declared entities as long as the kind of the
+ -- entity corresponds to a formal parameter. Skip internal entities
+ -- that may have been created for implicit subtypes, in the process
+ -- of analyzing default expressions.
+
+ P := Id;
+ loop
+ Next_Entity (P);
+
+ if No (P) or else Is_Formal (P) then
+ return P;
+ elsif not Is_Internal (P) then
+ return Empty;
+ end if;
+ end loop;
+ end Next_Formal;
+
+ -----------------------------
+ -- Next_Formal_With_Extras --
+ -----------------------------
+
+ function Next_Formal_With_Extras (Id : E) return E is
+ begin
+ if Present (Extra_Formal (Id)) then
+ return Extra_Formal (Id);
+ else
+ return Next_Formal (Id);
+ end if;
+ end Next_Formal_With_Extras;
+
+ ----------------
+ -- Next_Index --
+ ----------------
+
+ function Next_Index (Id : Node_Id) return Node_Id is
+ begin
+ return Next (Id);
+ end Next_Index;
+
+ ------------------
+ -- Next_Literal --
+ ------------------
+
+ function Next_Literal (Id : E) return E is
+ begin
+ pragma Assert (Nkind (Id) in N_Entity);
+ return Next (Id);
+ end Next_Literal;
+
+ ------------------------------
+ -- Next_Stored_Discriminant --
+ ------------------------------
+
+ function Next_Stored_Discriminant (Id : E) return E is
+ begin
+ -- See comment in Next_Discriminant
+
+ return Next_Discriminant (Id);
+ end Next_Stored_Discriminant;
+
+ -----------------------
+ -- Number_Dimensions --
+ -----------------------
+
+ function Number_Dimensions (Id : E) return Pos is
+ N : Int;
+ T : Node_Id;
+
+ begin
+ if Ekind (Id) = E_String_Literal_Subtype then
+ return 1;
+
+ else
+ N := 0;
+ T := First_Index (Id);
+ while Present (T) loop
+ N := N + 1;
+ Next_Index (T);
+ end loop;
+
+ return N;
+ end if;
+ end Number_Dimensions;
+
+ --------------------
+ -- Number_Entries --
+ --------------------
+
+ function Number_Entries (Id : E) return Nat is
+ N : Int;
+ Ent : Entity_Id;
+
+ begin
+ pragma Assert (Is_Concurrent_Type (Id));
+
+ N := 0;
+ Ent := First_Entity (Id);
+ while Present (Ent) loop
+ if Is_Entry (Ent) then
+ N := N + 1;
+ end if;
+
+ Next_Entity (Ent);
+ end loop;
+
+ return N;
+ end Number_Entries;
+
+ --------------------
+ -- Number_Formals --
+ --------------------
+
+ function Number_Formals (Id : E) return Pos is
+ N : Int;
+ Formal : Entity_Id;
+
+ begin
+ N := 0;
+ Formal := First_Formal (Id);
+ while Present (Formal) loop
+ N := N + 1;
+ Next_Formal (Formal);
+ end loop;
+
+ return N;
+ end Number_Formals;
+
+ ------------------------
+ -- Object_Size_Clause --
+ ------------------------
+
+ function Object_Size_Clause (Id : E) return N is
+ begin
+ return Get_Attribute_Definition_Clause (Id, Attribute_Object_Size);
+ end Object_Size_Clause;
+
+ --------------------
+ -- Parameter_Mode --
+ --------------------
+
+ function Parameter_Mode (Id : E) return Formal_Kind is
+ begin
+ return Ekind (Id);
+ end Parameter_Mode;
+
+ -------------------
+ -- DIC_Procedure --
+ -------------------
+
+ function DIC_Procedure (Id : E) return E is
+ Subp_Elmt : Elmt_Id;
+ Subp_Id : Entity_Id;
+ Subps : Elist_Id;
+
+ begin
+ pragma Assert (Is_Type (Id));
+
+ Subps := Subprograms_For_Type (Base_Type (Id));
+
+ if Present (Subps) then
+ Subp_Elmt := First_Elmt (Subps);
+ while Present (Subp_Elmt) loop
+ Subp_Id := Node (Subp_Elmt);
+
+ -- Currently the flag Is_DIC_Procedure is set for both normal DIC
+ -- check procedures as well as for partial DIC check procedures,
+ -- and we don't have a flag for the partial procedures.
+
+ if Is_DIC_Procedure (Subp_Id)
+ and then not Is_Partial_DIC_Procedure (Subp_Id)
+ then
+ return Subp_Id;
+ end if;
+
+ Next_Elmt (Subp_Elmt);
+ end loop;
+ end if;
+
+ return Empty;
+ end DIC_Procedure;
+
+ function Partial_DIC_Procedure (Id : E) return E is
+ Subp_Elmt : Elmt_Id;
+ Subp_Id : Entity_Id;
+ Subps : Elist_Id;
+
+ begin
+ pragma Assert (Is_Type (Id));
+
+ Subps := Subprograms_For_Type (Base_Type (Id));
+
+ if Present (Subps) then
+ Subp_Elmt := First_Elmt (Subps);
+ while Present (Subp_Elmt) loop
+ Subp_Id := Node (Subp_Elmt);
+
+ if Is_Partial_DIC_Procedure (Subp_Id) then
+ return Subp_Id;
+ end if;
+
+ Next_Elmt (Subp_Elmt);
+ end loop;
+ end if;
+
+ return Empty;
+ end Partial_DIC_Procedure;
+
+ function Is_Partial_DIC_Procedure (Id : E) return B is
+ Partial_DIC_Suffix : constant String := "Partial_DIC";
+ DIC_Nam : constant String := Get_Name_String (Chars (Id));
+
+ begin
+ pragma Assert (Ekind (Id) in E_Function | E_Procedure);
+
+ -- Instead of adding a new Entity_Id flag (which are in short supply),
+ -- we test the form of the subprogram name. When the node field and flag
+ -- situation is eased, this should be replaced with a flag. ???
+
+ if DIC_Nam'Length > Partial_DIC_Suffix'Length
+ and then
+ DIC_Nam
+ (DIC_Nam'Last - Partial_DIC_Suffix'Length + 1 .. DIC_Nam'Last) =
+ Partial_DIC_Suffix
+ then
+ return True;
+ else
+ return False;
+ end if;
+ end Is_Partial_DIC_Procedure;
+
+ ---------------------------------
+ -- Partial_Invariant_Procedure --
+ ---------------------------------
+
+ function Partial_Invariant_Procedure (Id : E) return E is
+ Subp_Elmt : Elmt_Id;
+ Subp_Id : Entity_Id;
+ Subps : Elist_Id;
+
+ begin
+ pragma Assert (Is_Type (Id));
+
+ Subps := Subprograms_For_Type (Base_Type (Id));
+
+ if Present (Subps) then
+ Subp_Elmt := First_Elmt (Subps);
+ while Present (Subp_Elmt) loop
+ Subp_Id := Node (Subp_Elmt);
+
+ if Is_Partial_Invariant_Procedure (Subp_Id) then
+ return Subp_Id;
+ end if;
+
+ Next_Elmt (Subp_Elmt);
+ end loop;
+ end if;
+
+ return Empty;
+ end Partial_Invariant_Procedure;
+
+ -------------------------------------
+ -- Partial_Refinement_Constituents --
+ -------------------------------------
+
+ function Partial_Refinement_Constituents (Id : E) return L is
+ Constits : Elist_Id := No_Elist;
+
+ procedure Add_Usable_Constituents (Item : E);
+ -- Add global item Item and/or its constituents to list Constits when
+ -- they can be used in a global refinement within the current scope. The
+ -- criteria are:
+ -- 1) If Item is an abstract state with full refinement visible, add
+ -- its constituents.
+ -- 2) If Item is an abstract state with only partial refinement
+ -- visible, add both Item and its constituents.
+ -- 3) If Item is an abstract state without a visible refinement, add
+ -- it.
+ -- 4) If Id is not an abstract state, add it.
+
+ procedure Add_Usable_Constituents (List : Elist_Id);
+ -- Apply Add_Usable_Constituents to every constituent in List
+
+ -----------------------------
+ -- Add_Usable_Constituents --
+ -----------------------------
+
+ procedure Add_Usable_Constituents (Item : E) is
+ begin
+ if Ekind (Item) = E_Abstract_State then
+ if Has_Visible_Refinement (Item) then
+ Add_Usable_Constituents (Refinement_Constituents (Item));
+
+ elsif Has_Partial_Visible_Refinement (Item) then
+ Append_New_Elmt (Item, Constits);
+ Add_Usable_Constituents (Part_Of_Constituents (Item));
+
+ else
+ Append_New_Elmt (Item, Constits);
+ end if;
+
+ else
+ Append_New_Elmt (Item, Constits);
+ end if;
+ end Add_Usable_Constituents;
+
+ procedure Add_Usable_Constituents (List : Elist_Id) is
+ Constit_Elmt : Elmt_Id;
+ begin
+ if Present (List) then
+ Constit_Elmt := First_Elmt (List);
+ while Present (Constit_Elmt) loop
+ Add_Usable_Constituents (Node (Constit_Elmt));
+ Next_Elmt (Constit_Elmt);
+ end loop;
+ end if;
+ end Add_Usable_Constituents;
+
+ -- Start of processing for Partial_Refinement_Constituents
+
+ begin
+ -- "Refinement" is a concept applicable only to abstract states
+
+ pragma Assert (Ekind (Id) = E_Abstract_State);
+
+ if Has_Visible_Refinement (Id) then
+ Constits := Refinement_Constituents (Id);
+
+ -- A refinement may be partially visible when objects declared in the
+ -- private part of a package are subject to a Part_Of indicator.
+
+ elsif Has_Partial_Visible_Refinement (Id) then
+ Add_Usable_Constituents (Part_Of_Constituents (Id));
+
+ -- Function should only be called when full or partial refinement is
+ -- visible.
+
+ else
+ raise Program_Error;
+ end if;
+
+ return Constits;
+ end Partial_Refinement_Constituents;
+
+ ------------------------
+ -- Predicate_Function --
+ ------------------------
+
+ function Predicate_Function (Id : E) return E is
+ Subp_Elmt : Elmt_Id;
+ Subp_Id : Entity_Id;
+ Subps : Elist_Id;
+ Typ : Entity_Id;
+
+ begin
+ pragma Assert (Is_Type (Id));
+
+ -- If type is private and has a completion, predicate may be defined on
+ -- the full view.
+
+ if Is_Private_Type (Id)
+ and then
+ (not Has_Predicates (Id) or else No (Subprograms_For_Type (Id)))
+ and then Present (Full_View (Id))
+ then
+ Typ := Full_View (Id);
+
+ 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);
+
+ else
+ Typ := Id;
+ end if;
+
+ Subps := Subprograms_For_Type (Typ);
+
+ if Present (Subps) then
+ Subp_Elmt := First_Elmt (Subps);
+ while Present (Subp_Elmt) loop
+ Subp_Id := Node (Subp_Elmt);
+
+ if Ekind (Subp_Id) = E_Function
+ and then Is_Predicate_Function (Subp_Id)
+ then
+ return Subp_Id;
+ end if;
+
+ Next_Elmt (Subp_Elmt);
+ end loop;
+ end if;
+
+ return Empty;
+ end Predicate_Function;
+
+ --------------------------
+ -- Predicate_Function_M --
+ --------------------------
+
+ function Predicate_Function_M (Id : E) return E is
+ Subp_Elmt : Elmt_Id;
+ Subp_Id : Entity_Id;
+ Subps : Elist_Id;
+ Typ : Entity_Id;
+
+ begin
+ pragma Assert (Is_Type (Id));
+
+ -- If type is private and has a completion, predicate may be defined on
+ -- the full view.
+
+ if Is_Private_Type (Id)
+ and then
+ (not Has_Predicates (Id) or else No (Subprograms_For_Type (Id)))
+ and then Present (Full_View (Id))
+ then
+ Typ := Full_View (Id);
+
+ else
+ Typ := Id;
+ end if;
+
+ Subps := Subprograms_For_Type (Typ);
+
+ if Present (Subps) then
+ Subp_Elmt := First_Elmt (Subps);
+ while Present (Subp_Elmt) loop
+ Subp_Id := Node (Subp_Elmt);
+
+ if Ekind (Subp_Id) = E_Function
+ and then Is_Predicate_Function_M (Subp_Id)
+ then
+ return Subp_Id;
+ end if;
+
+ Next_Elmt (Subp_Elmt);
+ end loop;
+ end if;
+
+ return Empty;
+ end Predicate_Function_M;
+
+ -------------------------
+ -- Present_In_Rep_Item --
+ -------------------------
+
+ function Present_In_Rep_Item (E : Entity_Id; N : Node_Id) return Boolean is
+ Ritem : Node_Id;
+
+ begin
+ Ritem := First_Rep_Item (E);
+
+ while Present (Ritem) loop
+ if Ritem = N then
+ return True;
+ end if;
+
+ Next_Rep_Item (Ritem);
+ end loop;
+
+ return False;
+ end Present_In_Rep_Item;
+
+ --------------------------
+ -- Primitive_Operations --
+ --------------------------
+
+ function Primitive_Operations (Id : E) return L is
+ begin
+ if Is_Concurrent_Type (Id) then
+ if Present (Corresponding_Record_Type (Id)) then
+ return Direct_Primitive_Operations
+ (Corresponding_Record_Type (Id));
+
+ -- When expansion is disabled, the corresponding record type is
+ -- absent, but if this is a tagged type with ancestors, or if the
+ -- extension of prefixed calls for untagged types is enabled, then
+ -- it may have associated primitive operations.
+
+ else
+ return Direct_Primitive_Operations (Id);
+ end if;
+
+ else
+ return Direct_Primitive_Operations (Id);
+ end if;
+ end Primitive_Operations;
+
+ ---------------------
+ -- Record_Rep_Item --
+ ---------------------
+
+ procedure Record_Rep_Item (E : Entity_Id; N : Node_Id) is
+ begin
+ Set_Next_Rep_Item (N, First_Rep_Item (E));
+ Set_First_Rep_Item (E, N);
+ end Record_Rep_Item;
+
+ -------------------
+ -- Remove_Entity --
+ -------------------
+
+ procedure Remove_Entity (Id : Entity_Id) is
+ Next : constant Entity_Id := Next_Entity (Id);
+ Prev : constant Entity_Id := Prev_Entity (Id);
+ Scop : constant Entity_Id := Scope (Id);
+ First : constant Entity_Id := First_Entity (Scop);
+ Last : constant Entity_Id := Last_Entity (Scop);
+
+ begin
+ -- Eliminate any existing linkages from the entity
+
+ Set_Prev_Entity (Id, Empty); -- Empty <-- Id
+ Set_Next_Entity (Id, Empty); -- Id --> Empty
+
+ -- The eliminated entity was the only element in the entity chain
+
+ if Id = First and then Id = Last then
+ Set_First_Entity (Scop, Empty);
+ Set_Last_Entity (Scop, Empty);
+
+ -- The eliminated entity was the head of the entity chain
+
+ elsif Id = First then
+ Set_First_Entity (Scop, Next);
+
+ -- The eliminated entity was the tail of the entity chain
+
+ elsif Id = Last then
+ Set_Last_Entity (Scop, Prev);
+
+ -- Otherwise the eliminated entity comes from the middle of the entity
+ -- chain.
+
+ else
+ Link_Entities (Prev, Next); -- Prev <-- Next, Prev --> Next
+ end if;
+ end Remove_Entity;
+
+ ---------------
+ -- Root_Type --
+ ---------------
+
+ function Root_Type (Id : E) return E is
+ T, Etyp : Entity_Id;
+
+ begin
+ pragma Assert (Nkind (Id) in N_Entity);
+
+ T := Base_Type (Id);
+
+ if Ekind (T) = E_Class_Wide_Type then
+ return Etype (T);
+
+ -- Other cases
+
+ else
+ loop
+ Etyp := Etype (T);
+
+ if T = Etyp then
+ return T;
+
+ -- Following test catches some error cases resulting from
+ -- previous errors.
+
+ elsif No (Etyp) then
+ Check_Error_Detected;
+ return T;
+
+ elsif Is_Private_Type (T) and then Etyp = Full_View (T) then
+ return T;
+
+ elsif Is_Private_Type (Etyp) and then Full_View (Etyp) = T then
+ return T;
+ end if;
+
+ T := Etyp;
+
+ -- Return if there is a circularity in the inheritance chain. This
+ -- happens in some error situations and we do not want to get
+ -- stuck in this loop.
+
+ if T = Base_Type (Id) then
+ return T;
+ end if;
+ end loop;
+ end if;
+ end Root_Type;
+
+ ---------------------
+ -- Safe_Emax_Value --
+ ---------------------
+
+ function Safe_Emax_Value (Id : E) return Uint is
+ begin
+ return Machine_Emax_Value (Id);
+ end Safe_Emax_Value;
+
+ ----------------------
+ -- Safe_First_Value --
+ ----------------------
+
+ function Safe_First_Value (Id : E) return Ureal is
+ begin
+ return -Safe_Last_Value (Id);
+ end Safe_First_Value;
+
+ ---------------------
+ -- Safe_Last_Value --
+ ---------------------
+
+ function Safe_Last_Value (Id : E) return Ureal is
+ Radix : constant Uint := Machine_Radix_Value (Id);
+ Mantissa : constant Uint := Machine_Mantissa_Value (Id);
+ Emax : constant Uint := Safe_Emax_Value (Id);
+ Significand : constant Uint := Radix ** Mantissa - 1;
+ Exponent : constant Uint := Emax - Mantissa;
+
+ begin
+ if Radix = 2 then
+ return
+ UR_From_Components
+ (Num => Significand * 2 ** (Exponent mod 4),
+ Den => -Exponent / 4,
+ Rbase => 16);
+ else
+ return
+ UR_From_Components
+ (Num => Significand,
+ Den => -Exponent,
+ Rbase => 16);
+ end if;
+ end Safe_Last_Value;
+
+ -----------------
+ -- Scope_Depth --
+ -----------------
+
+ function Scope_Depth (Id : E) return Uint is
+ Scop : Entity_Id;
+
+ begin
+ Scop := Id;
+ while Is_Record_Type (Scop) loop
+ Scop := Scope (Scop);
+ end loop;
+
+ return Scope_Depth_Value (Scop);
+ end Scope_Depth;
+
+ ---------------------
+ -- Scope_Depth_Set --
+ ---------------------
+
+ function Scope_Depth_Set (Id : E) return B is
+ begin
+ return not Is_Record_Type (Id)
+ and then not Field_Is_Initial_Zero (Id, F_Scope_Depth_Value);
+ -- We can't call Scope_Depth_Value here, because Empty is not a valid
+ -- value of type Uint.
+ end Scope_Depth_Set;
+
+ --------------------
+ -- Set_Convention --
+ --------------------
+
+ procedure Set_Convention (E : Entity_Id; Val : Snames.Convention_Id) is
+ begin
+ Set_Basic_Convention (E, Val);
+
+ if Ekind (E) in Access_Subprogram_Kind
+ and then Has_Foreign_Convention (E)
+ then
+ Set_Can_Use_Internal_Rep (E, False);
+ end if;
+
+ -- If E is an object, including a component, and the type of E is an
+ -- anonymous access type with no convention set, then also set the
+ -- convention of the anonymous access type. We do not do this for
+ -- anonymous protected types, since protected types always have the
+ -- default convention.
+
+ if Present (Etype (E))
+ and then (Is_Object (E)
+
+ -- Allow E_Void (happens for pragma Convention appearing
+ -- in the middle of a record applying to a component)
+
+ or else Ekind (E) = E_Void)
+ then
+ declare
+ Typ : constant Entity_Id := Etype (E);
+
+ begin
+ if Ekind (Typ) in E_Anonymous_Access_Type
+ | E_Anonymous_Access_Subprogram_Type
+ and then not Has_Convention_Pragma (Typ)
+ then
+ Set_Basic_Convention (Typ, Val);
+ Set_Has_Convention_Pragma (Typ);
+
+ -- And for the access subprogram type, deal similarly with the
+ -- designated E_Subprogram_Type, which is always internal.
+
+ if Ekind (Typ) = E_Anonymous_Access_Subprogram_Type then
+ declare
+ Dtype : constant Entity_Id := Designated_Type (Typ);
+ begin
+ if Ekind (Dtype) = E_Subprogram_Type
+ and then not Has_Convention_Pragma (Dtype)
+ then
+ Set_Basic_Convention (Dtype, Val);
+ Set_Has_Convention_Pragma (Dtype);
+ end if;
+ end;
+ end if;
+ end if;
+ end;
+ end if;
+ end Set_Convention;
+
+ -----------------------
+ -- Set_DIC_Procedure --
+ -----------------------
+
+ procedure Set_DIC_Procedure (Id : E; V : E) is
+ Base_Typ : Entity_Id;
+ Subps : Elist_Id;
+
+ begin
+ pragma Assert (Is_Type (Id));
+
+ Base_Typ := Base_Type (Id);
+ Subps := Subprograms_For_Type (Base_Typ);
+
+ if No (Subps) then
+ Subps := New_Elmt_List;
+ Set_Subprograms_For_Type (Base_Typ, Subps);
+ end if;
+
+ Prepend_Elmt (V, Subps);
+ end Set_DIC_Procedure;
+
+ procedure Set_Partial_DIC_Procedure (Id : E; V : E) is
+ begin
+ Set_DIC_Procedure (Id, V);
+ end Set_Partial_DIC_Procedure;
+
+ -------------------
+ -- Set_Float_Rep --
+ -------------------
+
+ procedure Set_Float_Rep
+ (Ignore_N : Entity_Id; Ignore_Val : Float_Rep_Kind) is
+ begin
+ pragma Assert (Float_Rep_Kind'First = Float_Rep_Kind'Last);
+ -- There is only one value, so we don't need to store it (see
+ -- types.ads).
+ end Set_Float_Rep;
+
+ -----------------------------
+ -- Set_Invariant_Procedure --
+ -----------------------------
+
+ procedure Set_Invariant_Procedure (Id : E; V : E) is
+ Base_Typ : Entity_Id;
+ Subp_Elmt : Elmt_Id;
+ Subp_Id : Entity_Id;
+ Subps : Elist_Id;
+
+ begin
+ pragma Assert (Is_Type (Id));
+
+ Base_Typ := Base_Type (Id);
+ Subps := Subprograms_For_Type (Base_Typ);
+
+ if No (Subps) then
+ Subps := New_Elmt_List;
+ Set_Subprograms_For_Type (Base_Typ, Subps);
+ end if;
+
+ Subp_Elmt := First_Elmt (Subps);
+ Prepend_Elmt (V, Subps);
+
+ -- Check for a duplicate invariant procedure
+
+ while Present (Subp_Elmt) loop
+ Subp_Id := Node (Subp_Elmt);
+
+ if Is_Invariant_Procedure (Subp_Id) then
+ raise Program_Error;
+ end if;
+
+ Next_Elmt (Subp_Elmt);
+ end loop;
+ end Set_Invariant_Procedure;
+
+ -------------------------------------
+ -- Set_Partial_Invariant_Procedure --
+ -------------------------------------
+
+ procedure Set_Partial_Invariant_Procedure (Id : E; V : E) is
+ Base_Typ : Entity_Id;
+ Subp_Elmt : Elmt_Id;
+ Subp_Id : Entity_Id;
+ Subps : Elist_Id;
+
+ begin
+ pragma Assert (Is_Type (Id));
+
+ Base_Typ := Base_Type (Id);
+ Subps := Subprograms_For_Type (Base_Typ);
+
+ if No (Subps) then
+ Subps := New_Elmt_List;
+ Set_Subprograms_For_Type (Base_Typ, Subps);
+ end if;
+
+ Subp_Elmt := First_Elmt (Subps);
+ Prepend_Elmt (V, Subps);
+
+ -- Check for a duplicate partial invariant procedure
+
+ while Present (Subp_Elmt) loop
+ Subp_Id := Node (Subp_Elmt);
+
+ if Is_Partial_Invariant_Procedure (Subp_Id) then
+ raise Program_Error;
+ end if;
+
+ Next_Elmt (Subp_Elmt);
+ end loop;
+ end Set_Partial_Invariant_Procedure;
+
+ ----------------------------
+ -- Set_Predicate_Function --
+ ----------------------------
+
+ procedure Set_Predicate_Function (Id : E; V : E) is
+ Subp_Elmt : Elmt_Id;
+ Subp_Id : Entity_Id;
+ Subps : Elist_Id;
+
+ begin
+ pragma Assert (Is_Type (Id) and then Has_Predicates (Id));
+
+ Subps := Subprograms_For_Type (Id);
+
+ if No (Subps) then
+ Subps := New_Elmt_List;
+ Set_Subprograms_For_Type (Id, Subps);
+ end if;
+
+ Subp_Elmt := First_Elmt (Subps);
+ Prepend_Elmt (V, Subps);
+
+ -- Check for a duplicate predication function
+
+ while Present (Subp_Elmt) loop
+ Subp_Id := Node (Subp_Elmt);
+
+ if Ekind (Subp_Id) = E_Function
+ and then Is_Predicate_Function (Subp_Id)
+ then
+ raise Program_Error;
+ end if;
+
+ Next_Elmt (Subp_Elmt);
+ end loop;
+ end Set_Predicate_Function;
+
+ ------------------------------
+ -- Set_Predicate_Function_M --
+ ------------------------------
+
+ procedure Set_Predicate_Function_M (Id : E; V : E) is
+ Subp_Elmt : Elmt_Id;
+ Subp_Id : Entity_Id;
+ Subps : Elist_Id;
+
+ begin
+ pragma Assert (Is_Type (Id) and then Has_Predicates (Id));
+
+ Subps := Subprograms_For_Type (Id);
+
+ if No (Subps) then
+ Subps := New_Elmt_List;
+ Set_Subprograms_For_Type (Id, Subps);
+ end if;
+
+ Subp_Elmt := First_Elmt (Subps);
+ Prepend_Elmt (V, Subps);
+
+ -- Check for a duplicate predication function
+
+ while Present (Subp_Elmt) loop
+ Subp_Id := Node (Subp_Elmt);
+
+ if Ekind (Subp_Id) = E_Function
+ and then Is_Predicate_Function_M (Subp_Id)
+ then
+ raise Program_Error;
+ end if;
+
+ Next_Elmt (Subp_Elmt);
+ end loop;
+ end Set_Predicate_Function_M;
+
+ -----------------
+ -- Size_Clause --
+ -----------------
+
+ function Size_Clause (Id : E) return N is
+ Result : N := Get_Attribute_Definition_Clause (Id, Attribute_Size);
+ begin
+ if No (Result) then
+ Result := Get_Attribute_Definition_Clause (Id, Attribute_Value_Size);
+ end if;
+
+ return Result;
+ end Size_Clause;
+
+ ------------------------
+ -- Stream_Size_Clause --
+ ------------------------
+
+ function Stream_Size_Clause (Id : E) return N is
+ begin
+ return Get_Attribute_Definition_Clause (Id, Attribute_Stream_Size);
+ end Stream_Size_Clause;
+
+ ------------------
+ -- Subtype_Kind --
+ ------------------
+
+ function Subtype_Kind (K : Entity_Kind) return Entity_Kind is
+ Kind : Entity_Kind;
+
+ begin
+ case K is
+ when Access_Kind =>
+ Kind := E_Access_Subtype;
+
+ when E_Array_Subtype
+ | E_Array_Type
+ =>
+ Kind := E_Array_Subtype;
+
+ when E_Class_Wide_Subtype
+ | E_Class_Wide_Type
+ =>
+ Kind := E_Class_Wide_Subtype;
+
+ when E_Decimal_Fixed_Point_Subtype
+ | E_Decimal_Fixed_Point_Type
+ =>
+ Kind := E_Decimal_Fixed_Point_Subtype;
+
+ when E_Ordinary_Fixed_Point_Subtype
+ | E_Ordinary_Fixed_Point_Type
+ =>
+ Kind := E_Ordinary_Fixed_Point_Subtype;
+
+ when E_Private_Subtype
+ | E_Private_Type
+ =>
+ Kind := E_Private_Subtype;
+
+ when E_Limited_Private_Subtype
+ | E_Limited_Private_Type
+ =>
+ Kind := E_Limited_Private_Subtype;
+
+ when E_Record_Subtype_With_Private
+ | E_Record_Type_With_Private
+ =>
+ Kind := E_Record_Subtype_With_Private;
+
+ when E_Record_Subtype
+ | E_Record_Type
+ =>
+ Kind := E_Record_Subtype;
+
+ when Enumeration_Kind =>
+ Kind := E_Enumeration_Subtype;
+
+ when E_Incomplete_Type =>
+ Kind := E_Incomplete_Subtype;
+
+ when Float_Kind =>
+ Kind := E_Floating_Point_Subtype;
+
+ when Signed_Integer_Kind =>
+ Kind := E_Signed_Integer_Subtype;
+
+ when Modular_Integer_Kind =>
+ Kind := E_Modular_Integer_Subtype;
+
+ when Protected_Kind =>
+ Kind := E_Protected_Subtype;
+
+ when Task_Kind =>
+ Kind := E_Task_Subtype;
+
+ when others =>
+ raise Program_Error;
+ end case;
+
+ return Kind;
+ end Subtype_Kind;
+
+ ---------------------
+ -- Type_High_Bound --
+ ---------------------
+
+ function Type_High_Bound (Id : E) return Node_Id is
+ Rng : constant Node_Id := Scalar_Range (Id);
+ begin
+ if Nkind (Rng) = N_Subtype_Indication then
+ return High_Bound (Range_Expression (Constraint (Rng)));
+ else
+ return High_Bound (Rng);
+ end if;
+ end Type_High_Bound;
+
+ --------------------
+ -- Type_Low_Bound --
+ --------------------
+
+ function Type_Low_Bound (Id : E) return Node_Id is
+ Rng : constant Node_Id := Scalar_Range (Id);
+ begin
+ if Nkind (Rng) = N_Subtype_Indication then
+ return Low_Bound (Range_Expression (Constraint (Rng)));
+ else
+ return Low_Bound (Rng);
+ end if;
+ end Type_Low_Bound;
+
+ ---------------------
+ -- Underlying_Type --
+ ---------------------
+
+ function Underlying_Type (Id : E) return E is
+ begin
+ -- For record_with_private the underlying type is always the direct full
+ -- view. Never try to take the full view of the parent it does not make
+ -- sense.
+
+ if Ekind (Id) = E_Record_Type_With_Private then
+ return Full_View (Id);
+
+ -- If we have a class-wide type that comes from the limited view then we
+ -- return the Underlying_Type of its nonlimited view.
+
+ elsif Ekind (Id) = E_Class_Wide_Type
+ and then From_Limited_With (Id)
+ and then Present (Non_Limited_View (Id))
+ then
+ return Underlying_Type (Non_Limited_View (Id));
+
+ elsif Ekind (Id) in Incomplete_Or_Private_Kind then
+
+ -- If we have an incomplete or private type with a full view, then we
+ -- return the Underlying_Type of this full view.
+
+ if Present (Full_View (Id)) then
+ if Id = Full_View (Id) then
+
+ -- Previous error in declaration
+
+ return Empty;
+
+ else
+ return Underlying_Type (Full_View (Id));
+ end if;
+
+ -- If we have a private type with an underlying full view, then we
+ -- return the Underlying_Type of this underlying full view.
+
+ elsif Ekind (Id) in Private_Kind
+ and then Present (Underlying_Full_View (Id))
+ then
+ return Underlying_Type (Underlying_Full_View (Id));
+
+ -- If we have an incomplete entity that comes from the limited view
+ -- then we return the Underlying_Type of its nonlimited view.
+
+ elsif From_Limited_With (Id)
+ and then Present (Non_Limited_View (Id))
+ then
+ return Underlying_Type (Non_Limited_View (Id));
+
+ -- Otherwise check for the case where we have a derived type or
+ -- subtype, and if so get the Underlying_Type of the parent type.
+
+ elsif Etype (Id) /= Id then
+ return Underlying_Type (Etype (Id));
+
+ -- Otherwise we have an incomplete or private type that has no full
+ -- view, which means that we have not encountered the completion, so
+ -- return Empty to indicate the underlying type is not yet known.
+
+ else
+ return Empty;
+ end if;
+
+ -- For non-incomplete, non-private types, return the type itself. Also
+ -- for entities that are not types at all return the entity itself.
+
+ else
+ return Id;
+ end if;
+ end Underlying_Type;
+
+ ------------------------
+ -- Unlink_Next_Entity --
+ ------------------------
+
+ procedure Unlink_Next_Entity (Id : Entity_Id) is
+ Next : constant Entity_Id := Next_Entity (Id);
+
+ begin
+ if Present (Next) then
+ Set_Prev_Entity (Next, Empty); -- Empty <-- Next
+ end if;
+
+ Set_Next_Entity (Id, Empty); -- Id --> Empty
+ end Unlink_Next_Entity;
+
+ ----------------------------------
+ -- Is_Volatile, Set_Is_Volatile --
+ ----------------------------------
+
+ function Is_Volatile (Id : E) return B is
+ begin
+ pragma Assert (Nkind (Id) in N_Entity);
+
+ if Is_Type (Id) then
+ return Is_Volatile_Type (Base_Type (Id));
+ else
+ return Is_Volatile_Object (Id);
+ end if;
+ end Is_Volatile;
+
+ procedure Set_Is_Volatile (Id : E; V : B := True) is
+ begin
+ pragma Assert (Nkind (Id) in N_Entity);
+
+ if Is_Type (Id) then
+ Set_Is_Volatile_Type (Id, V);
+ else
+ Set_Is_Volatile_Object (Id, V);
+ end if;
+ end Set_Is_Volatile;
+
+ -----------------------
+ -- Write_Entity_Info --
+ -----------------------
+
+ procedure Write_Entity_Info (Id : Entity_Id; Prefix : String) is
+
+ procedure Write_Attribute (Which : String; Nam : E);
+ -- Write attribute value with given string name
+
+ procedure Write_Kind (Id : Entity_Id);
+ -- Write Ekind field of entity
+
+ ---------------------
+ -- Write_Attribute --
+ ---------------------
+
+ procedure Write_Attribute (Which : String; Nam : E) is
+ begin
+ Write_Str (Prefix);
+ Write_Str (Which);
+ Write_Int (Int (Nam));
+ Write_Str (" ");
+ Write_Name (Chars (Nam));
+ Write_Str (" ");
+ end Write_Attribute;
+
+ ----------------
+ -- Write_Kind --
+ ----------------
+
+ procedure Write_Kind (Id : Entity_Id) is
+ K : constant String := Entity_Kind'Image (Ekind (Id));
+
+ begin
+ Write_Str (Prefix);
+ Write_Str (" Kind ");
+
+ if Is_Type (Id) and then Is_Tagged_Type (Id) then
+ Write_Str ("TAGGED ");
+ end if;
+
+ Write_Str (K (3 .. K'Length));
+ Write_Str (" ");
+
+ if Is_Type (Id) and then Depends_On_Private (Id) then
+ Write_Str ("Depends_On_Private ");
+ end if;
+ end Write_Kind;
+
+ -- Start of processing for Write_Entity_Info
+
+ begin
+ Write_Eol;
+ Write_Attribute ("Name ", Id);
+ Write_Int (Int (Id));
+ Write_Eol;
+ Write_Kind (Id);
+ Write_Eol;
+ Write_Attribute (" Type ", Etype (Id));
+ Write_Eol;
+ if Id /= Standard_Standard then
+ Write_Attribute (" Scope ", Scope (Id));
+ end if;
+ Write_Eol;
+
+ case Ekind (Id) is
+ when Discrete_Kind =>
+ Write_Str ("Bounds: Id = ");
+
+ if Present (Scalar_Range (Id)) then
+ Write_Int (Int (Type_Low_Bound (Id)));
+ Write_Str (" .. Id = ");
+ Write_Int (Int (Type_High_Bound (Id)));
+ else
+ Write_Str ("Empty");
+ end if;
+
+ Write_Eol;
+
+ when Array_Kind =>
+ declare
+ Index : Entity_Id;
+
+ begin
+ Write_Attribute
+ (" Component Type ", Component_Type (Id));
+ Write_Eol;
+ Write_Str (Prefix);
+ Write_Str (" Indexes ");
+
+ Index := First_Index (Id);
+ while Present (Index) loop
+ Write_Attribute (" ", Etype (Index));
+ Index := Next_Index (Index);
+ end loop;
+
+ Write_Eol;
+ end;
+
+ when Access_Kind =>
+ Write_Attribute
+ (" Directly Designated Type ",
+ Directly_Designated_Type (Id));
+ Write_Eol;
+
+ when Overloadable_Kind =>
+ if Present (Homonym (Id)) then
+ Write_Str (" Homonym ");
+ Write_Name (Chars (Homonym (Id)));
+ Write_Str (" ");
+ Write_Int (Int (Homonym (Id)));
+ Write_Eol;
+ end if;
+
+ Write_Eol;
+
+ when E_Component =>
+ if Ekind (Scope (Id)) in Record_Kind then
+ Write_Attribute (
+ " Original_Record_Component ",
+ Original_Record_Component (Id));
+ Write_Int (Int (Original_Record_Component (Id)));
+ Write_Eol;
+ end if;
+
+ when others =>
+ null;
+ end case;
+ end Write_Entity_Info;
+
+ -------------------------
+ -- Iterator Procedures --
+ -------------------------
+
+ procedure Proc_Next_Component (N : in out Node_Id) is
+ begin
+ N := Next_Component (N);
+ end Proc_Next_Component;
+
+ procedure Proc_Next_Component_Or_Discriminant (N : in out Node_Id) is
+ begin
+ N := Next_Entity (N);
+ while Present (N) loop
+ exit when Ekind (N) in E_Component | E_Discriminant;
+ N := Next_Entity (N);
+ end loop;
+ end Proc_Next_Component_Or_Discriminant;
+
+ procedure Proc_Next_Discriminant (N : in out Node_Id) is
+ begin
+ N := Next_Discriminant (N);
+ end Proc_Next_Discriminant;
+
+ procedure Proc_Next_Formal (N : in out Node_Id) is
+ begin
+ N := Next_Formal (N);
+ end Proc_Next_Formal;
+
+ procedure Proc_Next_Formal_With_Extras (N : in out Node_Id) is
+ begin
+ N := Next_Formal_With_Extras (N);
+ end Proc_Next_Formal_With_Extras;
+
+ procedure Proc_Next_Index (N : in out Node_Id) is
+ begin
+ N := Next_Index (N);
+ end Proc_Next_Index;
+
+ procedure Proc_Next_Inlined_Subprogram (N : in out Node_Id) is
+ begin
+ N := Next_Inlined_Subprogram (N);
+ end Proc_Next_Inlined_Subprogram;
+
+ procedure Proc_Next_Literal (N : in out Node_Id) is
+ begin
+ N := Next_Literal (N);
+ end Proc_Next_Literal;
+
+ procedure Proc_Next_Stored_Discriminant (N : in out Node_Id) is
+ begin
+ N := Next_Stored_Discriminant (N);
+ end Proc_Next_Stored_Discriminant;
+
+end Einfo.Utils;
diff --git a/gcc/ada/einfo-utils.ads b/gcc/ada/einfo-utils.ads
new file mode 100644
index 0000000..a6517b9
--- /dev/null
+++ b/gcc/ada/einfo-utils.ads
@@ -0,0 +1,713 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- E I N F O . U T I L S --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 2020-2021, Free Software Foundation, Inc. --
+-- --
+-- GNAT is 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 Einfo.Entities; use Einfo.Entities;
+
+package Einfo.Utils is
+
+ -----------------------------------
+ -- Renamings of Renamed_Or_Alias --
+ -----------------------------------
+
+ -- See the comment in einfo.ads, "Renaming and Aliasing", which is somewhat
+ -- incorrect. In fact, the compiler uses Alias, Renamed_Entity, and
+ -- Renamed_Object more-or-less interchangeably, so we rename them here.
+ -- Alias isn't really renamed, because we want an assertion in the body.
+
+ function Alias (N : Entity_Id) return Node_Id;
+ procedure Set_Alias (N : Entity_Id; Val : Node_Id);
+ function Renamed_Entity
+ (N : Entity_Id) return Node_Id renames Renamed_Or_Alias;
+ procedure Set_Renamed_Entity
+ (N : Entity_Id; Val : Node_Id) renames Set_Renamed_Or_Alias;
+ function Renamed_Object
+ (N : Entity_Id) return Node_Id renames Renamed_Or_Alias;
+ procedure Set_Renamed_Object
+ (N : Entity_Id; Val : Node_Id) renames Set_Renamed_Or_Alias;
+
+ pragma Inline (Alias);
+ pragma Inline (Set_Alias);
+ pragma Inline (Renamed_Entity);
+ pragma Inline (Set_Renamed_Entity);
+ pragma Inline (Renamed_Object);
+ pragma Inline (Set_Renamed_Object);
+
+ -------------------
+ -- Type Synonyms --
+ -------------------
+
+ -- The following type synonyms are used to tidy up the function and
+ -- procedure declarations that follow.
+
+ subtype B is Boolean;
+ subtype C is Component_Alignment_Kind;
+ subtype E is Entity_Id;
+ subtype F is Float_Rep_Kind;
+ subtype M is Mechanism_Type;
+ subtype N is Node_Id;
+ subtype U is Uint;
+ subtype R is Ureal;
+ subtype L is Elist_Id;
+ subtype S is List_Id;
+
+ -------------------------------
+ -- Classification Attributes --
+ -------------------------------
+
+ -- These functions provide a convenient functional notation for testing
+ -- whether an Ekind value belongs to a specified kind, for example the
+ -- function Is_Elementary_Type tests if its argument is in Elementary_Kind.
+ -- In some cases, the test is of an entity attribute (e.g. in the case of
+ -- 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;
+ function Is_Aggregate_Type (Id : E) return B;
+ function Is_Anonymous_Access_Type (Id : E) return B;
+ function Is_Array_Type (Id : E) return B;
+ function Is_Assignable (Id : E) return B;
+ function Is_Class_Wide_Type (Id : E) return B;
+ function Is_Composite_Type (Id : E) return B;
+ function Is_Concurrent_Body (Id : E) return B;
+ function Is_Concurrent_Type (Id : E) return B;
+ function Is_Decimal_Fixed_Point_Type (Id : E) return B;
+ function Is_Digits_Type (Id : E) return B;
+ function Is_Discrete_Or_Fixed_Point_Type (Id : E) return B;
+ function Is_Discrete_Type (Id : E) return B;
+ function Is_Elementary_Type (Id : E) return B;
+ function Is_Entry (Id : E) return B;
+ function Is_Enumeration_Type (Id : E) return B;
+ function Is_Fixed_Point_Type (Id : E) return B;
+ function Is_Floating_Point_Type (Id : E) return B;
+ function Is_Formal (Id : E) return B;
+ function Is_Formal_Object (Id : E) return B;
+ function Is_Generic_Subprogram (Id : E) return B;
+ function Is_Generic_Unit (Id : E) return B;
+ function Is_Ghost_Entity (Id : E) return B;
+ function Is_Incomplete_Or_Private_Type (Id : E) return B;
+ function Is_Incomplete_Type (Id : E) return B;
+ function Is_Integer_Type (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;
+ function Is_Ordinary_Fixed_Point_Type (Id : E) return B;
+ function Is_Overloadable (Id : E) return B;
+ function Is_Private_Type (Id : E) return B;
+ function Is_Protected_Type (Id : E) return B;
+ function Is_Real_Type (Id : E) return B;
+ function Is_Record_Type (Id : E) return B;
+ function Is_Scalar_Type (Id : E) return B;
+ function Is_Signed_Integer_Type (Id : E) return B;
+ function Is_Subprogram (Id : E) return B;
+ function Is_Subprogram_Or_Entry (Id : E) return B;
+ function Is_Subprogram_Or_Generic_Subprogram (Id : E) return B;
+ function Is_Task_Type (Id : E) return B;
+ function Is_Type (Id : E) return B;
+
+ pragma Inline (Is_Access_Object_Type);
+ pragma Inline (Is_Access_Type);
+ pragma Inline (Is_Access_Protected_Subprogram_Type);
+ pragma Inline (Is_Access_Subprogram_Type);
+ pragma Inline (Is_Aggregate_Type);
+ pragma Inline (Is_Anonymous_Access_Type);
+ pragma Inline (Is_Array_Type);
+ pragma Inline (Is_Assignable);
+ pragma Inline (Is_Class_Wide_Type);
+ pragma Inline (Is_Composite_Type);
+ pragma Inline (Is_Concurrent_Body);
+ pragma Inline (Is_Concurrent_Type);
+ pragma Inline (Is_Decimal_Fixed_Point_Type);
+ pragma Inline (Is_Digits_Type);
+ pragma Inline (Is_Discrete_Type);
+ pragma Inline (Is_Elementary_Type);
+ pragma Inline (Is_Entry);
+ pragma Inline (Is_Enumeration_Type);
+ pragma Inline (Is_Fixed_Point_Type);
+ pragma Inline (Is_Floating_Point_Type);
+ pragma Inline (Is_Formal);
+ pragma Inline (Is_Formal_Object);
+ pragma Inline (Is_Generic_Subprogram);
+ pragma Inline (Is_Generic_Unit);
+ pragma Inline (Is_Ghost_Entity);
+ pragma Inline (Is_Incomplete_Or_Private_Type);
+ pragma Inline (Is_Incomplete_Type);
+ pragma Inline (Is_Integer_Type);
+ pragma Inline (Is_Modular_Integer_Type);
+ pragma Inline (Is_Named_Access_Type);
+ pragma Inline (Is_Named_Number);
+ pragma Inline (Is_Numeric_Type);
+ pragma Inline (Is_Object);
+ pragma Inline (Is_Ordinary_Fixed_Point_Type);
+ pragma Inline (Is_Overloadable);
+ pragma Inline (Is_Private_Type);
+ pragma Inline (Is_Protected_Type);
+ pragma Inline (Is_Real_Type);
+ pragma Inline (Is_Record_Type);
+ pragma Inline (Is_Scalar_Type);
+ pragma Inline (Is_Signed_Integer_Type);
+ pragma Inline (Is_Subprogram);
+ pragma Inline (Is_Subprogram_Or_Entry);
+ pragma Inline (Is_Subprogram_Or_Generic_Subprogram);
+ pragma Inline (Is_Task_Type);
+ pragma Inline (Is_Type);
+
+ -------------------------------------
+ -- Synthesized Attribute Functions --
+ -------------------------------------
+
+ -- The functions in this section synthesize attributes from the tree,
+ -- so they do not correspond to defined fields in the entity itself.
+
+ function Address_Clause (Id : E) return N;
+ function Aft_Value (Id : E) return U;
+ function Alignment_Clause (Id : E) return N;
+ function Base_Type (Id : E) return E;
+ function Declaration_Node (Id : E) return N;
+ function Designated_Type (Id : E) return E;
+ function Entry_Index_Type (Id : E) return E;
+ function First_Component (Id : E) return E;
+ function First_Component_Or_Discriminant (Id : E) return E;
+ function First_Formal (Id : E) return E;
+ function First_Formal_With_Extras (Id : E) return E;
+
+ function Float_Rep
+ (N : Entity_Id) return F with Inline, Pre =>
+ N in E_Void_Id
+ | Float_Kind_Id;
+ procedure Set_Float_Rep
+ (Ignore_N : Entity_Id; Ignore_Val : F) with Inline, Pre =>
+ Ignore_N in E_Void_Id
+ | Float_Kind_Id;
+
+ 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_Limited_View (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_Base_Type (Id : E) return B;
+ -- Note that Is_Base_Type returns True for nontypes
+ function Is_Boolean_Type (Id : E) return B;
+ function Is_Constant_Object (Id : E) return B;
+ function Is_Controlled (Id : E) return B;
+ function Is_Discriminal (Id : E) return B;
+ function Is_Dynamic_Scope (Id : E) return B;
+ function Is_Elaboration_Target (Id : E) return B;
+ function Is_External_State (Id : E) return B;
+ function Is_Finalizer (Id : E) return B;
+ function Is_Full_Access (Id : E) return B;
+ function Is_Null_State (Id : E) return B;
+ function Is_Package_Or_Generic_Package (Id : E) return B;
+ function Is_Packed_Array (Id : E) return B;
+ function Is_Prival (Id : E) return B;
+ 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;
+ function Is_Synchronized_Interface (Id : E) return B;
+ function Is_Synchronized_State (Id : E) return B;
+ function Is_Task_Interface (Id : E) return B;
+ function Is_Task_Record_Type (Id : E) return B;
+ function Is_Wrapper_Package (Id : E) return B;
+ function Last_Formal (Id : E) return E;
+ function Machine_Emax_Value (Id : E) return U;
+ function Machine_Emin_Value (Id : E) return U;
+ function Machine_Mantissa_Value (Id : E) return U;
+ function Machine_Radix_Value (Id : E) return U;
+ function Model_Emin_Value (Id : E) return U;
+ function Model_Epsilon_Value (Id : E) return R;
+ function Model_Mantissa_Value (Id : E) return U;
+ function Model_Small_Value (Id : E) return R;
+ function Next_Component (Id : E) return E;
+ function Next_Component_Or_Discriminant (Id : E) return E;
+ 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;
+ function Number_Entries (Id : E) return Nat;
+ function Number_Formals (Id : E) return Pos;
+ function Object_Size_Clause (Id : E) return N;
+ function Parameter_Mode (Id : E) return Formal_Kind;
+ function Partial_Refinement_Constituents (Id : E) return L;
+ function Primitive_Operations (Id : E) return L;
+ function Root_Type (Id : E) return E;
+ 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;
+ function Type_High_Bound (Id : E) return N;
+ function Type_Low_Bound (Id : E) return N;
+ function Underlying_Type (Id : E) return E;
+
+ pragma Inline (Address_Clause);
+ pragma Inline (Alignment_Clause);
+ pragma Inline (Base_Type);
+ 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_Finalizer);
+ pragma Inline (Is_Full_Access);
+ 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_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);
+
+ ----------------------------------------------
+ -- Type Representation Attribute Predicates --
+ ----------------------------------------------
+
+ -- These predicates test the setting of the indicated attribute. The
+ -- Known predicate is True if and only if the value has been set. The
+ -- Known_Static predicate is True only if the value is set (Known) and is
+ -- set to a compile time known value. Note that in the case of Alignment
+ -- and Normalized_First_Bit, dynamic values are not possible, so we do not
+ -- need a separate Known_Static calls in these cases. The not set (unknown)
+ -- values are as follows:
+
+ -- Alignment Uint_0 or No_Uint
+ -- Component_Size Uint_0 or No_Uint
+ -- Component_Bit_Offset No_Uint
+ -- Digits_Value Uint_0 or No_Uint
+ -- Esize Uint_0 or No_Uint
+ -- Normalized_First_Bit No_Uint
+ -- Normalized_Position No_Uint
+ -- Normalized_Position_Max No_Uint
+ -- RM_Size Uint_0 or No_Uint
+
+ -- It would be cleaner to use No_Uint in all these cases, but historically
+ -- we chose to use Uint_0 at first, and the change over will take time ???
+ -- This is particularly true for the RM_Size field, where a value of zero
+ -- is legitimate. We deal with this by a considering that the value is
+ -- always known static for discrete types (and no other types can have
+ -- an RM_Size value of zero).
+
+ -- In two cases, Known_Static_Esize and Known_Static_RM_Size, there is one
+ -- more consideration, which is that we always return False for generic
+ -- types. Within a template, the size can look known, because of the fake
+ -- size values we put in template types, but they are not really known and
+ -- anyone testing if they are known within the template should get False as
+ -- a result to prevent incorrect assumptions.
+
+ function Known_Alignment (E : Entity_Id) return B;
+ function Known_Component_Bit_Offset (E : Entity_Id) return B;
+ function Known_Component_Size (E : Entity_Id) return B;
+ function Known_Esize (E : Entity_Id) return B;
+ function Known_Normalized_First_Bit (E : Entity_Id) return B;
+ function Known_Normalized_Position (E : Entity_Id) return B;
+ function Known_Normalized_Position_Max (E : Entity_Id) return B;
+ function Known_RM_Size (E : Entity_Id) return B;
+
+ function Known_Static_Component_Bit_Offset (E : Entity_Id) return B;
+ function Known_Static_Component_Size (E : Entity_Id) return B;
+ function Known_Static_Esize (E : Entity_Id) return B;
+ function Known_Static_Normalized_First_Bit (E : Entity_Id) return B;
+ function Known_Static_Normalized_Position (E : Entity_Id) return B;
+ function Known_Static_Normalized_Position_Max (E : Entity_Id) return B;
+ function Known_Static_RM_Size (E : Entity_Id) return B;
+
+ 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);
+
+ ---------------------------------------------------
+ -- Access to Subprograms in Subprograms_For_Type --
+ ---------------------------------------------------
+
+ -- Now that we have variable-sized nodes, it might be possible to replace
+ -- the following with regular fields, and get rid of the flags used to mark
+ -- these kinds of subprograms.
+
+ function Is_Partial_DIC_Procedure (Id : E) return B;
+
+ function DIC_Procedure (Id : E) return E;
+ function Partial_DIC_Procedure (Id : E) return E;
+ function Invariant_Procedure (Id : E) return E;
+ function Partial_Invariant_Procedure (Id : E) return E;
+ function Predicate_Function (Id : E) return E;
+ function Predicate_Function_M (Id : E) return E;
+
+ procedure Set_DIC_Procedure (Id : E; V : E);
+ procedure Set_Partial_DIC_Procedure (Id : E; V : E);
+ procedure Set_Invariant_Procedure (Id : E; V : E);
+ procedure Set_Partial_Invariant_Procedure (Id : E; V : E);
+ procedure Set_Predicate_Function (Id : E; V : E);
+ procedure Set_Predicate_Function_M (Id : E; V : E);
+
+ -----------------------------------
+ -- Field Initialization Routines --
+ -----------------------------------
+
+ -- These routines are overloadings of some of the above Set procedures
+ -- where the argument is normally a Uint. The overloadings take an Int
+ -- parameter instead, and appropriately convert it. There are also
+ -- versions that implicitly initialize to the appropriate "not set"
+ -- value. The not set (unknown) values are as follows:
+
+ -- Alignment Uint_0
+ -- Component_Size Uint_0
+ -- Component_Bit_Offset No_Uint
+ -- Digits_Value Uint_0
+ -- Esize Uint_0
+ -- Normalized_First_Bit No_Uint
+ -- Normalized_Position No_Uint
+ -- Normalized_Position_Max No_Uint
+ -- RM_Size Uint_0
+
+ -- It would be cleaner to use No_Uint in all these cases, but historically
+ -- we chose to use Uint_0 at first, and the change over will take time ???
+ -- This is particularly true for the RM_Size field, where a value of zero
+ -- is legitimate and causes some special tests around the code.
+
+ -- Contrary to the corresponding Set procedures above, these routines
+ -- do NOT check the entity kind of their argument, instead they set the
+ -- underlying Uint fields directly (this allows them to be used for
+ -- entities whose Ekind has not been set yet).
+
+ procedure Init_Alignment (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);
+ procedure Init_Normalized_Position (Id : E; V : Int);
+ procedure Init_Normalized_Position_Max (Id : E; V : Int);
+ procedure Init_RM_Size (Id : E; V : Int);
+
+ procedure Init_Alignment (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);
+ procedure Init_Normalized_Position (Id : E);
+ procedure Init_Normalized_Position_Max (Id : E);
+ procedure Init_RM_Size (Id : E);
+
+ -- The following Copy_xxx procedures copy the value of xxx from From to
+ -- To. If xxx is set to its initial invalid (zero-bits) value, then it is
+ -- reset to invalid in To. We only have Copy_Alignment so far, but more are
+ -- planned.
+
+ procedure Copy_Alignment (To, From : E);
+
+ 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);
+
+ 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.
+
+ procedure Init_Object_Size_Align (Id : E);
+ -- Same as Init_Size_Align except RM_Size field (which is only for types)
+ -- is unaffected.
+
+ ---------------
+ -- Iterators --
+ ---------------
+
+ -- The call to Next_xxx (obj) is equivalent to obj := Next_xxx (obj)
+ -- We define the set of Proc_Next_xxx routines simply for the purposes
+ -- of inlining them without necessarily inlining the function.
+
+ procedure Proc_Next_Component (N : in out Node_Id);
+ procedure Proc_Next_Component_Or_Discriminant (N : in out Node_Id);
+ procedure Proc_Next_Discriminant (N : in out Node_Id);
+ procedure Proc_Next_Formal (N : in out Node_Id);
+ procedure Proc_Next_Formal_With_Extras (N : in out Node_Id);
+ procedure Proc_Next_Index (N : in out Node_Id);
+ procedure Proc_Next_Inlined_Subprogram (N : in out Node_Id);
+ procedure Proc_Next_Literal (N : in out Node_Id);
+ procedure Proc_Next_Stored_Discriminant (N : in out Node_Id);
+
+ pragma Inline (Proc_Next_Component);
+ pragma Inline (Proc_Next_Component_Or_Discriminant);
+ pragma Inline (Proc_Next_Discriminant);
+ pragma Inline (Proc_Next_Formal);
+ pragma Inline (Proc_Next_Formal_With_Extras);
+ pragma Inline (Proc_Next_Index);
+ pragma Inline (Proc_Next_Inlined_Subprogram);
+ pragma Inline (Proc_Next_Literal);
+ pragma Inline (Proc_Next_Stored_Discriminant);
+
+ procedure Next_Component (N : in out Node_Id)
+ renames Proc_Next_Component;
+
+ procedure Next_Component_Or_Discriminant (N : in out Node_Id)
+ renames Proc_Next_Component_Or_Discriminant;
+
+ procedure Next_Discriminant (N : in out Node_Id)
+ renames Proc_Next_Discriminant;
+
+ procedure Next_Formal (N : in out Node_Id)
+ renames Proc_Next_Formal;
+
+ procedure Next_Formal_With_Extras (N : in out Node_Id)
+ renames Proc_Next_Formal_With_Extras;
+
+ procedure Next_Index (N : in out Node_Id)
+ renames Proc_Next_Index;
+
+ procedure Next_Inlined_Subprogram (N : in out Node_Id)
+ renames Proc_Next_Inlined_Subprogram;
+
+ procedure Next_Literal (N : in out Node_Id)
+ renames Proc_Next_Literal;
+
+ procedure Next_Stored_Discriminant (N : in out Node_Id)
+ renames Proc_Next_Stored_Discriminant;
+
+ ---------------------------
+ -- Testing Warning Flags --
+ ---------------------------
+
+ -- These routines are to be used rather than testing flags Warnings_Off,
+ -- Has_Pragma_Unmodified, Has_Pragma_Unreferenced. They deal with setting
+ -- the flags Warnings_Off_Used[_Unmodified|Unreferenced] for later access.
+
+ function Has_Warnings_Off (E : Entity_Id) return Boolean;
+ -- If Warnings_Off is set on E, then returns True and also sets the flag
+ -- Warnings_Off_Used on E. If Warnings_Off is not set on E, returns False
+ -- and has no side effect.
+
+ function Has_Unmodified (E : Entity_Id) return Boolean;
+ -- If flag Has_Pragma_Unmodified is set on E, returns True with no side
+ -- effects. Otherwise if Warnings_Off is set on E, returns True and also
+ -- sets the flag Warnings_Off_Used_Unmodified on E. If neither of the flags
+ -- Warnings_Off nor Has_Pragma_Unmodified is set, returns False with no
+ -- side effects.
+
+ function Has_Unreferenced (E : Entity_Id) return Boolean;
+ -- If flag Has_Pragma_Unreferenced is set on E, returns True with no side
+ -- effects. Otherwise if Warnings_Off is set on E, returns True and also
+ -- sets the flag Warnings_Off_Used_Unreferenced on E. If neither of the
+ -- flags Warnings_Off nor Has_Pragma_Unreferenced is set, returns False
+ -- with no side effects.
+
+ ----------------------------------------------
+ -- Subprograms for Accessing Rep Item Chain --
+ ----------------------------------------------
+
+ -- The First_Rep_Item field of every entity points to a linked list (linked
+ -- through Next_Rep_Item) of representation pragmas, attribute definition
+ -- clauses, representation clauses, and aspect specifications that apply to
+ -- the item. Note that in the case of types, it is assumed that any such
+ -- rep items for a base type also apply to all subtypes. This is achieved
+ -- by having the chain for subtypes link onto the chain for the base type,
+ -- so that new entries for the subtype are added at the start of the chain.
+ --
+ -- Note: aspect specification nodes are linked only when evaluation of the
+ -- expression is deferred to the freeze point. For further details see
+ -- Sem_Ch13.Analyze_Aspect_Specifications.
+
+ function Get_Attribute_Definition_Clause
+ (E : Entity_Id;
+ Id : Attribute_Id) return Node_Id;
+ -- Searches the Rep_Item chain for a given entity E, for an instance of an
+ -- attribute definition clause with the given attribute Id. If found, the
+ -- value returned is the N_Attribute_Definition_Clause node, otherwise
+ -- Empty is returned.
+
+ -- WARNING: There is a matching C declaration of this subprogram in fe.h
+
+ function Get_Pragma (E : Entity_Id; Id : Pragma_Id) return Node_Id;
+ -- Searches the Rep_Item chain of entity E, for an instance of a pragma
+ -- with the given pragma Id. If found, the value returned is the N_Pragma
+ -- node, otherwise Empty is returned. The following contract pragmas that
+ -- appear in N_Contract nodes are also handled by this routine:
+ -- Abstract_State
+ -- Async_Readers
+ -- Async_Writers
+ -- Attach_Handler
+ -- Constant_After_Elaboration
+ -- Contract_Cases
+ -- Depends
+ -- Effective_Reads
+ -- Effective_Writes
+ -- Global
+ -- Initial_Condition
+ -- Initializes
+ -- Interrupt_Handler
+ -- No_Caching
+ -- Part_Of
+ -- Precondition
+ -- Postcondition
+ -- Refined_Depends
+ -- Refined_Global
+ -- Refined_Post
+ -- Refined_State
+ -- Subprogram_Variant
+ -- Test_Case
+ -- Volatile_Function
+
+ function Get_Class_Wide_Pragma
+ (E : Entity_Id;
+ Id : Pragma_Id) return Node_Id;
+ -- Examine Rep_Item chain to locate a classwide pre- or postcondition of a
+ -- primitive operation. Returns Empty if not present.
+
+ function Get_Record_Representation_Clause (E : Entity_Id) return Node_Id;
+ -- Searches the Rep_Item chain for a given entity E, for a record
+ -- representation clause, and if found, returns it. Returns Empty
+ -- if no such clause is found.
+
+ function Present_In_Rep_Item (E : Entity_Id; N : Node_Id) return Boolean;
+ -- Return True if N is present in the Rep_Item chain for a given entity E
+
+ procedure Record_Rep_Item (E : Entity_Id; N : Node_Id);
+ -- N is the node for a representation pragma, representation clause, an
+ -- attribute definition clause, or an aspect specification that applies to
+ -- entity E. This procedure links the node N onto the Rep_Item chain for
+ -- entity E. Note that it is an error to call this procedure with E being
+ -- overloadable, and N being a pragma that applies to multiple overloadable
+ -- entities (Convention, Interface, Inline, Inline_Always, Import, Export,
+ -- External). This is not allowed even in the case where the entity is not
+ -- overloaded, since we can't rely on it being present in the overloaded
+ -- case, it is not useful to have it present in the non-overloaded case.
+
+ -------------------------------
+ -- Miscellaneous Subprograms --
+ -------------------------------
+
+ procedure Append_Entity (Id : Entity_Id; Scop : Entity_Id);
+ -- Add an entity to the list of entities declared in the scope Scop
+
+ function Get_Full_View (T : Entity_Id) return Entity_Id;
+ -- If T is an incomplete type and the full declaration has been seen, or
+ -- is the name of a class_wide type whose root is incomplete, return the
+ -- corresponding full declaration, else return T itself.
+
+ function Is_Entity_Name (N : Node_Id) return Boolean;
+ -- Test if the node N is the name of an entity (i.e. is an identifier,
+ -- expanded name, or an attribute reference that returns an entity).
+
+ -- WARNING: There is a matching C declaration of this subprogram in fe.h
+
+ procedure Link_Entities (First : Entity_Id; Second : Entity_Id);
+ -- Link entities First and Second in one entity chain.
+ --
+ -- NOTE: No updates are done to the First_Entity and Last_Entity fields
+ -- of the scope.
+
+ procedure Remove_Entity (Id : Entity_Id);
+ -- Remove entity Id from the entity chain of its 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
+ -- example if K is E_Signed_Integer_Type then E_Signed_Integer_Subtype
+ -- is returned. If K is already a subtype kind it itself is returned. An
+ -- internal error is generated if no such correspondence exists for K.
+
+ procedure Unlink_Next_Entity (Id : Entity_Id);
+ -- Unchain entity Id's forward link within the entity chain of its scope
+
+ function Is_Volatile (Id : E) return B;
+ procedure Set_Is_Volatile (Id : E; V : B := True);
+ -- Call [Set_]Is_Volatile_Type/Is_Volatile_Object as appropriate for the
+ -- Ekind of Id.
+
+ function Convention
+ (N : Entity_Id) return Convention_Id renames Basic_Convention;
+ procedure Set_Convention (E : Entity_Id; Val : Convention_Id);
+ -- Same as Set_Basic_Convention, but with an extra check for access types.
+ -- In particular, if E is an access-to-subprogram type, and Val is a
+ -- foreign convention, then we set Can_Use_Internal_Rep to False on E.
+ -- Also, if the Etype of E is set and is an anonymous access type with
+ -- no convention set, this anonymous type inherits the convention of E.
+
+ pragma Inline (Is_Entity_Name);
+
+ ----------------------------------
+ -- Debugging Output Subprograms --
+ ----------------------------------
+
+ procedure Write_Entity_Info (Id : Entity_Id; Prefix : String);
+ -- A debugging procedure to write out information about an entity
+
+end Einfo.Utils;
diff --git a/gcc/ada/einfo.adb b/gcc/ada/einfo.adb
index 8c401ca..3202f99 100644
--- a/gcc/ada/einfo.adb
+++ b/gcc/ada/einfo.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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,11555 +23,4 @@
-- --
------------------------------------------------------------------------------
-with Atree; use Atree;
-with Elists; use Elists;
-with Namet; use Namet;
-with Nlists; use Nlists;
-with Output; use Output;
-with Sinfo; use Sinfo;
-with Stand; use Stand;
-
-package body Einfo is
-
- use Atree.Unchecked_Access;
- -- This is one of the packages that is allowed direct untyped access to
- -- the fields in a node, since it provides the next level abstraction
- -- which incorporates appropriate checks.
-
- ----------------------------------------------
- -- Usage of Fields in Defining Entity Nodes --
- ----------------------------------------------
-
- -- Four of these fields are defined in Sinfo, since they in are the base
- -- part of the node. The access routines for these four fields and the
- -- corresponding set procedures are defined in Sinfo. These fields are
- -- present in all entities. Note that Homonym is also in the base part of
- -- the node, but has access routines that are more properly part of Einfo,
- -- which is why they are defined here.
-
- -- Chars Name1
- -- Next_Entity Node2
- -- Scope Node3
- -- Etype Node5
-
- -- Remaining fields are present only in extended nodes (i.e. entities).
-
- -- The following fields are present in all entities
-
- -- Homonym Node4
- -- First_Rep_Item Node6
- -- Freeze_Node Node7
- -- Prev_Entity Node36
- -- Associated_Entity Node37
-
- -- The usage of other fields (and the entity kinds to which it applies)
- -- depends on the particular field (see Einfo spec for details).
-
- -- Associated_Node_For_Itype Node8
- -- Dependent_Instances Elist8
- -- Hiding_Loop_Variable Node8
- -- Mechanism Uint8 (but returns Mechanism_Type)
- -- Normalized_First_Bit Uint8
- -- Refinement_Constituents Elist8
- -- Return_Applies_To Node8
- -- First_Exit_Statement Node8
-
- -- Class_Wide_Type Node9
- -- Current_Value Node9
- -- Renaming_Map Uint9
-
- -- Direct_Primitive_Operations Elist10
- -- Discriminal_Link Node10
- -- Float_Rep Uint10 (but returns Float_Rep_Kind)
- -- Handler_Records List10
- -- Normalized_Position_Max Uint10
- -- Part_Of_Constituents Elist10
-
- -- Block_Node Node11
- -- Component_Bit_Offset Uint11
- -- Full_View Node11
- -- Entry_Component Node11
- -- Enumeration_Pos Uint11
- -- Generic_Homonym Node11
- -- Part_Of_References Elist11
- -- Protected_Body_Subprogram Node11
-
- -- Barrier_Function Node12
- -- Enumeration_Rep Uint12
- -- Esize Uint12
- -- Next_Inlined_Subprogram Node12
-
- -- Component_Clause Node13
- -- Elaboration_Entity Node13
- -- Extra_Accessibility Node13
- -- RM_Size Uint13
-
- -- Alignment Uint14
- -- Normalized_Position Uint14
- -- Postconditions_Proc Node14
-
- -- Discriminant_Number Uint15
- -- DT_Position Uint15
- -- DT_Entry_Count Uint15
- -- Entry_Parameters_Type Node15
- -- Extra_Formal Node15
- -- Pending_Access_Types Elist15
- -- Related_Instance Node15
- -- Status_Flag_Or_Transient_Decl Node15
-
- -- Access_Disp_Table Elist16
- -- Body_References Elist16
- -- Cloned_Subtype Node16
- -- DTC_Entity Node16
- -- Entry_Formal Node16
- -- First_Private_Entity Node16
- -- Lit_Strings Node16
- -- Scale_Value Uint16
- -- String_Literal_Length Uint16
- -- Unset_Reference Node16
-
- -- Actual_Subtype Node17
- -- Digits_Value Uint17
- -- Discriminal Node17
- -- First_Entity Node17
- -- First_Index Node17
- -- First_Literal Node17
- -- Master_Id Node17
- -- Modulus Uint17
- -- Prival Node17
-
- -- Alias Node18
- -- Corresponding_Concurrent_Type Node18
- -- Corresponding_Protected_Entry Node18
- -- Corresponding_Record_Type Node18
- -- Delta_Value Ureal18
- -- Enclosing_Scope Node18
- -- Equivalent_Type Node18
- -- Lit_Indexes Node18
- -- Private_Dependents Elist18
- -- Renamed_Entity Node18
- -- Renamed_Object Node18
- -- String_Literal_Low_Bound Node18
-
- -- Body_Entity Node19
- -- Corresponding_Discriminant Node19
- -- Default_Aspect_Component_Value Node19
- -- Default_Aspect_Value Node19
- -- Entry_Bodies_Array Node19
- -- Extra_Accessibility_Of_Result Node19
- -- Non_Limited_View Node19
- -- Parent_Subtype Node19
- -- Receiving_Entry Node19
- -- Size_Check_Code Node19
- -- Spec_Entity Node19
- -- Underlying_Full_View Node19
-
- -- Component_Type Node20
- -- Default_Value Node20
- -- Directly_Designated_Type Node20
- -- Discriminant_Checking_Func Node20
- -- Discriminant_Default_Value Node20
- -- Last_Entity Node20
- -- Prival_Link Node20
- -- Register_Exception_Call Node20
- -- Scalar_Range Node20
-
- -- Accept_Address Elist21
- -- Corresponding_Record_Component Node21
- -- Default_Expr_Function Node21
- -- Discriminant_Constraint Elist21
- -- Interface_Name Node21
- -- Original_Array_Type Node21
- -- Small_Value Ureal21
-
- -- Associated_Storage_Pool Node22
- -- Component_Size Uint22
- -- Corresponding_Remote_Type Node22
- -- Enumeration_Rep_Expr Node22
- -- Original_Record_Component Node22
- -- Protected_Formal Node22
- -- Scope_Depth_Value Uint22
- -- Shared_Var_Procs_Instance Node22
-
- -- CR_Discriminant Node23
- -- Entry_Cancel_Parameter Node23
- -- Enum_Pos_To_Rep Node23
- -- Extra_Constrained Node23
- -- Finalization_Master Node23
- -- Generic_Renamings Elist23
- -- Inner_Instances Elist23
- -- Limited_View Node23
- -- Packed_Array_Impl_Type Node23
- -- Protection_Object Node23
- -- Stored_Constraint Elist23
-
- -- Incomplete_Actuals Elist24
- -- Minimum_Accessibility Node24
- -- Related_Expression Node24
- -- Subps_Index Uint24
-
- -- Contract_Wrapper Node25
- -- Debug_Renaming_Link Node25
- -- DT_Offset_To_Top_Func Node25
- -- Interface_Alias Node25
- -- Interfaces Elist25
- -- Related_Array_Object Node25
- -- Static_Discrete_Predicate List25
- -- Static_Real_Or_String_Predicate Node25
- -- Task_Body_Procedure Node25
-
- -- Dispatch_Table_Wrappers Elist26
- -- Last_Assignment Node26
- -- Overridden_Operation Node26
- -- Package_Instantiation Node26
- -- Storage_Size_Variable Node26
-
- -- Current_Use_Clause Node27
- -- Related_Type Node27
- -- Wrapped_Entity Node27
-
- -- Extra_Formals Node28
- -- Finalizer Node28
- -- Initialization_Statements Node28
- -- Original_Access_Type Node28
- -- Relative_Deadline_Variable Node28
- -- Underlying_Record_View Node28
-
- -- Anonymous_Masters Elist29
- -- BIP_Initialization_Call Node29
- -- Subprograms_For_Type Elist29
-
- -- Access_Disp_Table_Elab_Flag Node30
- -- Anonymous_Object Node30
- -- Corresponding_Equality Node30
- -- Hidden_In_Formal_Instance Elist30
- -- Last_Aggregate_Assignment Node30
- -- Static_Initialization Node30
-
- -- Activation_Record_Component Node31
- -- Derived_Type_Link Node31
- -- Thunk_Entity Node31
-
- -- Corresponding_Function Node32
- -- Corresponding_Procedure Node32
- -- Encapsulating_State Node32
- -- No_Tagged_Streams_Pragma Node32
-
- -- Linker_Section_Pragma Node33
-
- -- Contract Node34
-
- -- Anonymous_Designated_Type Node35
- -- Entry_Max_Queue_Lengths_Array Node35
- -- Import_Pragma Node35
-
- -- Validated_Object Node38
- -- Predicated_Parent Node38
- -- Class_Wide_Clone Node38
-
- -- Protected_Subprogram Node39
-
- -- SPARK_Pragma Node40
-
- -- Access_Subprogram_Wrapper Node41
- -- Original_Protected_Subprogram Node41
- -- SPARK_Aux_Pragma Node41
-
- ---------------------------------------------
- -- Usage of Flags in Defining Entity Nodes --
- ---------------------------------------------
-
- -- All flags are unique, there is no overlaying, so each flag is physically
- -- present in every entity. However, for many of the flags, it only makes
- -- sense for them to be set true for certain subsets of entity kinds. See
- -- the spec of Einfo for further details.
-
- -- Is_Inlined_Always Flag1
- -- Is_Hidden_Non_Overridden_Subpgm Flag2
- -- Has_Own_DIC Flag3
- -- Is_Frozen Flag4
- -- Has_Discriminants Flag5
- -- Is_Dispatching_Operation Flag6
- -- Is_Immediately_Visible Flag7
- -- In_Use Flag8
- -- Is_Potentially_Use_Visible Flag9
- -- Is_Public Flag10
-
- -- Is_Inlined Flag11
- -- Is_Constrained Flag12
- -- Is_Generic_Type Flag13
- -- Depends_On_Private Flag14
- -- Is_Aliased Flag15
- -- Is_Volatile Flag16
- -- Is_Internal Flag17
- -- Has_Delayed_Freeze Flag18
- -- Is_Abstract_Subprogram Flag19
- -- Is_Concurrent_Record_Type Flag20
-
- -- Has_Master_Entity Flag21
- -- Needs_No_Actuals Flag22
- -- Has_Storage_Size_Clause Flag23
- -- Is_Imported Flag24
- -- Is_Limited_Record Flag25
- -- Has_Completion Flag26
- -- Has_Pragma_Controlled Flag27
- -- Is_Statically_Allocated Flag28
- -- Has_Size_Clause Flag29
- -- Has_Task Flag30
-
- -- Checks_May_Be_Suppressed Flag31
- -- Kill_Elaboration_Checks Flag32
- -- Kill_Range_Checks Flag33
- -- Has_Independent_Components Flag34
- -- Is_Class_Wide_Equivalent_Type Flag35
- -- Referenced_As_LHS Flag36
- -- Is_Known_Non_Null Flag37
- -- Can_Never_Be_Null Flag38
- -- Has_Default_Aspect Flag39
- -- Body_Needed_For_SAL Flag40
-
- -- Treat_As_Volatile Flag41
- -- Is_Controlled_Active Flag42
- -- Has_Controlled_Component Flag43
- -- Is_Pure Flag44
- -- In_Private_Part Flag45
- -- Has_Alignment_Clause Flag46
- -- Has_Exit Flag47
- -- In_Package_Body Flag48
- -- Reachable Flag49
- -- Delay_Subprogram_Descriptors Flag50
-
- -- Is_Packed Flag51
- -- Is_Entry_Formal Flag52
- -- Is_Private_Descendant Flag53
- -- Return_Present Flag54
- -- Is_Tagged_Type Flag55
- -- Has_Homonym Flag56
- -- Is_Hidden Flag57
- -- Non_Binary_Modulus Flag58
- -- Is_Preelaborated Flag59
- -- Is_Shared_Passive Flag60
-
- -- Is_Remote_Types Flag61
- -- Is_Remote_Call_Interface Flag62
- -- Is_Character_Type Flag63
- -- Is_Intrinsic_Subprogram Flag64
- -- Has_Record_Rep_Clause Flag65
- -- Has_Enumeration_Rep_Clause Flag66
- -- Has_Small_Clause Flag67
- -- Has_Component_Size_Clause Flag68
- -- Is_Access_Constant Flag69
- -- Is_First_Subtype Flag70
-
- -- Has_Completion_In_Body Flag71
- -- Has_Unknown_Discriminants Flag72
- -- Is_Child_Unit Flag73
- -- Is_CPP_Class Flag74
- -- Has_Non_Standard_Rep Flag75
- -- Is_Constructor Flag76
- -- Static_Elaboration_Desired Flag77
- -- Is_Tag Flag78
- -- Has_All_Calls_Remote Flag79
- -- Is_Constr_Subt_For_U_Nominal Flag80
-
- -- Is_Asynchronous Flag81
- -- Has_Gigi_Rep_Item Flag82
- -- Has_Machine_Radix_Clause Flag83
- -- Machine_Radix_10 Flag84
- -- Is_Atomic Flag85
- -- Has_Atomic_Components Flag86
- -- Has_Volatile_Components Flag87
- -- Discard_Names Flag88
- -- Is_Interrupt_Handler Flag89
- -- Returns_By_Ref Flag90
-
- -- Is_Itype Flag91
- -- Size_Known_At_Compile_Time Flag92
- -- Reverse_Storage_Order Flag93
- -- Is_Generic_Actual_Type Flag94
- -- Uses_Sec_Stack Flag95
- -- Warnings_Off Flag96
- -- Is_Controlling_Formal Flag97
- -- Has_Controlling_Result Flag98
- -- Is_Exported Flag99
- -- Has_Specified_Layout Flag100
-
- -- Has_Nested_Block_With_Handler Flag101
- -- Is_Called Flag102
- -- Is_Completely_Hidden Flag103
- -- Address_Taken Flag104
- -- Suppress_Initialization Flag105
- -- Is_Limited_Composite Flag106
- -- Is_Private_Composite Flag107
- -- Default_Expressions_Processed Flag108
- -- Is_Non_Static_Subtype Flag109
- -- Has_Out_Or_In_Out_Parameter Flag110
-
- -- Is_Formal_Subprogram Flag111
- -- Is_Renaming_Of_Object Flag112
- -- No_Return Flag113
- -- Delay_Cleanups Flag114
- -- 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
-
- -- Has_Pragma_Pack Flag121
- -- Is_Bit_Packed_Array Flag122
- -- Has_Unchecked_Union Flag123
- -- Is_Eliminated Flag124
- -- C_Pass_By_Copy Flag125
- -- Is_Instantiated Flag126
- -- Is_Valued_Procedure Flag127
- -- (used for Component_Alignment) Flag128
- -- (used for Component_Alignment) Flag129
- -- Is_Generic_Instance Flag130
-
- -- No_Pool_Assigned Flag131
- -- Is_DIC_Procedure Flag132
- -- Has_Inherited_DIC Flag133
- -- Has_Aliased_Components Flag135
- -- No_Strict_Aliasing Flag136
- -- Is_Machine_Code_Subprogram Flag137
- -- Is_Packed_Array_Impl_Type Flag138
- -- Has_Biased_Representation Flag139
- -- Has_Complex_Representation Flag140
-
- -- Is_Constr_Subt_For_UN_Aliased Flag141
- -- Has_Missing_Return Flag142
- -- Has_Recursive_Call Flag143
- -- Is_Unsigned_Type Flag144
- -- Strict_Alignment Flag145
- -- Is_Abstract_Type Flag146
- -- Needs_Debug_Info Flag147
- -- Is_Elaboration_Checks_OK_Id Flag148
- -- Is_Compilation_Unit Flag149
- -- Has_Pragma_Elaborate_Body Flag150
-
- -- Has_Private_Ancestor Flag151
- -- Entry_Accepted Flag152
- -- Is_Obsolescent Flag153
- -- Has_Per_Object_Constraint Flag154
- -- Has_Private_Declaration Flag155
- -- Referenced Flag156
- -- Has_Pragma_Inline Flag157
- -- Finalize_Storage_Only Flag158
- -- From_Limited_With Flag159
- -- Is_Package_Body_Entity Flag160
-
- -- Has_Qualified_Name Flag161
- -- Nonzero_Is_True Flag162
- -- Is_True_Constant Flag163
- -- Reverse_Bit_Order Flag164
- -- Suppress_Style_Checks Flag165
- -- Debug_Info_Off Flag166
- -- Sec_Stack_Needed_For_Return Flag167
- -- Materialize_Entity Flag168
- -- Has_Pragma_Thread_Local_Storage Flag169
- -- Is_Known_Valid Flag170
-
- -- Is_Hidden_Open_Scope Flag171
- -- Has_Object_Size_Clause Flag172
- -- Has_Fully_Qualified_Name Flag173
- -- Elaboration_Entity_Required Flag174
- -- Has_Forward_Instantiation Flag175
- -- Is_Discrim_SO_Function Flag176
- -- Size_Depends_On_Discriminant Flag177
- -- Is_Null_Init_Proc Flag178
- -- Has_Pragma_Pure_Function Flag179
- -- Has_Pragma_Unreferenced Flag180
-
- -- Has_Contiguous_Rep Flag181
- -- Has_Xref_Entry Flag182
- -- Must_Be_On_Byte_Boundary Flag183
- -- Has_Stream_Size_Clause Flag184
- -- Is_Ada_2005_Only Flag185
- -- Is_Interface Flag186
- -- Has_Constrained_Partial_View Flag187
- -- Uses_Lock_Free Flag188
- -- Is_Pure_Unit_Access_Type Flag189
- -- Has_Specified_Stream_Input Flag190
-
- -- Has_Specified_Stream_Output Flag191
- -- Has_Specified_Stream_Read Flag192
- -- Has_Specified_Stream_Write Flag193
- -- Is_Local_Anonymous_Access Flag194
- -- Is_Primitive_Wrapper Flag195
- -- Was_Hidden Flag196
- -- Is_Limited_Interface Flag197
- -- Has_Pragma_Ordered Flag198
- -- Is_Ada_2012_Only Flag199
-
- -- Has_Delayed_Aspects Flag200
- -- Has_Pragma_No_Inline Flag201
- -- Itype_Printed Flag202
- -- Has_Pragma_Pure Flag203
- -- Is_Known_Null Flag204
- -- Low_Bound_Tested Flag205
- -- Is_Visible_Formal Flag206
- -- Known_To_Have_Preelab_Init Flag207
- -- Must_Have_Preelab_Init Flag208
- -- Is_Return_Object Flag209
-
- -- Elaborate_Body_Desirable Flag210
- -- Has_Static_Discriminants Flag211
- -- Has_Pragma_Unreferenced_Objects Flag212
- -- Requires_Overriding Flag213
- -- Has_RACW Flag214
- -- Is_Param_Block_Component_Type Flag215
- -- Universal_Aliasing Flag216
- -- Suppress_Value_Tracking_On_Call Flag217
- -- Is_Primitive Flag218
- -- Has_Initial_Value Flag219
-
- -- Has_Dispatch_Table Flag220
- -- Has_Pragma_Preelab_Init Flag221
- -- Used_As_Generic_Actual Flag222
- -- Is_Descendant_Of_Address Flag223
- -- Is_Raised Flag224
- -- Is_Thunk Flag225
- -- Is_Only_Out_Parameter Flag226
- -- Referenced_As_Out_Parameter Flag227
- -- Has_Thunks Flag228
- -- Can_Use_Internal_Rep Flag229
-
- -- Has_Pragma_Inline_Always Flag230
- -- Renamed_In_Spec Flag231
- -- Has_Own_Invariants Flag232
- -- Has_Pragma_Unmodified Flag233
- -- Is_Dispatch_Table_Entity Flag234
- -- Is_Trivial_Subprogram Flag235
- -- Warnings_Off_Used Flag236
- -- Warnings_Off_Used_Unmodified Flag237
- -- Warnings_Off_Used_Unreferenced Flag238
- -- No_Reordering Flag239
-
- -- Has_Expanded_Contract Flag240
- -- Optimize_Alignment_Space Flag241
- -- Optimize_Alignment_Time Flag242
- -- Overlays_Constant Flag243
- -- Is_RACW_Stub_Type Flag244
- -- Is_Private_Primitive Flag245
- -- Is_Underlying_Record_View Flag246
- -- OK_To_Rename Flag247
- -- Has_Inheritable_Invariants Flag248
- -- Is_Safe_To_Reevaluate Flag249
-
- -- Has_Predicates Flag250
- -- Has_Implicit_Dereference Flag251
- -- Is_Finalized_Transient Flag252
- -- Disable_Controlled Flag253
- -- Is_Implementation_Defined Flag254
- -- Is_Predicate_Function Flag255
- -- Is_Predicate_Function_M Flag256
- -- Is_Invariant_Procedure Flag257
- -- Has_Dynamic_Predicate_Aspect Flag258
- -- Has_Static_Predicate_Aspect Flag259
-
- -- Has_Loop_Entry_Attributes Flag260
- -- Has_Delayed_Rep_Aspects Flag261
- -- May_Inherit_Delayed_Rep_Aspects Flag262
- -- Has_Visible_Refinement Flag263
- -- Is_Discriminant_Check_Function Flag264
- -- SPARK_Pragma_Inherited Flag265
- -- SPARK_Aux_Pragma_Inherited Flag266
- -- Has_Shift_Operator Flag267
- -- Is_Independent Flag268
- -- Has_Static_Predicate Flag269
-
- -- Stores_Attribute_Old_Prefix Flag270
- -- Has_Protected Flag271
- -- SSO_Set_Low_By_Default Flag272
- -- SSO_Set_High_By_Default Flag273
- -- Is_Generic_Actual_Subprogram Flag274
- -- No_Predicate_On_Actual Flag275
- -- No_Dynamic_Predicate_On_Actual Flag276
- -- Is_Checked_Ghost_Entity Flag277
- -- Is_Ignored_Ghost_Entity Flag278
- -- Contains_Ignored_Ghost_Code Flag279
-
- -- Partial_View_Has_Unknown_Discr Flag280
- -- Is_Static_Type Flag281
- -- Has_Nested_Subprogram Flag282
- -- Is_Uplevel_Referenced_Entity Flag283
- -- Is_Unimplemented Flag284
- -- Is_Volatile_Full_Access Flag285
- -- Is_Exception_Handler Flag286
- -- Rewritten_For_C Flag287
- -- Predicates_Ignored Flag288
- -- Has_Timing_Event Flag289
-
- -- Is_Class_Wide_Clone Flag290
- -- Has_Inherited_Invariants Flag291
- -- Is_Partial_Invariant_Procedure Flag292
- -- Is_Actual_Subtype Flag293
- -- Has_Pragma_Unused Flag294
- -- Is_Ignored_Transient Flag295
- -- Has_Partial_Visible_Refinement Flag296
- -- Is_Entry_Wrapper Flag297
- -- Is_Underlying_Full_View Flag298
- -- Body_Needed_For_Inlining Flag299
-
- -- Has_Private_Extension Flag300
- -- Ignore_SPARK_Mode_Pragmas Flag301
- -- Is_Initial_Condition_Procedure Flag302
- -- Suppress_Elaboration_Warnings Flag303
- -- Is_Elaboration_Warnings_OK_Id Flag304
- -- Is_Activation_Record Flag305
- -- Needs_Activation_Record Flag306
- -- Is_Loop_Parameter Flag307
- -- Has_Yield_Aspect Flag308
-
- -- (unused) Flag309
-
- -- Note: Flag310-317 are defined in atree.ads/adb, but not yet in atree.h
-
- -----------------------
- -- Local subprograms --
- -----------------------
-
- function Has_Option
- (State_Id : Entity_Id;
- Option_Nam : Name_Id) return Boolean;
- -- Determine whether abstract state State_Id has particular option denoted
- -- by the name Option_Nam.
-
- ---------------
- -- Float_Rep --
- ---------------
-
- function Float_Rep (Id : E) return F is
- pragma Assert (Is_Floating_Point_Type (Id));
- begin
- return F'Val (UI_To_Int (Uint10 (Base_Type (Id))));
- end Float_Rep;
-
- ----------------
- -- Has_Option --
- ----------------
-
- function Has_Option
- (State_Id : Entity_Id;
- Option_Nam : Name_Id) return Boolean
- is
- Decl : constant Node_Id := Parent (State_Id);
- Opt : Node_Id;
- Opt_Nam : Node_Id;
-
- begin
- pragma Assert (Ekind (State_Id) = E_Abstract_State);
-
- -- The declaration of abstract states with options appear as an
- -- extension aggregate. If this is not the case, the option is not
- -- available.
-
- if Nkind (Decl) /= N_Extension_Aggregate then
- return False;
- end if;
-
- -- Simple options
-
- Opt := First (Expressions (Decl));
- while Present (Opt) loop
- if Nkind (Opt) = N_Identifier and then Chars (Opt) = Option_Nam then
- return True;
- end if;
-
- Next (Opt);
- end loop;
-
- -- Complex options with various specifiers
-
- Opt := First (Component_Associations (Decl));
- while Present (Opt) loop
- Opt_Nam := First (Choices (Opt));
-
- if Nkind (Opt_Nam) = N_Identifier
- and then Chars (Opt_Nam) = Option_Nam
- then
- return True;
- end if;
-
- Next (Opt);
- end loop;
-
- return False;
- end Has_Option;
-
- --------------------------------
- -- Attribute Access Functions --
- --------------------------------
-
- function Abstract_States (Id : E) return L is
- begin
- pragma Assert (Is_Package_Or_Generic_Package (Id));
- return Elist25 (Id);
- end Abstract_States;
-
- function Accept_Address (Id : E) return L is
- begin
- return Elist21 (Id);
- end Accept_Address;
-
- function Access_Disp_Table (Id : E) return L is
- begin
- 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 (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 (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 (Id) in E_Constant | E_Variable | E_Generic_In_Out_Parameter
- or else Is_Formal (Id));
- return Node17 (Id);
- end Actual_Subtype;
-
- function Address_Taken (Id : E) return B is
- begin
- return Flag104 (Id);
- end Address_Taken;
-
- function Alias (Id : E) return E is
- begin
- pragma Assert
- (Is_Overloadable (Id) or else Ekind (Id) = E_Subprogram_Type);
- return Node18 (Id);
- end Alias;
-
- function Alignment (Id : E) return U is
- begin
- pragma Assert (Is_Type (Id)
- or else Is_Formal (Id)
- or else Ekind (Id) in E_Loop_Parameter
- | E_Constant
- | E_Exception
- | E_Variable);
- return Uint14 (Id);
- end Alignment;
-
- function Anonymous_Designated_Type (Id : E) return E is
- begin
- pragma Assert (Ekind (Id) = E_Variable);
- return Node35 (Id);
- end Anonymous_Designated_Type;
-
- function Anonymous_Masters (Id : E) return L is
- begin
- 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 (Id) in E_Protected_Type | E_Task_Type);
- return Node30 (Id);
- end Anonymous_Object;
-
- function Associated_Entity (Id : E) return E is
- begin
- return Node37 (Id);
- end Associated_Entity;
-
- function Associated_Formal_Package (Id : E) return E is
- begin
- pragma Assert (Ekind (Id) = E_Package);
- return Node12 (Id);
- end Associated_Formal_Package;
-
- function Associated_Node_For_Itype (Id : E) return N is
- begin
- return Node8 (Id);
- end Associated_Node_For_Itype;
-
- function Associated_Storage_Pool (Id : E) return E is
- begin
- pragma Assert (Is_Access_Type (Id));
- return Node22 (Root_Type (Id));
- end Associated_Storage_Pool;
-
- function Barrier_Function (Id : E) return N is
- begin
- pragma Assert (Is_Entry (Id));
- return Node12 (Id);
- end Barrier_Function;
-
- function Block_Node (Id : E) return N is
- begin
- pragma Assert (Ekind (Id) = E_Block);
- return Node11 (Id);
- end Block_Node;
-
- function Body_Entity (Id : E) return E is
- begin
- pragma Assert (Is_Package_Or_Generic_Package (Id));
- return Node19 (Id);
- end Body_Entity;
-
- function Body_Needed_For_Inlining (Id : E) return B is
- begin
- pragma Assert (Ekind (Id) = E_Package);
- return Flag299 (Id);
- end Body_Needed_For_Inlining;
-
- function Body_Needed_For_SAL (Id : E) return B is
- begin
- pragma Assert
- (Ekind (Id) = E_Package
- or else Is_Subprogram (Id)
- or else Is_Generic_Unit (Id));
- return Flag40 (Id);
- end Body_Needed_For_SAL;
-
- function Body_References (Id : E) return L is
- begin
- pragma Assert (Ekind (Id) = E_Abstract_State);
- return Elist16 (Id);
- end Body_References;
-
- function BIP_Initialization_Call (Id : E) return N is
- begin
- pragma Assert (Ekind (Id) in E_Constant | E_Variable);
- return Node29 (Id);
- end BIP_Initialization_Call;
-
- function C_Pass_By_Copy (Id : E) return B is
- begin
- pragma Assert (Is_Record_Type (Id));
- return Flag125 (Implementation_Base_Type (Id));
- end C_Pass_By_Copy;
-
- function Can_Never_Be_Null (Id : E) return B is
- begin
- return Flag38 (Id);
- end Can_Never_Be_Null;
-
- function Checks_May_Be_Suppressed (Id : E) return B is
- begin
- return Flag31 (Id);
- end Checks_May_Be_Suppressed;
-
- function Class_Wide_Clone (Id : E) return E is
- begin
- pragma Assert (Is_Subprogram (Id));
- return Node38 (Id);
- end Class_Wide_Clone;
-
- function Class_Wide_Type (Id : E) return E is
- begin
- pragma Assert (Is_Type (Id));
- return Node9 (Id);
- end Class_Wide_Type;
-
- function Cloned_Subtype (Id : E) return E is
- begin
- 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 (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 (Id) in E_Component | E_Discriminant);
- return Node13 (Id);
- end Component_Clause;
-
- function Component_Size (Id : E) return U is
- begin
- pragma Assert (Is_Array_Type (Id));
- return Uint22 (Implementation_Base_Type (Id));
- end Component_Size;
-
- function Component_Type (Id : E) return E is
- begin
- pragma Assert (Is_Array_Type (Id));
- return Node20 (Implementation_Base_Type (Id));
- end Component_Type;
-
- function Corresponding_Concurrent_Type (Id : E) return E is
- begin
- pragma Assert (Ekind (Id) = E_Record_Type);
- return Node18 (Id);
- end Corresponding_Concurrent_Type;
-
- function Corresponding_Discriminant (Id : E) return E is
- begin
- pragma Assert (Ekind (Id) = E_Discriminant);
- return Node19 (Id);
- end Corresponding_Discriminant;
-
- function Corresponding_Equality (Id : E) return E is
- begin
- pragma Assert
- (Ekind (Id) = E_Function
- and then not Comes_From_Source (Id)
- and then Chars (Id) = Name_Op_Ne);
- return Node30 (Id);
- end Corresponding_Equality;
-
- function Corresponding_Function (Id : E) return E is
- begin
- pragma Assert (Ekind (Id) = E_Procedure);
- return Node32 (Id);
- end Corresponding_Function;
-
- function Corresponding_Procedure (Id : E) return E is
- begin
- pragma Assert (Ekind (Id) = E_Function);
- return Node32 (Id);
- end Corresponding_Procedure;
-
- function Corresponding_Protected_Entry (Id : E) return E is
- begin
- pragma Assert (Ekind (Id) = E_Subprogram_Body);
- return Node18 (Id);
- end Corresponding_Protected_Entry;
-
- function Corresponding_Record_Component (Id : E) return E is
- begin
- pragma Assert (Ekind (Id) in E_Component | E_Discriminant);
- return Node21 (Id);
- end Corresponding_Record_Component;
-
- function Corresponding_Record_Type (Id : E) return E is
- begin
- pragma Assert (Is_Concurrent_Type (Id));
- return Node18 (Id);
- end Corresponding_Record_Type;
-
- function Corresponding_Remote_Type (Id : E) return E is
- begin
- return Node22 (Id);
- end Corresponding_Remote_Type;
-
- function Current_Use_Clause (Id : E) return E is
- begin
- pragma Assert (Ekind (Id) = E_Package or else Is_Type (Id));
- return Node27 (Id);
- end Current_Use_Clause;
-
- function Current_Value (Id : E) return N is
- begin
- pragma Assert (Is_Object (Id));
- return Node9 (Id);
- end Current_Value;
-
- function CR_Discriminant (Id : E) return E is
- begin
- return Node23 (Id);
- end CR_Discriminant;
-
- function Debug_Info_Off (Id : E) return B is
- begin
- return Flag166 (Id);
- end Debug_Info_Off;
-
- function Debug_Renaming_Link (Id : E) return E is
- begin
- return Node25 (Id);
- end Debug_Renaming_Link;
-
- function Default_Aspect_Component_Value (Id : E) return N is
- begin
- pragma Assert (Is_Array_Type (Id));
- return Node19 (Base_Type (Id));
- end Default_Aspect_Component_Value;
-
- function Default_Aspect_Value (Id : E) return N is
- begin
- pragma Assert (Is_Scalar_Type (Id));
- return Node19 (Base_Type (Id));
- end Default_Aspect_Value;
-
- function Default_Expr_Function (Id : E) return E is
- begin
- pragma Assert (Is_Formal (Id));
- return Node21 (Id);
- end Default_Expr_Function;
-
- function Default_Expressions_Processed (Id : E) return B is
- begin
- return Flag108 (Id);
- end Default_Expressions_Processed;
-
- function Default_Value (Id : E) return N is
- begin
- pragma Assert (Is_Formal (Id));
- return Node20 (Id);
- end Default_Value;
-
- function Delay_Cleanups (Id : E) return B is
- begin
- return Flag114 (Id);
- end Delay_Cleanups;
-
- function Delay_Subprogram_Descriptors (Id : E) return B is
- begin
- return Flag50 (Id);
- end Delay_Subprogram_Descriptors;
-
- function Delta_Value (Id : E) return R is
- begin
- pragma Assert (Is_Fixed_Point_Type (Id));
- return Ureal18 (Id);
- end Delta_Value;
-
- function Dependent_Instances (Id : E) return L is
- begin
- pragma Assert (Is_Generic_Instance (Id));
- return Elist8 (Id);
- end Dependent_Instances;
-
- function Depends_On_Private (Id : E) return B is
- begin
- pragma Assert (Nkind (Id) in N_Entity);
- return Flag14 (Id);
- end Depends_On_Private;
-
- function Derived_Type_Link (Id : E) return E is
- begin
- pragma Assert (Is_Type (Id));
- return Node31 (Base_Type (Id));
- end Derived_Type_Link;
-
- function Digits_Value (Id : E) return U is
- begin
- pragma Assert
- (Is_Floating_Point_Type (Id)
- or else Is_Decimal_Fixed_Point_Type (Id));
- return Uint17 (Id);
- end Digits_Value;
-
- function Direct_Primitive_Operations (Id : E) return L is
- begin
- pragma Assert (Is_Tagged_Type (Id));
- return Elist10 (Id);
- end Direct_Primitive_Operations;
-
- function Directly_Designated_Type (Id : E) return E is
- begin
- pragma Assert (Is_Access_Type (Id));
- return Node20 (Id);
- end Directly_Designated_Type;
-
- function Disable_Controlled (Id : E) return B is
- begin
- return Flag253 (Base_Type (Id));
- end Disable_Controlled;
-
- function Discard_Names (Id : E) return B is
- begin
- return Flag88 (Id);
- end Discard_Names;
-
- function Discriminal (Id : E) return E is
- begin
- pragma Assert (Ekind (Id) = E_Discriminant);
- return Node17 (Id);
- end Discriminal;
-
- function Discriminal_Link (Id : E) return N is
- begin
- return Node10 (Id);
- end Discriminal_Link;
-
- function Discriminant_Checking_Func (Id : E) return E is
- begin
- pragma Assert (Ekind (Id) = E_Component);
- return Node20 (Id);
- end Discriminant_Checking_Func;
-
- function Discriminant_Constraint (Id : E) return L is
- begin
- pragma Assert (Is_Composite_Type (Id) and then Has_Discriminants (Id));
- return Elist21 (Id);
- end Discriminant_Constraint;
-
- function Discriminant_Default_Value (Id : E) return N is
- begin
- pragma Assert (Ekind (Id) = E_Discriminant);
- return Node20 (Id);
- end Discriminant_Default_Value;
-
- function Discriminant_Number (Id : E) return U is
- begin
- pragma Assert (Ekind (Id) = E_Discriminant);
- return Uint15 (Id);
- end Discriminant_Number;
-
- function Dispatch_Table_Wrappers (Id : E) return L is
- begin
- pragma Assert (Ekind (Id) in E_Record_Type | E_Record_Subtype);
- return Elist26 (Implementation_Base_Type (Id));
- end Dispatch_Table_Wrappers;
-
- function DT_Entry_Count (Id : E) return U is
- begin
- pragma Assert (Ekind (Id) = E_Component and then Is_Tag (Id));
- return Uint15 (Id);
- end DT_Entry_Count;
-
- function DT_Offset_To_Top_Func (Id : E) return E is
- begin
- pragma Assert (Ekind (Id) = E_Component and then Is_Tag (Id));
- return Node25 (Id);
- end DT_Offset_To_Top_Func;
-
- function DT_Position (Id : E) return U is
- begin
- 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 (Id) in E_Function | E_Procedure);
- return Node16 (Id);
- end DTC_Entity;
-
- function Elaborate_Body_Desirable (Id : E) return B is
- begin
- pragma Assert (Ekind (Id) = E_Package);
- return Flag210 (Id);
- end Elaborate_Body_Desirable;
-
- function Elaboration_Entity (Id : E) return E is
- begin
- pragma Assert
- (Is_Subprogram (Id)
- or else
- Ekind (Id) in E_Entry | E_Entry_Family | E_Package
- or else
- Is_Generic_Unit (Id));
- return Node13 (Id);
- end Elaboration_Entity;
-
- function Elaboration_Entity_Required (Id : E) return B is
- begin
- pragma Assert
- (Is_Subprogram (Id)
- or else
- Ekind (Id) in E_Entry | E_Entry_Family | E_Package
- or else
- Is_Generic_Unit (Id));
- return Flag174 (Id);
- end Elaboration_Entity_Required;
-
- function Encapsulating_State (Id : E) return N is
- begin
- pragma Assert (Ekind (Id) in E_Abstract_State | E_Constant | E_Variable);
- return Node32 (Id);
- end Encapsulating_State;
-
- function Enclosing_Scope (Id : E) return E is
- begin
- return Node18 (Id);
- end Enclosing_Scope;
-
- function Entry_Accepted (Id : E) return B is
- begin
- pragma Assert (Is_Entry (Id));
- return Flag152 (Id);
- end Entry_Accepted;
-
- function Entry_Bodies_Array (Id : E) return E is
- begin
- return Node19 (Id);
- end Entry_Bodies_Array;
-
- function Entry_Cancel_Parameter (Id : E) return E is
- begin
- return Node23 (Id);
- end Entry_Cancel_Parameter;
-
- function Entry_Component (Id : E) return E is
- begin
- return Node11 (Id);
- end Entry_Component;
-
- function Entry_Formal (Id : E) return E is
- begin
- return Node16 (Id);
- end Entry_Formal;
-
- function Entry_Index_Constant (Id : E) return N is
- begin
- pragma Assert (Ekind (Id) = E_Entry_Index_Parameter);
- return Node18 (Id);
- end Entry_Index_Constant;
-
- function Entry_Max_Queue_Lengths_Array (Id : E) return N is
- begin
- pragma Assert (Ekind (Id) = E_Protected_Type);
- return Node35 (Id);
- end Entry_Max_Queue_Lengths_Array;
-
- function Contains_Ignored_Ghost_Code (Id : E) return B is
- begin
- pragma Assert
- (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 (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 (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 (Id) in E_Generic_Package -- packages
- | E_Package
- | E_Package_Body
- or else
- Is_Type (Id) -- types
- or else
- Ekind (Id) = E_Void); -- special purpose
- return Node34 (Id);
- end Contract;
-
- function Contract_Wrapper (Id : E) return E is
- begin
- pragma Assert (Is_Entry (Id));
- return Node25 (Id);
- end Contract_Wrapper;
-
- function Entry_Parameters_Type (Id : E) return E is
- begin
- return Node15 (Id);
- end Entry_Parameters_Type;
-
- function Enum_Pos_To_Rep (Id : E) return E is
- begin
- pragma Assert (Ekind (Id) = E_Enumeration_Type);
- return Node23 (Id);
- end Enum_Pos_To_Rep;
-
- function Enumeration_Pos (Id : E) return Uint is
- begin
- pragma Assert (Ekind (Id) = E_Enumeration_Literal);
- return Uint11 (Id);
- end Enumeration_Pos;
-
- function Enumeration_Rep (Id : E) return U is
- begin
- pragma Assert (Ekind (Id) = E_Enumeration_Literal);
- return Uint12 (Id);
- end Enumeration_Rep;
-
- function Enumeration_Rep_Expr (Id : E) return N is
- begin
- pragma Assert (Ekind (Id) = E_Enumeration_Literal);
- return Node22 (Id);
- end Enumeration_Rep_Expr;
-
- function Equivalent_Type (Id : E) return E is
- begin
- pragma Assert
- (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;
-
- function Esize (Id : E) return Uint is
- begin
- return Uint12 (Id);
- end Esize;
-
- function Extra_Accessibility (Id : E) return E is
- begin
- pragma Assert
- (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 (Id) in E_Function | E_Operator | E_Subprogram_Type);
- return Node19 (Id);
- end Extra_Accessibility_Of_Result;
-
- function Extra_Constrained (Id : E) return E is
- begin
- pragma Assert (Is_Formal (Id) or else Ekind (Id) = E_Variable);
- return Node23 (Id);
- end Extra_Constrained;
-
- function Extra_Formal (Id : E) return E is
- begin
- return Node15 (Id);
- end Extra_Formal;
-
- function Extra_Formals (Id : E) return E is
- begin
- pragma Assert
- (Is_Overloadable (Id)
- or else Ekind (Id) in E_Entry_Family
- | E_Subprogram_Body
- | E_Subprogram_Type);
- return Node28 (Id);
- end Extra_Formals;
-
- function Can_Use_Internal_Rep (Id : E) return B is
- begin
- pragma Assert (Is_Access_Subprogram_Type (Base_Type (Id)));
- return Flag229 (Base_Type (Id));
- end Can_Use_Internal_Rep;
-
- function Finalization_Master (Id : E) return E is
- begin
- pragma Assert (Is_Access_Type (Id));
- return Node23 (Root_Type (Id));
- end Finalization_Master;
-
- function Finalize_Storage_Only (Id : E) return B is
- begin
- pragma Assert (Is_Type (Id));
- return Flag158 (Base_Type (Id));
- end Finalize_Storage_Only;
-
- function Finalizer (Id : E) return E is
- begin
- pragma Assert (Ekind (Id) in E_Package | E_Package_Body);
- return Node28 (Id);
- end Finalizer;
-
- function First_Entity (Id : E) return E is
- begin
- return Node17 (Id);
- end First_Entity;
-
- function First_Exit_Statement (Id : E) return N is
- begin
- pragma Assert (Ekind (Id) = E_Loop);
- return Node8 (Id);
- end First_Exit_Statement;
-
- function First_Index (Id : E) return N is
- begin
- pragma Assert (Is_Array_Type (Id));
- return Node17 (Id);
- end First_Index;
-
- function First_Literal (Id : E) return E is
- begin
- pragma Assert (Is_Enumeration_Type (Id));
- return Node17 (Id);
- end First_Literal;
-
- function First_Private_Entity (Id : E) return E is
- begin
- pragma Assert (Is_Package_Or_Generic_Package (Id)
- or else Is_Concurrent_Type (Id));
- return Node16 (Id);
- end First_Private_Entity;
-
- function First_Rep_Item (Id : E) return E is
- begin
- return Node6 (Id);
- end First_Rep_Item;
-
- function Freeze_Node (Id : E) return N is
- begin
- return Node7 (Id);
- end Freeze_Node;
-
- function From_Limited_With (Id : E) return B is
- begin
- return Flag159 (Id);
- end From_Limited_With;
-
- function Full_View (Id : E) return E is
- begin
- pragma Assert (Is_Type (Id) or else Ekind (Id) = E_Constant);
- return Node11 (Id);
- end Full_View;
-
- function Generic_Homonym (Id : E) return E is
- begin
- pragma Assert (Ekind (Id) = E_Generic_Package);
- return Node11 (Id);
- end Generic_Homonym;
-
- function Generic_Renamings (Id : E) return L is
- begin
- return Elist23 (Id);
- end Generic_Renamings;
-
- function Handler_Records (Id : E) return S is
- begin
- return List10 (Id);
- end Handler_Records;
-
- function Has_Aliased_Components (Id : E) return B is
- begin
- return Flag135 (Implementation_Base_Type (Id));
- end Has_Aliased_Components;
-
- function Has_Alignment_Clause (Id : E) return B is
- begin
- return Flag46 (Id);
- end Has_Alignment_Clause;
-
- function Has_All_Calls_Remote (Id : E) return B is
- begin
- return Flag79 (Id);
- end Has_All_Calls_Remote;
-
- function Has_Atomic_Components (Id : E) return B is
- begin
- return Flag86 (Implementation_Base_Type (Id));
- end Has_Atomic_Components;
-
- function Has_Biased_Representation (Id : E) return B is
- begin
- return Flag139 (Id);
- end Has_Biased_Representation;
-
- function Has_Completion (Id : E) return B is
- begin
- return Flag26 (Id);
- end Has_Completion;
-
- function Has_Completion_In_Body (Id : E) return B is
- begin
- pragma Assert (Is_Type (Id));
- return Flag71 (Id);
- end Has_Completion_In_Body;
-
- function Has_Complex_Representation (Id : E) return B is
- begin
- pragma Assert (Is_Record_Type (Id));
- return Flag140 (Implementation_Base_Type (Id));
- end Has_Complex_Representation;
-
- function Has_Component_Size_Clause (Id : E) return B is
- begin
- pragma Assert (Is_Array_Type (Id));
- return Flag68 (Implementation_Base_Type (Id));
- end Has_Component_Size_Clause;
-
- function Has_Constrained_Partial_View (Id : E) return B is
- begin
- pragma Assert (Is_Type (Id));
- return Flag187 (Base_Type (Id));
- end Has_Constrained_Partial_View;
-
- function Has_Controlled_Component (Id : E) return B is
- begin
- return Flag43 (Base_Type (Id));
- end Has_Controlled_Component;
-
- function Has_Contiguous_Rep (Id : E) return B is
- begin
- return Flag181 (Id);
- end Has_Contiguous_Rep;
-
- function Has_Controlling_Result (Id : E) return B is
- begin
- return Flag98 (Id);
- end Has_Controlling_Result;
-
- function Has_Convention_Pragma (Id : E) return B is
- begin
- return Flag119 (Id);
- end Has_Convention_Pragma;
-
- function Has_Default_Aspect (Id : E) return B is
- begin
- return Flag39 (Base_Type (Id));
- end Has_Default_Aspect;
-
- function Has_Delayed_Aspects (Id : E) return B is
- begin
- pragma Assert (Nkind (Id) in N_Entity);
- return Flag200 (Id);
- end Has_Delayed_Aspects;
-
- function Has_Delayed_Freeze (Id : E) return B is
- begin
- pragma Assert (Nkind (Id) in N_Entity);
- return Flag18 (Id);
- end Has_Delayed_Freeze;
-
- function Has_Delayed_Rep_Aspects (Id : E) return B is
- begin
- pragma Assert (Nkind (Id) in N_Entity);
- return Flag261 (Id);
- end Has_Delayed_Rep_Aspects;
-
- function Has_Discriminants (Id : E) return B is
- begin
- pragma Assert (Is_Type (Id));
- return Flag5 (Id);
- end Has_Discriminants;
-
- function Has_Dispatch_Table (Id : E) return B is
- begin
- pragma Assert (Is_Tagged_Type (Id));
- return Flag220 (Id);
- end Has_Dispatch_Table;
-
- function Has_Dynamic_Predicate_Aspect (Id : E) return B is
- begin
- pragma Assert (Is_Type (Id));
- return Flag258 (Id);
- end Has_Dynamic_Predicate_Aspect;
-
- function Has_Enumeration_Rep_Clause (Id : E) return B is
- begin
- pragma Assert (Is_Enumeration_Type (Id));
- return Flag66 (Id);
- end Has_Enumeration_Rep_Clause;
-
- function Has_Exit (Id : E) return B is
- begin
- return Flag47 (Id);
- end Has_Exit;
-
- function Has_Expanded_Contract (Id : E) return B is
- begin
- pragma Assert (Is_Subprogram (Id));
- return Flag240 (Id);
- end Has_Expanded_Contract;
-
- function Has_Forward_Instantiation (Id : E) return B is
- begin
- return Flag175 (Id);
- end Has_Forward_Instantiation;
-
- function Has_Fully_Qualified_Name (Id : E) return B is
- begin
- return Flag173 (Id);
- end Has_Fully_Qualified_Name;
-
- function Has_Gigi_Rep_Item (Id : E) return B is
- begin
- return Flag82 (Id);
- end Has_Gigi_Rep_Item;
-
- function Has_Homonym (Id : E) return B is
- begin
- return Flag56 (Id);
- end Has_Homonym;
-
- function Has_Implicit_Dereference (Id : E) return B is
- begin
- return Flag251 (Id);
- end Has_Implicit_Dereference;
-
- function Has_Independent_Components (Id : E) return B is
- begin
- return Flag34 (Implementation_Base_Type (Id));
- end Has_Independent_Components;
-
- function Has_Inheritable_Invariants (Id : E) return B is
- begin
- pragma Assert (Is_Type (Id));
- return Flag248 (Base_Type (Id));
- end Has_Inheritable_Invariants;
-
- function Has_Inherited_DIC (Id : E) return B is
- begin
- pragma Assert (Is_Type (Id));
- return Flag133 (Base_Type (Id));
- end Has_Inherited_DIC;
-
- function Has_Inherited_Invariants (Id : E) return B is
- begin
- pragma Assert (Is_Type (Id));
- return Flag291 (Base_Type (Id));
- end Has_Inherited_Invariants;
-
- function Has_Initial_Value (Id : E) return B is
- begin
- pragma Assert (Ekind (Id) = E_Variable or else Is_Formal (Id));
- return Flag219 (Id);
- end Has_Initial_Value;
-
- function Has_Loop_Entry_Attributes (Id : E) return B is
- begin
- pragma Assert (Ekind (Id) = E_Loop);
- return Flag260 (Id);
- end Has_Loop_Entry_Attributes;
-
- function Has_Machine_Radix_Clause (Id : E) return B is
- begin
- pragma Assert (Is_Decimal_Fixed_Point_Type (Id));
- return Flag83 (Id);
- end Has_Machine_Radix_Clause;
-
- function Has_Master_Entity (Id : E) return B is
- begin
- return Flag21 (Id);
- end Has_Master_Entity;
-
- function Has_Missing_Return (Id : E) return B is
- begin
- pragma Assert (Ekind (Id) in E_Function | E_Generic_Function);
- return Flag142 (Id);
- end Has_Missing_Return;
-
- function Has_Nested_Block_With_Handler (Id : E) return B is
- begin
- return Flag101 (Id);
- end Has_Nested_Block_With_Handler;
-
- function Has_Nested_Subprogram (Id : E) return B is
- begin
- pragma Assert (Is_Subprogram (Id));
- return Flag282 (Id);
- end Has_Nested_Subprogram;
-
- function Has_Non_Standard_Rep (Id : E) return B is
- begin
- return Flag75 (Implementation_Base_Type (Id));
- end Has_Non_Standard_Rep;
-
- function Has_Object_Size_Clause (Id : E) return B is
- begin
- pragma Assert (Is_Type (Id));
- return Flag172 (Id);
- end Has_Object_Size_Clause;
-
- function Has_Out_Or_In_Out_Parameter (Id : E) return B is
- begin
- pragma Assert
- (Is_Entry (Id) or else Is_Subprogram_Or_Generic_Subprogram (Id));
- return Flag110 (Id);
- end Has_Out_Or_In_Out_Parameter;
-
- function Has_Own_DIC (Id : E) return B is
- begin
- pragma Assert (Is_Type (Id));
- return Flag3 (Base_Type (Id));
- end Has_Own_DIC;
-
- function Has_Own_Invariants (Id : E) return B is
- begin
- pragma Assert (Is_Type (Id));
- return Flag232 (Base_Type (Id));
- end Has_Own_Invariants;
-
- function Has_Partial_Visible_Refinement (Id : E) return B is
- begin
- pragma Assert (Ekind (Id) = E_Abstract_State);
- return Flag296 (Id);
- end Has_Partial_Visible_Refinement;
-
- function Has_Per_Object_Constraint (Id : E) return B is
- begin
- return Flag154 (Id);
- end Has_Per_Object_Constraint;
-
- function Has_Pragma_Controlled (Id : E) return B is
- begin
- pragma Assert (Is_Access_Type (Id));
- return Flag27 (Implementation_Base_Type (Id));
- end Has_Pragma_Controlled;
-
- function Has_Pragma_Elaborate_Body (Id : E) return B is
- begin
- return Flag150 (Id);
- end Has_Pragma_Elaborate_Body;
-
- function Has_Pragma_Inline (Id : E) return B is
- begin
- return Flag157 (Id);
- end Has_Pragma_Inline;
-
- function Has_Pragma_Inline_Always (Id : E) return B is
- begin
- return Flag230 (Id);
- end Has_Pragma_Inline_Always;
-
- function Has_Pragma_No_Inline (Id : E) return B is
- begin
- return Flag201 (Id);
- end Has_Pragma_No_Inline;
-
- function Has_Pragma_Ordered (Id : E) return B is
- begin
- pragma Assert (Is_Enumeration_Type (Id));
- return Flag198 (Implementation_Base_Type (Id));
- end Has_Pragma_Ordered;
-
- function Has_Pragma_Pack (Id : E) return B is
- begin
- pragma Assert (Is_Record_Type (Id) or else Is_Array_Type (Id));
- return Flag121 (Implementation_Base_Type (Id));
- end Has_Pragma_Pack;
-
- function Has_Pragma_Preelab_Init (Id : E) return B is
- begin
- return Flag221 (Id);
- end Has_Pragma_Preelab_Init;
-
- function Has_Pragma_Pure (Id : E) return B is
- begin
- return Flag203 (Id);
- end Has_Pragma_Pure;
-
- function Has_Pragma_Pure_Function (Id : E) return B is
- begin
- return Flag179 (Id);
- end Has_Pragma_Pure_Function;
-
- function Has_Pragma_Thread_Local_Storage (Id : E) return B is
- begin
- return Flag169 (Id);
- end Has_Pragma_Thread_Local_Storage;
-
- function Has_Pragma_Unmodified (Id : E) return B is
- begin
- return Flag233 (Id);
- end Has_Pragma_Unmodified;
-
- function Has_Pragma_Unreferenced (Id : E) return B is
- begin
- return Flag180 (Id);
- end Has_Pragma_Unreferenced;
-
- function Has_Pragma_Unreferenced_Objects (Id : E) return B is
- begin
- pragma Assert (Is_Type (Id));
- return Flag212 (Id);
- end Has_Pragma_Unreferenced_Objects;
-
- function Has_Pragma_Unused (Id : E) return B is
- begin
- return Flag294 (Id);
- end Has_Pragma_Unused;
-
- function Has_Predicates (Id : E) return B is
- begin
- pragma Assert (Is_Type (Id));
- return Flag250 (Id);
- end Has_Predicates;
-
- function Has_Primitive_Operations (Id : E) return B is
- begin
- pragma Assert (Is_Type (Id));
- return Flag120 (Base_Type (Id));
- end Has_Primitive_Operations;
-
- function Has_Private_Ancestor (Id : E) return B is
- begin
- return Flag151 (Id);
- end Has_Private_Ancestor;
-
- function Has_Private_Declaration (Id : E) return B is
- begin
- return Flag155 (Id);
- end Has_Private_Declaration;
-
- function Has_Private_Extension (Id : E) return B is
- begin
- pragma Assert (Is_Tagged_Type (Id));
- return Flag300 (Id);
- end Has_Private_Extension;
-
- function Has_Protected (Id : E) return B is
- begin
- return Flag271 (Base_Type (Id));
- end Has_Protected;
-
- function Has_Qualified_Name (Id : E) return B is
- begin
- return Flag161 (Id);
- end Has_Qualified_Name;
-
- function Has_RACW (Id : E) return B is
- begin
- pragma Assert (Ekind (Id) = E_Package);
- return Flag214 (Id);
- end Has_RACW;
-
- function Has_Record_Rep_Clause (Id : E) return B is
- begin
- pragma Assert (Is_Record_Type (Id));
- return Flag65 (Implementation_Base_Type (Id));
- end Has_Record_Rep_Clause;
-
- function Has_Recursive_Call (Id : E) return B is
- begin
- pragma Assert (Is_Subprogram (Id));
- return Flag143 (Id);
- end Has_Recursive_Call;
-
- function Has_Shift_Operator (Id : E) return B is
- begin
- pragma Assert (Is_Integer_Type (Id));
- return Flag267 (Base_Type (Id));
- end Has_Shift_Operator;
-
- function Has_Size_Clause (Id : E) return B is
- begin
- return Flag29 (Id);
- end Has_Size_Clause;
-
- function Has_Small_Clause (Id : E) return B is
- begin
- pragma Assert (Is_Ordinary_Fixed_Point_Type (Id));
- return Flag67 (Id);
- end Has_Small_Clause;
-
- function Has_Specified_Layout (Id : E) return B is
- begin
- pragma Assert (Is_Type (Id));
- return Flag100 (Implementation_Base_Type (Id));
- end Has_Specified_Layout;
-
- function Has_Specified_Stream_Input (Id : E) return B is
- begin
- pragma Assert (Is_Type (Id));
- return Flag190 (Id);
- end Has_Specified_Stream_Input;
-
- function Has_Specified_Stream_Output (Id : E) return B is
- begin
- pragma Assert (Is_Type (Id));
- return Flag191 (Id);
- end Has_Specified_Stream_Output;
-
- function Has_Specified_Stream_Read (Id : E) return B is
- begin
- pragma Assert (Is_Type (Id));
- return Flag192 (Id);
- end Has_Specified_Stream_Read;
-
- function Has_Specified_Stream_Write (Id : E) return B is
- begin
- pragma Assert (Is_Type (Id));
- return Flag193 (Id);
- end Has_Specified_Stream_Write;
-
- function Has_Static_Discriminants (Id : E) return B is
- begin
- pragma Assert (Is_Type (Id));
- return Flag211 (Id);
- end Has_Static_Discriminants;
-
- function Has_Static_Predicate (Id : E) return B is
- begin
- pragma Assert (Is_Type (Id));
- return Flag269 (Id);
- end Has_Static_Predicate;
-
- function Has_Static_Predicate_Aspect (Id : E) return B is
- begin
- pragma Assert (Is_Type (Id));
- return Flag259 (Id);
- end Has_Static_Predicate_Aspect;
-
- function Has_Storage_Size_Clause (Id : E) return B is
- begin
- pragma Assert (Is_Access_Type (Id) or else Is_Task_Type (Id));
- return Flag23 (Implementation_Base_Type (Id));
- end Has_Storage_Size_Clause;
-
- function Has_Stream_Size_Clause (Id : E) return B is
- begin
- return Flag184 (Id);
- end Has_Stream_Size_Clause;
-
- function Has_Task (Id : E) return B is
- begin
- return Flag30 (Base_Type (Id));
- end Has_Task;
-
- function Has_Thunks (Id : E) return B is
- begin
- return Flag228 (Id);
- end Has_Thunks;
-
- function Has_Timing_Event (Id : E) return B is
- begin
- return Flag289 (Base_Type (Id));
- end Has_Timing_Event;
-
- function Has_Unchecked_Union (Id : E) return B is
- begin
- return Flag123 (Base_Type (Id));
- end Has_Unchecked_Union;
-
- function Has_Unknown_Discriminants (Id : E) return B is
- begin
- pragma Assert (Is_Type (Id));
- return Flag72 (Id);
- end Has_Unknown_Discriminants;
-
- function Has_Visible_Refinement (Id : E) return B is
- begin
- pragma Assert (Ekind (Id) = E_Abstract_State);
- return Flag263 (Id);
- end Has_Visible_Refinement;
-
- function Has_Volatile_Components (Id : E) return B is
- begin
- return Flag87 (Implementation_Base_Type (Id));
- end Has_Volatile_Components;
-
- function Has_Xref_Entry (Id : E) return B is
- begin
- 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);
- return Node8 (Id);
- end Hiding_Loop_Variable;
-
- function Hidden_In_Formal_Instance (Id : E) return L is
- begin
- pragma Assert (Ekind (Id) = E_Package);
- return Elist30 (Id);
- end Hidden_In_Formal_Instance;
-
- function Homonym (Id : E) return E is
- begin
- return Node4 (Id);
- end Homonym;
-
- function Ignore_SPARK_Mode_Pragmas (Id : E) return B is
- begin
- pragma Assert
- (Ekind (Id) in E_Protected_Body -- concurrent types
- | E_Protected_Type
- | E_Task_Body
- | E_Task_Type
- or else
- 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 (Id) in E_Generic_Package -- packages
- | E_Package
- | E_Package_Body);
- return Flag301 (Id);
- end Ignore_SPARK_Mode_Pragmas;
-
- function Import_Pragma (Id : E) return E is
- begin
- pragma Assert (Is_Subprogram (Id));
- return Node35 (Id);
- end Import_Pragma;
-
- function Incomplete_Actuals (Id : E) return L is
- begin
- pragma Assert (Ekind (Id) = E_Package);
- return Elist24 (Id);
- end Incomplete_Actuals;
-
- function Interface_Alias (Id : E) return E is
- begin
- pragma Assert (Is_Subprogram (Id));
- return Node25 (Id);
- end Interface_Alias;
-
- function Interfaces (Id : E) return L is
- begin
- pragma Assert (Is_Record_Type (Id));
- return Elist25 (Id);
- end Interfaces;
-
- function In_Package_Body (Id : E) return B is
- begin
- return Flag48 (Id);
- end In_Package_Body;
-
- function In_Private_Part (Id : E) return B is
- begin
- return Flag45 (Id);
- end In_Private_Part;
-
- function In_Use (Id : E) return B is
- begin
- pragma Assert (Nkind (Id) in N_Entity);
- return Flag8 (Id);
- end In_Use;
-
- function Initialization_Statements (Id : E) return N is
- begin
- pragma Assert (Ekind (Id) in E_Constant | E_Variable);
- return Node28 (Id);
- end Initialization_Statements;
-
- function Inner_Instances (Id : E) return L is
- begin
- return Elist23 (Id);
- end Inner_Instances;
-
- function Interface_Name (Id : E) return N is
- begin
- return Node21 (Id);
- end Interface_Name;
-
- function Is_Abstract_Subprogram (Id : E) return B is
- begin
- pragma Assert (Is_Overloadable (Id));
- return Flag19 (Id);
- end Is_Abstract_Subprogram;
-
- function Is_Abstract_Type (Id : E) return B is
- begin
- pragma Assert (Is_Type (Id));
- return Flag146 (Id);
- end Is_Abstract_Type;
-
- function Is_Access_Constant (Id : E) return B is
- begin
- pragma Assert (Is_Access_Type (Id));
- return Flag69 (Id);
- end Is_Access_Constant;
-
- function Is_Activation_Record (Id : E) return B is
- begin
- pragma Assert (Ekind (Id) = E_In_Parameter);
- return Flag305 (Id);
- end Is_Activation_Record;
-
- function Is_Actual_Subtype (Id : E) return B is
- begin
- pragma Assert (Is_Type (Id));
- return Flag293 (Id);
- end Is_Actual_Subtype;
-
- function Is_Ada_2005_Only (Id : E) return B is
- begin
- return Flag185 (Id);
- end Is_Ada_2005_Only;
-
- function Is_Ada_2012_Only (Id : E) return B is
- begin
- return Flag199 (Id);
- end Is_Ada_2012_Only;
-
- function Is_Aliased (Id : E) return B is
- begin
- pragma Assert (Nkind (Id) in N_Entity);
- return Flag15 (Id);
- end Is_Aliased;
-
- function Is_Asynchronous (Id : E) return B is
- begin
- pragma Assert (Ekind (Id) = E_Procedure or else Is_Type (Id));
- return Flag81 (Id);
- end Is_Asynchronous;
-
- function Is_Atomic (Id : E) return B is
- begin
- return Flag85 (Id);
- end Is_Atomic;
-
- function Is_Bit_Packed_Array (Id : E) return B is
- begin
- return Flag122 (Implementation_Base_Type (Id));
- end Is_Bit_Packed_Array;
-
- function Is_Called (Id : E) return B is
- begin
- pragma Assert (Ekind (Id) in E_Procedure | E_Function | E_Package);
- return Flag102 (Id);
- end Is_Called;
-
- function Is_Character_Type (Id : E) return B is
- begin
- return Flag63 (Id);
- end Is_Character_Type;
-
- function Is_Checked_Ghost_Entity (Id : E) return B is
- begin
- -- Allow this attribute to appear on unanalyzed entities
-
- pragma Assert (Nkind (Id) in N_Entity
- or else Ekind (Id) = E_Void);
- return Flag277 (Id);
- end Is_Checked_Ghost_Entity;
-
- function Is_Child_Unit (Id : E) return B is
- begin
- return Flag73 (Id);
- end Is_Child_Unit;
-
- function Is_Class_Wide_Clone (Id : E) return B is
- begin
- return Flag290 (Id);
- end Is_Class_Wide_Clone;
-
- function Is_Class_Wide_Equivalent_Type (Id : E) return B is
- begin
- return Flag35 (Id);
- end Is_Class_Wide_Equivalent_Type;
-
- function Is_Compilation_Unit (Id : E) return B is
- begin
- return Flag149 (Id);
- end Is_Compilation_Unit;
-
- function Is_Completely_Hidden (Id : E) return B is
- begin
- pragma Assert (Ekind (Id) = E_Discriminant);
- return Flag103 (Id);
- end Is_Completely_Hidden;
-
- function Is_Constr_Subt_For_U_Nominal (Id : E) return B is
- begin
- return Flag80 (Id);
- end Is_Constr_Subt_For_U_Nominal;
-
- function Is_Constr_Subt_For_UN_Aliased (Id : E) return B is
- begin
- return Flag141 (Id);
- end Is_Constr_Subt_For_UN_Aliased;
-
- function Is_Constrained (Id : E) return B is
- begin
- pragma Assert (Nkind (Id) in N_Entity);
- return Flag12 (Id);
- end Is_Constrained;
-
- function Is_Constructor (Id : E) return B is
- begin
- return Flag76 (Id);
- end Is_Constructor;
-
- function Is_Controlled_Active (Id : E) return B is
- begin
- return Flag42 (Base_Type (Id));
- end Is_Controlled_Active;
-
- function Is_Controlling_Formal (Id : E) return B is
- begin
- pragma Assert (Is_Formal (Id));
- return Flag97 (Id);
- end Is_Controlling_Formal;
-
- function Is_CPP_Class (Id : E) return B is
- begin
- 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 (Id) in E_Function | E_Procedure);
- return Flag132 (Id);
- end Is_DIC_Procedure;
-
- function Is_Descendant_Of_Address (Id : E) return B is
- begin
- return Flag223 (Id);
- end Is_Descendant_Of_Address;
-
- function Is_Discrim_SO_Function (Id : E) return B is
- begin
- return Flag176 (Id);
- end Is_Discrim_SO_Function;
-
- function Is_Discriminant_Check_Function (Id : E) return B is
- begin
- return Flag264 (Id);
- end Is_Discriminant_Check_Function;
-
- function Is_Dispatch_Table_Entity (Id : E) return B is
- begin
- return Flag234 (Id);
- end Is_Dispatch_Table_Entity;
-
- function Is_Dispatching_Operation (Id : E) return B is
- begin
- pragma Assert (Nkind (Id) in N_Entity);
- return Flag6 (Id);
- end Is_Dispatching_Operation;
-
- function Is_Elaboration_Checks_OK_Id (Id : E) return B is
- begin
- pragma Assert (Is_Elaboration_Target (Id));
- return Flag148 (Id);
- end Is_Elaboration_Checks_OK_Id;
-
- function Is_Elaboration_Warnings_OK_Id (Id : E) return B is
- begin
- pragma Assert (Is_Elaboration_Target (Id) or else Ekind (Id) = E_Void);
- return Flag304 (Id);
- end Is_Elaboration_Warnings_OK_Id;
-
- function Is_Eliminated (Id : E) return B is
- begin
- return Flag124 (Id);
- end Is_Eliminated;
-
- function Is_Entry_Formal (Id : E) return B is
- begin
- return Flag52 (Id);
- end Is_Entry_Formal;
-
- function Is_Entry_Wrapper (Id : E) return B is
- begin
- return Flag297 (Id);
- end Is_Entry_Wrapper;
-
- function Is_Exception_Handler (Id : E) return B is
- begin
- pragma Assert (Ekind (Id) = E_Block);
- return Flag286 (Id);
- end Is_Exception_Handler;
-
- function Is_Exported (Id : E) return B is
- begin
- return Flag99 (Id);
- end Is_Exported;
-
- function Is_Finalized_Transient (Id : E) return B is
- begin
- pragma Assert (Ekind (Id) in E_Constant | E_Loop_Parameter | E_Variable);
- return Flag252 (Id);
- end Is_Finalized_Transient;
-
- function Is_First_Subtype (Id : E) return B is
- begin
- return Flag70 (Id);
- end Is_First_Subtype;
-
- function Is_Formal_Subprogram (Id : E) return B is
- begin
- return Flag111 (Id);
- end Is_Formal_Subprogram;
-
- function Is_Frozen (Id : E) return B is
- begin
- return Flag4 (Id);
- end Is_Frozen;
-
- function Is_Generic_Actual_Subprogram (Id : E) return B is
- begin
- pragma Assert (Ekind (Id) in E_Function | E_Procedure);
- return Flag274 (Id);
- end Is_Generic_Actual_Subprogram;
-
- function Is_Generic_Actual_Type (Id : E) return B is
- begin
- pragma Assert (Is_Type (Id));
- return Flag94 (Id);
- end Is_Generic_Actual_Type;
-
- function Is_Generic_Instance (Id : E) return B is
- begin
- return Flag130 (Id);
- end Is_Generic_Instance;
-
- function Is_Generic_Type (Id : E) return B is
- begin
- pragma Assert (Nkind (Id) in N_Entity);
- return Flag13 (Id);
- end Is_Generic_Type;
-
- function Is_Hidden (Id : E) return B is
- begin
- return Flag57 (Id);
- end Is_Hidden;
-
- function Is_Hidden_Non_Overridden_Subpgm (Id : E) return B is
- begin
- return Flag2 (Id);
- end Is_Hidden_Non_Overridden_Subpgm;
-
- function Is_Hidden_Open_Scope (Id : E) return B is
- begin
- return Flag171 (Id);
- end Is_Hidden_Open_Scope;
-
- function Is_Ignored_Ghost_Entity (Id : E) return B is
- begin
- -- Allow this attribute to appear on unanalyzed entities
-
- pragma Assert (Nkind (Id) in N_Entity
- or else Ekind (Id) = E_Void);
- return Flag278 (Id);
- end Is_Ignored_Ghost_Entity;
-
- function Is_Ignored_Transient (Id : E) return B is
- begin
- pragma Assert (Ekind (Id) in E_Constant | E_Loop_Parameter | E_Variable);
- return Flag295 (Id);
- end Is_Ignored_Transient;
-
- function Is_Immediately_Visible (Id : E) return B is
- begin
- pragma Assert (Nkind (Id) in N_Entity);
- return Flag7 (Id);
- end Is_Immediately_Visible;
-
- function Is_Implementation_Defined (Id : E) return B is
- begin
- return Flag254 (Id);
- end Is_Implementation_Defined;
-
- function Is_Imported (Id : E) return B is
- begin
- return Flag24 (Id);
- end Is_Imported;
-
- function Is_Independent (Id : E) return B is
- begin
- return Flag268 (Id);
- end Is_Independent;
-
- function Is_Initial_Condition_Procedure (Id : E) return B is
- begin
- pragma Assert (Ekind (Id) in E_Function | E_Procedure);
- return Flag302 (Id);
- end Is_Initial_Condition_Procedure;
-
- function Is_Inlined (Id : E) return B is
- begin
- return Flag11 (Id);
- end Is_Inlined;
-
- function Is_Inlined_Always (Id : E) return B is
- begin
- pragma Assert (Ekind (Id) in E_Function | E_Procedure);
- return Flag1 (Id);
- end Is_Inlined_Always;
-
- function Is_Interface (Id : E) return B is
- begin
- return Flag186 (Id);
- end Is_Interface;
-
- function Is_Instantiated (Id : E) return B is
- begin
- return Flag126 (Id);
- end Is_Instantiated;
-
- function Is_Internal (Id : E) return B is
- begin
- pragma Assert (Nkind (Id) in N_Entity);
- return Flag17 (Id);
- end Is_Internal;
-
- function Is_Interrupt_Handler (Id : E) return B is
- begin
- pragma Assert (Nkind (Id) in N_Entity);
- return Flag89 (Id);
- end Is_Interrupt_Handler;
-
- function Is_Intrinsic_Subprogram (Id : E) return B is
- begin
- return Flag64 (Id);
- end Is_Intrinsic_Subprogram;
-
- function Is_Invariant_Procedure (Id : E) return B is
- begin
- pragma Assert (Ekind (Id) in E_Function | E_Procedure);
- return Flag257 (Id);
- end Is_Invariant_Procedure;
-
- function Is_Itype (Id : E) return B is
- begin
- return Flag91 (Id);
- end Is_Itype;
-
- function Is_Known_Non_Null (Id : E) return B is
- begin
- return Flag37 (Id);
- end Is_Known_Non_Null;
-
- function Is_Known_Null (Id : E) return B is
- begin
- return Flag204 (Id);
- end Is_Known_Null;
-
- function Is_Known_Valid (Id : E) return B is
- begin
- return Flag170 (Id);
- end Is_Known_Valid;
-
- function Is_Limited_Composite (Id : E) return B is
- begin
- return Flag106 (Id);
- end Is_Limited_Composite;
-
- function Is_Limited_Interface (Id : E) return B is
- begin
- return Flag197 (Id);
- end Is_Limited_Interface;
-
- function Is_Limited_Record (Id : E) return B is
- begin
- return Flag25 (Id);
- end Is_Limited_Record;
-
- function Is_Local_Anonymous_Access (Id : E) return B is
- begin
- pragma Assert (Is_Access_Type (Id));
- return Flag194 (Id);
- end Is_Local_Anonymous_Access;
-
- function Is_Loop_Parameter (Id : E) return B is
- begin
- return Flag307 (Id);
- end Is_Loop_Parameter;
-
- function Is_Machine_Code_Subprogram (Id : E) return B is
- begin
- pragma Assert (Is_Subprogram (Id));
- return Flag137 (Id);
- end Is_Machine_Code_Subprogram;
-
- function Is_Non_Static_Subtype (Id : E) return B is
- begin
- pragma Assert (Is_Type (Id));
- return Flag109 (Id);
- end Is_Non_Static_Subtype;
-
- function Is_Null_Init_Proc (Id : E) return B is
- begin
- pragma Assert (Ekind (Id) = E_Procedure);
- return Flag178 (Id);
- end Is_Null_Init_Proc;
-
- function Is_Obsolescent (Id : E) return B is
- begin
- return Flag153 (Id);
- end Is_Obsolescent;
-
- function Is_Only_Out_Parameter (Id : E) return B is
- begin
- pragma Assert (Is_Formal (Id));
- return Flag226 (Id);
- end Is_Only_Out_Parameter;
-
- function Is_Package_Body_Entity (Id : E) return B is
- begin
- return Flag160 (Id);
- end Is_Package_Body_Entity;
-
- function Is_Packed (Id : E) return B is
- begin
- return Flag51 (Implementation_Base_Type (Id));
- end Is_Packed;
-
- function Is_Packed_Array_Impl_Type (Id : E) return B is
- begin
- return Flag138 (Id);
- end Is_Packed_Array_Impl_Type;
-
- function Is_Param_Block_Component_Type (Id : E) return B is
- begin
- pragma Assert (Is_Access_Type (Id));
- return Flag215 (Base_Type (Id));
- end Is_Param_Block_Component_Type;
-
- function Is_Partial_DIC_Procedure (Id : E) return B is
- Partial_DIC_Suffix : constant String := "Partial_DIC";
- DIC_Nam : constant String := Get_Name_String (Chars (Id));
-
- begin
- pragma Assert (Ekind (Id) in E_Function | E_Procedure);
-
- -- Instead of adding a new Entity_Id flag (which are in short supply),
- -- we test the form of the subprogram name. When the node field and flag
- -- situation is eased, this should be replaced with a flag. ???
-
- if DIC_Nam'Length > Partial_DIC_Suffix'Length
- and then
- DIC_Nam
- (DIC_Nam'Last - Partial_DIC_Suffix'Length + 1 .. DIC_Nam'Last) =
- Partial_DIC_Suffix
- then
- return True;
- else
- return False;
- end if;
- end Is_Partial_DIC_Procedure;
-
- function Is_Partial_Invariant_Procedure (Id : E) return B is
- begin
- pragma Assert (Ekind (Id) in E_Function | E_Procedure);
- return Flag292 (Id);
- end Is_Partial_Invariant_Procedure;
-
- function Is_Potentially_Use_Visible (Id : E) return B is
- begin
- pragma Assert (Nkind (Id) in N_Entity);
- return Flag9 (Id);
- end Is_Potentially_Use_Visible;
-
- function Is_Predicate_Function (Id : E) return B is
- begin
- 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 (Id) in E_Function | E_Procedure);
- return Flag256 (Id);
- end Is_Predicate_Function_M;
-
- function Is_Preelaborated (Id : E) return B is
- begin
- return Flag59 (Id);
- end Is_Preelaborated;
-
- function Is_Primitive (Id : E) return B is
- begin
- 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 (Id) in E_Function | E_Procedure);
- return Flag195 (Id);
- end Is_Primitive_Wrapper;
-
- function Is_Private_Composite (Id : E) return B is
- begin
- pragma Assert (Is_Type (Id));
- return Flag107 (Id);
- end Is_Private_Composite;
-
- function Is_Private_Descendant (Id : E) return B is
- begin
- return Flag53 (Id);
- end Is_Private_Descendant;
-
- function Is_Private_Primitive (Id : E) return B is
- begin
- pragma Assert (Ekind (Id) in E_Function | E_Procedure);
- return Flag245 (Id);
- end Is_Private_Primitive;
-
- function Is_Public (Id : E) return B is
- begin
- pragma Assert (Nkind (Id) in N_Entity);
- return Flag10 (Id);
- end Is_Public;
-
- function Is_Pure (Id : E) return B is
- begin
- return Flag44 (Id);
- end Is_Pure;
-
- function Is_Pure_Unit_Access_Type (Id : E) return B is
- begin
- pragma Assert (Is_Access_Type (Id));
- return Flag189 (Id);
- end Is_Pure_Unit_Access_Type;
-
- function Is_RACW_Stub_Type (Id : E) return B is
- begin
- pragma Assert (Is_Type (Id));
- return Flag244 (Id);
- end Is_RACW_Stub_Type;
-
- function Is_Raised (Id : E) return B is
- begin
- pragma Assert (Ekind (Id) = E_Exception);
- return Flag224 (Id);
- end Is_Raised;
-
- function Is_Remote_Call_Interface (Id : E) return B is
- begin
- return Flag62 (Id);
- end Is_Remote_Call_Interface;
-
- function Is_Remote_Types (Id : E) return B is
- begin
- return Flag61 (Id);
- end Is_Remote_Types;
-
- function Is_Renaming_Of_Object (Id : E) return B is
- begin
- return Flag112 (Id);
- end Is_Renaming_Of_Object;
-
- function Is_Return_Object (Id : E) return B is
- begin
- return Flag209 (Id);
- end Is_Return_Object;
-
- function Is_Safe_To_Reevaluate (Id : E) return B is
- begin
- return Flag249 (Id);
- end Is_Safe_To_Reevaluate;
-
- function Is_Shared_Passive (Id : E) return B is
- begin
- return Flag60 (Id);
- end Is_Shared_Passive;
-
- function Is_Static_Type (Id : E) return B is
- begin
- return Flag281 (Id);
- end Is_Static_Type;
-
- function Is_Statically_Allocated (Id : E) return B is
- begin
- return Flag28 (Id);
- end Is_Statically_Allocated;
-
- function Is_Tag (Id : E) return B is
- begin
- pragma Assert (Nkind (Id) in N_Entity);
- return Flag78 (Id);
- end Is_Tag;
-
- function Is_Tagged_Type (Id : E) return B is
- begin
- return Flag55 (Id);
- end Is_Tagged_Type;
-
- function Is_Thunk (Id : E) return B is
- begin
- return Flag225 (Id);
- end Is_Thunk;
-
- function Is_Trivial_Subprogram (Id : E) return B is
- begin
- return Flag235 (Id);
- end Is_Trivial_Subprogram;
-
- function Is_True_Constant (Id : E) return B is
- begin
- return Flag163 (Id);
- end Is_True_Constant;
-
- function Is_Unchecked_Union (Id : E) return B is
- begin
- return Flag117 (Implementation_Base_Type (Id));
- end Is_Unchecked_Union;
-
- function Is_Underlying_Full_View (Id : E) return B is
- begin
- return Flag298 (Id);
- end Is_Underlying_Full_View;
-
- function Is_Underlying_Record_View (Id : E) return B is
- begin
- return Flag246 (Id);
- end Is_Underlying_Record_View;
-
- function Is_Unimplemented (Id : E) return B is
- begin
- return Flag284 (Id);
- end Is_Unimplemented;
-
- function Is_Unsigned_Type (Id : E) return B is
- begin
- pragma Assert (Is_Type (Id));
- return Flag144 (Id);
- end Is_Unsigned_Type;
-
- function Is_Uplevel_Referenced_Entity (Id : E) return B is
- begin
- return Flag283 (Id);
- end Is_Uplevel_Referenced_Entity;
-
- function Is_Valued_Procedure (Id : E) return B is
- begin
- pragma Assert (Ekind (Id) = E_Procedure);
- return Flag127 (Id);
- end Is_Valued_Procedure;
-
- function Is_Visible_Formal (Id : E) return B is
- begin
- return Flag206 (Id);
- end Is_Visible_Formal;
-
- function Is_Visible_Lib_Unit (Id : E) return B is
- begin
- return Flag116 (Id);
- end Is_Visible_Lib_Unit;
-
- function Is_Volatile (Id : E) return B is
- begin
- pragma Assert (Nkind (Id) in N_Entity);
-
- if Is_Type (Id) then
- return Flag16 (Base_Type (Id));
- else
- return Flag16 (Id);
- end if;
- end Is_Volatile;
-
- function Is_Volatile_Full_Access (Id : E) return B is
- begin
- return Flag285 (Id);
- end Is_Volatile_Full_Access;
-
- function Itype_Printed (Id : E) return B is
- begin
- pragma Assert (Is_Itype (Id));
- return Flag202 (Id);
- end Itype_Printed;
-
- function Kill_Elaboration_Checks (Id : E) return B is
- begin
- return Flag32 (Id);
- end Kill_Elaboration_Checks;
-
- function Kill_Range_Checks (Id : E) return B is
- begin
- return Flag33 (Id);
- end Kill_Range_Checks;
-
- function Known_To_Have_Preelab_Init (Id : E) return B is
- begin
- pragma Assert (Is_Type (Id));
- return Flag207 (Id);
- end Known_To_Have_Preelab_Init;
-
- function Last_Aggregate_Assignment (Id : E) return N is
- begin
- pragma Assert (Ekind (Id) in E_Constant | E_Variable);
- return Node30 (Id);
- end Last_Aggregate_Assignment;
-
- function Last_Assignment (Id : E) return N is
- begin
- pragma Assert (Is_Assignable (Id));
- return Node26 (Id);
- end Last_Assignment;
-
- function Last_Entity (Id : E) return E is
- begin
- return Node20 (Id);
- end Last_Entity;
-
- function Limited_View (Id : E) return E is
- begin
- pragma Assert (Ekind (Id) = E_Package);
- return Node23 (Id);
- end Limited_View;
-
- function Linker_Section_Pragma (Id : E) return N is
- begin
- pragma Assert
- (Is_Object (Id) or else Is_Subprogram (Id) or else Is_Type (Id));
- return Node33 (Id);
- end Linker_Section_Pragma;
-
- function Lit_Indexes (Id : E) return E is
- begin
- pragma Assert (Is_Enumeration_Type (Id));
- return Node18 (Id);
- end Lit_Indexes;
-
- function Lit_Strings (Id : E) return E is
- begin
- pragma Assert (Is_Enumeration_Type (Id));
- return Node16 (Id);
- end Lit_Strings;
-
- function Low_Bound_Tested (Id : E) return B is
- begin
- return Flag205 (Id);
- end Low_Bound_Tested;
-
- function Machine_Radix_10 (Id : E) return B is
- begin
- pragma Assert (Is_Decimal_Fixed_Point_Type (Id));
- return Flag84 (Id);
- end Machine_Radix_10;
-
- function Master_Id (Id : E) return E is
- begin
- pragma Assert (Is_Access_Type (Id));
- return Node17 (Id);
- end Master_Id;
-
- function Materialize_Entity (Id : E) return B is
- begin
- return Flag168 (Id);
- end Materialize_Entity;
-
- function May_Inherit_Delayed_Rep_Aspects (Id : E) return B is
- begin
- return Flag262 (Id);
- end May_Inherit_Delayed_Rep_Aspects;
-
- function Mechanism (Id : E) return M is
- begin
- pragma Assert (Ekind (Id) = E_Function or else Is_Formal (Id));
- return UI_To_Int (Uint8 (Id));
- end Mechanism;
-
- function Minimum_Accessibility (Id : E) return E is
- begin
- pragma Assert (Is_Formal (Id));
- return Node24 (Id);
- end Minimum_Accessibility;
-
- function Modulus (Id : E) return Uint is
- begin
- pragma Assert (Is_Modular_Integer_Type (Id));
- return Uint17 (Base_Type (Id));
- end Modulus;
-
- function Must_Be_On_Byte_Boundary (Id : E) return B is
- begin
- pragma Assert (Is_Type (Id));
- return Flag183 (Id);
- end Must_Be_On_Byte_Boundary;
-
- function Must_Have_Preelab_Init (Id : E) return B is
- begin
- pragma Assert (Is_Type (Id));
- return Flag208 (Id);
- end Must_Have_Preelab_Init;
-
- function Needs_Activation_Record (Id : E) return B is
- begin
- return Flag306 (Id);
- end Needs_Activation_Record;
-
- function Needs_Debug_Info (Id : E) return B is
- begin
- return Flag147 (Id);
- end Needs_Debug_Info;
-
- function Needs_No_Actuals (Id : E) return B is
- begin
- pragma Assert
- (Is_Overloadable (Id)
- or else Ekind (Id) in E_Subprogram_Type | E_Entry_Family);
- return Flag22 (Id);
- end Needs_No_Actuals;
-
- function Never_Set_In_Source (Id : E) return B is
- begin
- return Flag115 (Id);
- end Never_Set_In_Source;
-
- function Next_Inlined_Subprogram (Id : E) return E is
- begin
- return Node12 (Id);
- end Next_Inlined_Subprogram;
-
- function No_Dynamic_Predicate_On_Actual (Id : E) return Boolean is
- begin
- pragma Assert (Is_Discrete_Type (Id));
- return Flag276 (Id);
- end No_Dynamic_Predicate_On_Actual;
-
- function No_Pool_Assigned (Id : E) return B is
- begin
- pragma Assert (Is_Access_Type (Id));
- return Flag131 (Root_Type (Id));
- end No_Pool_Assigned;
-
- function No_Predicate_On_Actual (Id : E) return Boolean is
- begin
- pragma Assert (Is_Discrete_Type (Id));
- return Flag275 (Id);
- end No_Predicate_On_Actual;
-
- function No_Reordering (Id : E) return B is
- begin
- pragma Assert (Is_Record_Type (Id));
- return Flag239 (Implementation_Base_Type (Id));
- end No_Reordering;
-
- function No_Return (Id : E) return B is
- begin
- return Flag113 (Id);
- end No_Return;
-
- function No_Strict_Aliasing (Id : E) return B is
- begin
- pragma Assert (Is_Access_Type (Id));
- return Flag136 (Base_Type (Id));
- end No_Strict_Aliasing;
-
- function No_Tagged_Streams_Pragma (Id : E) return N is
- begin
- pragma Assert (Is_Tagged_Type (Id));
- return Node32 (Id);
- end No_Tagged_Streams_Pragma;
-
- function Non_Binary_Modulus (Id : E) return B is
- begin
- pragma Assert (Is_Type (Id));
- return Flag58 (Base_Type (Id));
- end Non_Binary_Modulus;
-
- function Non_Limited_View (Id : E) return E is
- begin
- pragma Assert
- (Ekind (Id) in Incomplete_Kind
- or else
- Ekind (Id) in Class_Wide_Kind
- or else
- Ekind (Id) = E_Abstract_State);
- return Node19 (Id);
- end Non_Limited_View;
-
- function Nonzero_Is_True (Id : E) return B is
- begin
- pragma Assert (Root_Type (Id) = Standard_Boolean);
- return Flag162 (Base_Type (Id));
- end Nonzero_Is_True;
-
- function Normalized_First_Bit (Id : E) return U is
- begin
- 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 (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 (Id) in E_Component | E_Discriminant);
- return Uint10 (Id);
- end Normalized_Position_Max;
-
- function OK_To_Rename (Id : E) return B is
- begin
- pragma Assert (Ekind (Id) = E_Variable);
- return Flag247 (Id);
- end OK_To_Rename;
-
- function Optimize_Alignment_Space (Id : E) return B is
- begin
- pragma Assert
- (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 (Id) in E_Constant | E_Variable);
- return Flag242 (Id);
- end Optimize_Alignment_Time;
-
- function Original_Access_Type (Id : E) return E is
- begin
- pragma Assert (Ekind (Id) = E_Access_Subprogram_Type);
- return Node28 (Id);
- end Original_Access_Type;
-
- function Original_Array_Type (Id : E) return E is
- begin
- pragma Assert (Is_Array_Type (Id) or else Is_Modular_Integer_Type (Id));
- return Node21 (Id);
- end Original_Array_Type;
-
- function Original_Protected_Subprogram (Id : E) return N is
- begin
- return Node41 (Id);
- end Original_Protected_Subprogram;
-
- function Original_Record_Component (Id : E) return E is
- begin
- pragma Assert (Ekind (Id) in E_Void | E_Component | E_Discriminant);
- return Node22 (Id);
- end Original_Record_Component;
-
- function Overlays_Constant (Id : E) return B is
- begin
- return Flag243 (Id);
- end Overlays_Constant;
-
- function Overridden_Operation (Id : E) return E is
- begin
- pragma Assert (Is_Subprogram_Or_Generic_Subprogram (Id));
- return Node26 (Id);
- end Overridden_Operation;
-
- function Package_Instantiation (Id : E) return N is
- begin
- pragma Assert (Is_Package_Or_Generic_Package (Id));
- return Node26 (Id);
- end Package_Instantiation;
-
- function Packed_Array_Impl_Type (Id : E) return E is
- begin
- pragma Assert (Is_Array_Type (Id));
- return Node23 (Id);
- end Packed_Array_Impl_Type;
-
- function Parent_Subtype (Id : E) return E is
- begin
- pragma Assert (Is_Record_Type (Id));
- return Node19 (Base_Type (Id));
- end Parent_Subtype;
-
- function Part_Of_Constituents (Id : E) return L is
- begin
- pragma Assert (Ekind (Id) in E_Abstract_State | E_Variable);
- return Elist10 (Id);
- end Part_Of_Constituents;
-
- function Part_Of_References (Id : E) return L is
- begin
- pragma Assert (Ekind (Id) = E_Variable);
- return Elist11 (Id);
- end Part_Of_References;
-
- function Partial_View_Has_Unknown_Discr (Id : E) return B is
- begin
- pragma Assert (Is_Type (Id));
- return Flag280 (Id);
- end Partial_View_Has_Unknown_Discr;
-
- function Pending_Access_Types (Id : E) return L is
- begin
- pragma Assert (Is_Type (Id));
- return Elist15 (Id);
- end Pending_Access_Types;
-
- function Postconditions_Proc (Id : E) return E is
- begin
- 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 (Id) in E_Array_Subtype |
- E_Record_Subtype |
- E_Record_Subtype_With_Private);
- return Node38 (Id);
- end Predicated_Parent;
-
- function Predicates_Ignored (Id : E) return B is
- begin
- pragma Assert (Is_Type (Id));
- return Flag288 (Id);
- end Predicates_Ignored;
-
- function Prev_Entity (Id : E) return E is
- begin
- return Node36 (Id);
- end Prev_Entity;
-
- function Prival (Id : E) return E is
- begin
- pragma Assert (Is_Protected_Component (Id));
- return Node17 (Id);
- end Prival;
-
- function Prival_Link (Id : E) return E is
- begin
- pragma Assert (Ekind (Id) in E_Constant | E_Variable);
- return Node20 (Id);
- end Prival_Link;
-
- function Private_Dependents (Id : E) return L is
- begin
- pragma Assert (Is_Incomplete_Or_Private_Type (Id));
- return Elist18 (Id);
- end Private_Dependents;
-
- function Protected_Body_Subprogram (Id : E) return E is
- begin
- pragma Assert (Is_Subprogram_Or_Entry (Id));
- return Node11 (Id);
- end Protected_Body_Subprogram;
-
- function Protected_Formal (Id : E) return E is
- begin
- pragma Assert (Is_Formal (Id));
- return Node22 (Id);
- end Protected_Formal;
-
- function Protected_Subprogram (Id : E) return N is
- begin
- 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 (Id) in E_Entry | E_Entry_Family | E_Function | E_Procedure);
- return Node23 (Id);
- end Protection_Object;
-
- function Reachable (Id : E) return B is
- begin
- return Flag49 (Id);
- end Reachable;
-
- function Receiving_Entry (Id : E) return E is
- begin
- pragma Assert (Ekind (Id) = E_Procedure);
- return Node19 (Id);
- end Receiving_Entry;
-
- function Referenced (Id : E) return B is
- begin
- return Flag156 (Id);
- end Referenced;
-
- function Referenced_As_LHS (Id : E) return B is
- begin
- return Flag36 (Id);
- end Referenced_As_LHS;
-
- function Referenced_As_Out_Parameter (Id : E) return B is
- begin
- return Flag227 (Id);
- end Referenced_As_Out_Parameter;
-
- function Refinement_Constituents (Id : E) return L is
- begin
- pragma Assert (Ekind (Id) = E_Abstract_State);
- return Elist8 (Id);
- end Refinement_Constituents;
-
- function Register_Exception_Call (Id : E) return N is
- begin
- pragma Assert (Ekind (Id) = E_Exception);
- return Node20 (Id);
- end Register_Exception_Call;
-
- function Related_Array_Object (Id : E) return E is
- begin
- pragma Assert (Is_Array_Type (Id));
- return Node25 (Id);
- end Related_Array_Object;
-
- function Related_Expression (Id : E) return N is
- begin
- pragma Assert
- (Ekind (Id) in Type_Kind | E_Constant | E_Variable | E_Function);
- return Node24 (Id);
- end Related_Expression;
-
- function Related_Instance (Id : E) return E is
- begin
- 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 (Id) in E_Component | E_Constant | E_Variable);
- return Node27 (Id);
- end Related_Type;
-
- function Relative_Deadline_Variable (Id : E) return E is
- begin
- pragma Assert (Is_Task_Type (Id));
- return Node28 (Implementation_Base_Type (Id));
- end Relative_Deadline_Variable;
-
- function Renamed_Entity (Id : E) return N is
- begin
- return Node18 (Id);
- end Renamed_Entity;
-
- function Renamed_In_Spec (Id : E) return B is
- begin
- pragma Assert (Ekind (Id) = E_Package);
- return Flag231 (Id);
- end Renamed_In_Spec;
-
- function Renamed_Object (Id : E) return N is
- begin
- return Node18 (Id);
- end Renamed_Object;
-
- function Renaming_Map (Id : E) return U is
- begin
- return Uint9 (Id);
- end Renaming_Map;
-
- function Requires_Overriding (Id : E) return B is
- begin
- pragma Assert (Is_Overloadable (Id));
- return Flag213 (Id);
- end Requires_Overriding;
-
- function Return_Present (Id : E) return B is
- begin
- return Flag54 (Id);
- end Return_Present;
-
- function Return_Applies_To (Id : E) return N is
- begin
- return Node8 (Id);
- end Return_Applies_To;
-
- function Returns_By_Ref (Id : E) return B is
- begin
- return Flag90 (Id);
- end Returns_By_Ref;
-
- function Reverse_Bit_Order (Id : E) return B is
- begin
- pragma Assert (Is_Record_Type (Id));
- return Flag164 (Base_Type (Id));
- end Reverse_Bit_Order;
-
- function Reverse_Storage_Order (Id : E) return B is
- begin
- pragma Assert (Is_Record_Type (Id) or else Is_Array_Type (Id));
- return Flag93 (Base_Type (Id));
- end Reverse_Storage_Order;
-
- function Rewritten_For_C (Id : E) return B is
- begin
- pragma Assert (Ekind (Id) = E_Function);
- return Flag287 (Id);
- end Rewritten_For_C;
-
- function RM_Size (Id : E) return U is
- begin
- pragma Assert (Is_Type (Id));
- return Uint13 (Id);
- end RM_Size;
-
- function Scalar_Range (Id : E) return N is
- begin
- return Node20 (Id);
- end Scalar_Range;
-
- function Scale_Value (Id : E) return U is
- begin
- return Uint16 (Id);
- end Scale_Value;
-
- function Scope_Depth_Value (Id : E) return U is
- begin
- pragma Assert
- (Ekind (Id) in
- Concurrent_Kind | Entry_Kind | Generic_Unit_Kind |
- E_Package | E_Package_Body | Subprogram_Kind |
- E_Block | E_Subprogram_Body |
- E_Private_Type .. E_Limited_Private_Subtype |
- E_Void | E_Loop | E_Return_Statement);
- return Uint22 (Id);
- end Scope_Depth_Value;
-
- function Sec_Stack_Needed_For_Return (Id : E) return B is
- begin
- return Flag167 (Id);
- end Sec_Stack_Needed_For_Return;
-
- function Shared_Var_Procs_Instance (Id : E) return E is
- begin
- pragma Assert (Ekind (Id) = E_Variable);
- return Node22 (Id);
- end Shared_Var_Procs_Instance;
-
- function Size_Check_Code (Id : E) return N is
- begin
- pragma Assert (Ekind (Id) in E_Constant | E_Variable);
- return Node19 (Id);
- end Size_Check_Code;
-
- function Size_Depends_On_Discriminant (Id : E) return B is
- begin
- return Flag177 (Id);
- end Size_Depends_On_Discriminant;
-
- function Size_Known_At_Compile_Time (Id : E) return B is
- begin
- return Flag92 (Id);
- end Size_Known_At_Compile_Time;
-
- function Small_Value (Id : E) return R is
- begin
- pragma Assert (Is_Fixed_Point_Type (Id));
- return Ureal21 (Id);
- end Small_Value;
-
- function SPARK_Aux_Pragma (Id : E) return N is
- begin
- pragma Assert
- (Ekind (Id) in E_Protected_Type -- concurrent types
- | E_Task_Type
- or else
- 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 (Id) in E_Protected_Type -- concurrent types
- | E_Task_Type
- or else
- 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 (Id) in E_Constant -- objects
- | E_Variable
- or else
- 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 (Id) in E_Generic_Package -- packages
- | E_Package
- | E_Package_Body
- or else
- Ekind (Id) = E_Void -- special purpose
- or else
- Ekind (Id) in E_Protected_Body -- types
- | E_Task_Body
- or else
- Is_Type (Id));
- return Node40 (Id);
- end SPARK_Pragma;
-
- function SPARK_Pragma_Inherited (Id : E) return B is
- begin
- pragma Assert
- (Ekind (Id) in E_Constant -- objects
- | E_Variable
- or else
- 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 (Id) in E_Generic_Package -- packages
- | E_Package
- | E_Package_Body
- or else
- Ekind (Id) = E_Void -- special purpose
- or else
- Ekind (Id) in E_Protected_Body -- types
- | E_Task_Body
- or else
- Is_Type (Id));
- return Flag265 (Id);
- end SPARK_Pragma_Inherited;
-
- function Spec_Entity (Id : E) return E is
- begin
- pragma Assert (Ekind (Id) = E_Package_Body or else Is_Formal (Id));
- return Node19 (Id);
- end Spec_Entity;
-
- function SSO_Set_High_By_Default (Id : E) return B is
- begin
- pragma Assert (Is_Record_Type (Id) or else Is_Array_Type (Id));
- return Flag273 (Base_Type (Id));
- end SSO_Set_High_By_Default;
-
- function SSO_Set_Low_By_Default (Id : E) return B is
- begin
- pragma Assert (Is_Record_Type (Id) or else Is_Array_Type (Id));
- return Flag272 (Base_Type (Id));
- end SSO_Set_Low_By_Default;
-
- function Static_Discrete_Predicate (Id : E) return S is
- begin
- pragma Assert (Is_Discrete_Type (Id));
- return List25 (Id);
- end Static_Discrete_Predicate;
-
- function Static_Real_Or_String_Predicate (Id : E) return N is
- begin
- pragma Assert (Is_Real_Type (Id) or else Is_String_Type (Id));
- return Node25 (Id);
- end Static_Real_Or_String_Predicate;
-
- function Status_Flag_Or_Transient_Decl (Id : E) return N is
- begin
- pragma Assert
- (Ekind (Id) in E_Constant | E_Loop_Parameter | E_Variable);
- return Node15 (Id);
- end Status_Flag_Or_Transient_Decl;
-
- function Storage_Size_Variable (Id : E) return E is
- begin
- pragma Assert (Is_Access_Type (Id) or else Is_Task_Type (Id));
- return Node26 (Implementation_Base_Type (Id));
- end Storage_Size_Variable;
-
- function Static_Elaboration_Desired (Id : E) return B is
- begin
- pragma Assert (Ekind (Id) = E_Package);
- return Flag77 (Id);
- end Static_Elaboration_Desired;
-
- function Static_Initialization (Id : E) return N is
- begin
- pragma Assert
- (Ekind (Id) = E_Procedure and then not Is_Dispatching_Operation (Id));
- return Node30 (Id);
- end Static_Initialization;
-
- function Stored_Constraint (Id : E) return L is
- begin
- pragma Assert
- (Is_Composite_Type (Id) and then not Is_Array_Type (Id));
- return Elist23 (Id);
- end Stored_Constraint;
-
- function Stores_Attribute_Old_Prefix (Id : E) return B is
- begin
- return Flag270 (Id);
- end Stores_Attribute_Old_Prefix;
-
- function Strict_Alignment (Id : E) return B is
- begin
- return Flag145 (Implementation_Base_Type (Id));
- end Strict_Alignment;
-
- function String_Literal_Length (Id : E) return U is
- begin
- return Uint16 (Id);
- end String_Literal_Length;
-
- function String_Literal_Low_Bound (Id : E) return N is
- begin
- return Node18 (Id);
- end String_Literal_Low_Bound;
-
- function Subprograms_For_Type (Id : E) return L is
- begin
- pragma Assert (Is_Type (Id));
- return Elist29 (Id);
- end Subprograms_For_Type;
-
- function Subps_Index (Id : E) return U is
- begin
- pragma Assert (Is_Subprogram (Id));
- return Uint24 (Id);
- end Subps_Index;
-
- function Suppress_Elaboration_Warnings (Id : E) return B is
- begin
- return Flag303 (Id);
- end Suppress_Elaboration_Warnings;
-
- function Suppress_Initialization (Id : E) return B is
- begin
- pragma Assert (Is_Type (Id) or else Ekind (Id) = E_Variable);
- return Flag105 (Id);
- end Suppress_Initialization;
-
- function Suppress_Style_Checks (Id : E) return B is
- begin
- return Flag165 (Id);
- end Suppress_Style_Checks;
-
- function Suppress_Value_Tracking_On_Call (Id : E) return B is
- begin
- return Flag217 (Id);
- end Suppress_Value_Tracking_On_Call;
-
- function Task_Body_Procedure (Id : E) return N is
- begin
- pragma Assert (Ekind (Id) in Task_Kind);
- return Node25 (Id);
- end Task_Body_Procedure;
-
- function Thunk_Entity (Id : E) return E is
- begin
- pragma Assert (Ekind (Id) in E_Function | E_Procedure
- and then Is_Thunk (Id));
- return Node31 (Id);
- end Thunk_Entity;
-
- function Treat_As_Volatile (Id : E) return B is
- begin
- return Flag41 (Id);
- end Treat_As_Volatile;
-
- function Underlying_Full_View (Id : E) return E is
- begin
- pragma Assert (Ekind (Id) in Private_Kind);
- return Node19 (Id);
- end Underlying_Full_View;
-
- function Underlying_Record_View (Id : E) return E is
- begin
- return Node28 (Id);
- end Underlying_Record_View;
-
- function Universal_Aliasing (Id : E) return B is
- begin
- pragma Assert (Is_Type (Id));
- return Flag216 (Implementation_Base_Type (Id));
- end Universal_Aliasing;
-
- function Unset_Reference (Id : E) return N is
- begin
- return Node16 (Id);
- end Unset_Reference;
-
- function Used_As_Generic_Actual (Id : E) return B is
- begin
- return Flag222 (Id);
- end Used_As_Generic_Actual;
-
- function Uses_Lock_Free (Id : E) return B is
- begin
- pragma Assert (Is_Protected_Type (Id));
- return Flag188 (Id);
- end Uses_Lock_Free;
-
- function Uses_Sec_Stack (Id : E) return B is
- begin
- return Flag95 (Id);
- end Uses_Sec_Stack;
-
- function Validated_Object (Id : E) return N is
- begin
- pragma Assert (Ekind (Id) = E_Variable);
- return Node38 (Id);
- end Validated_Object;
-
- function Warnings_Off (Id : E) return B is
- begin
- return Flag96 (Id);
- end Warnings_Off;
-
- function Warnings_Off_Used (Id : E) return B is
- begin
- return Flag236 (Id);
- end Warnings_Off_Used;
-
- function Warnings_Off_Used_Unmodified (Id : E) return B is
- begin
- return Flag237 (Id);
- end Warnings_Off_Used_Unmodified;
-
- function Warnings_Off_Used_Unreferenced (Id : E) return B is
- begin
- 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 (Id) in E_Function | E_Procedure
- and then Is_Primitive_Wrapper (Id));
- return Node27 (Id);
- end Wrapped_Entity;
-
- ------------------------------
- -- 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;
- end Is_Access_Type;
-
- function Is_Access_Protected_Subprogram_Type (Id : E) return B is
- begin
- return Ekind (Id) in Access_Protected_Kind;
- end Is_Access_Protected_Subprogram_Type;
-
- function Is_Access_Subprogram_Type (Id : E) return B is
- begin
- return Ekind (Id) in Access_Subprogram_Kind;
- end Is_Access_Subprogram_Type;
-
- function Is_Aggregate_Type (Id : E) return B is
- begin
- return Ekind (Id) in Aggregate_Kind;
- end Is_Aggregate_Type;
-
- function Is_Anonymous_Access_Type (Id : E) return B is
- begin
- return Ekind (Id) in Anonymous_Access_Kind;
- end Is_Anonymous_Access_Type;
-
- function Is_Array_Type (Id : E) return B is
- begin
- return Ekind (Id) in Array_Kind;
- end Is_Array_Type;
-
- function Is_Assignable (Id : E) return B is
- begin
- return Ekind (Id) in Assignable_Kind;
- end Is_Assignable;
-
- function Is_Class_Wide_Type (Id : E) return B is
- begin
- return Ekind (Id) in Class_Wide_Kind;
- end Is_Class_Wide_Type;
-
- function Is_Composite_Type (Id : E) return B is
- begin
- return Ekind (Id) in Composite_Kind;
- end Is_Composite_Type;
-
- function Is_Concurrent_Body (Id : E) return B is
- begin
- return Ekind (Id) in Concurrent_Body_Kind;
- end Is_Concurrent_Body;
-
- function Is_Concurrent_Record_Type (Id : E) return B is
- begin
- return Flag20 (Id);
- end Is_Concurrent_Record_Type;
-
- function Is_Concurrent_Type (Id : E) return B is
- begin
- return Ekind (Id) in Concurrent_Kind;
- end Is_Concurrent_Type;
-
- function Is_Decimal_Fixed_Point_Type (Id : E) return B is
- begin
- return Ekind (Id) in Decimal_Fixed_Point_Kind;
- end Is_Decimal_Fixed_Point_Type;
-
- function Is_Digits_Type (Id : E) return B is
- begin
- return Ekind (Id) in Digits_Kind;
- end Is_Digits_Type;
-
- function Is_Discrete_Or_Fixed_Point_Type (Id : E) return B is
- begin
- return Ekind (Id) in Discrete_Or_Fixed_Point_Kind;
- end Is_Discrete_Or_Fixed_Point_Type;
-
- function Is_Discrete_Type (Id : E) return B is
- begin
- return Ekind (Id) in Discrete_Kind;
- end Is_Discrete_Type;
-
- function Is_Elementary_Type (Id : E) return B is
- begin
- return Ekind (Id) in Elementary_Kind;
- end Is_Elementary_Type;
-
- function Is_Entry (Id : E) return B is
- begin
- return Ekind (Id) in Entry_Kind;
- end Is_Entry;
-
- function Is_Enumeration_Type (Id : E) return B is
- begin
- return Ekind (Id) in Enumeration_Kind;
- end Is_Enumeration_Type;
-
- function Is_Fixed_Point_Type (Id : E) return B is
- begin
- return Ekind (Id) in Fixed_Point_Kind;
- end Is_Fixed_Point_Type;
-
- function Is_Floating_Point_Type (Id : E) return B is
- begin
- return Ekind (Id) in Float_Kind;
- end Is_Floating_Point_Type;
-
- function Is_Formal (Id : E) return B is
- begin
- return Ekind (Id) in Formal_Kind;
- end Is_Formal;
-
- function Is_Formal_Object (Id : E) return B is
- begin
- return Ekind (Id) in Formal_Object_Kind;
- end Is_Formal_Object;
-
- function Is_Generic_Subprogram (Id : E) return B is
- begin
- return Ekind (Id) in Generic_Subprogram_Kind;
- end Is_Generic_Subprogram;
-
- function Is_Generic_Unit (Id : E) return B is
- begin
- return Ekind (Id) in Generic_Unit_Kind;
- end Is_Generic_Unit;
-
- function Is_Ghost_Entity (Id : Entity_Id) return Boolean is
- begin
- return Is_Checked_Ghost_Entity (Id) or else Is_Ignored_Ghost_Entity (Id);
- end Is_Ghost_Entity;
-
- function Is_Incomplete_Or_Private_Type (Id : E) return B is
- begin
- return Ekind (Id) in Incomplete_Or_Private_Kind;
- end Is_Incomplete_Or_Private_Type;
-
- function Is_Incomplete_Type (Id : E) return B is
- begin
- return Ekind (Id) in Incomplete_Kind;
- end Is_Incomplete_Type;
-
- function Is_Integer_Type (Id : E) return B is
- begin
- return Ekind (Id) in Integer_Kind;
- end Is_Integer_Type;
-
- function Is_Modular_Integer_Type (Id : E) return B is
- begin
- 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;
- end Is_Named_Number;
-
- function Is_Numeric_Type (Id : E) return B is
- begin
- return Ekind (Id) in Numeric_Kind;
- end Is_Numeric_Type;
-
- function Is_Object (Id : E) return B is
- begin
- return Ekind (Id) in Object_Kind;
- end Is_Object;
-
- function Is_Ordinary_Fixed_Point_Type (Id : E) return B is
- begin
- return Ekind (Id) in Ordinary_Fixed_Point_Kind;
- end Is_Ordinary_Fixed_Point_Type;
-
- function Is_Overloadable (Id : E) return B is
- begin
- return Ekind (Id) in Overloadable_Kind;
- end Is_Overloadable;
-
- function Is_Private_Type (Id : E) return B is
- begin
- return Ekind (Id) in Private_Kind;
- end Is_Private_Type;
-
- function Is_Protected_Type (Id : E) return B is
- begin
- return Ekind (Id) in Protected_Kind;
- end Is_Protected_Type;
-
- function Is_Real_Type (Id : E) return B is
- begin
- return Ekind (Id) in Real_Kind;
- end Is_Real_Type;
-
- function Is_Record_Type (Id : E) return B is
- begin
- return Ekind (Id) in Record_Kind;
- end Is_Record_Type;
-
- function Is_Scalar_Type (Id : E) return B is
- begin
- return Ekind (Id) in Scalar_Kind;
- end Is_Scalar_Type;
-
- function Is_Signed_Integer_Type (Id : E) return B is
- begin
- return Ekind (Id) in Signed_Integer_Kind;
- end Is_Signed_Integer_Type;
-
- function Is_Subprogram (Id : E) return B is
- begin
- return Ekind (Id) in Subprogram_Kind;
- end Is_Subprogram;
-
- function Is_Subprogram_Or_Entry (Id : E) return B is
- begin
- return Ekind (Id) in Subprogram_Kind
- or else
- Ekind (Id) in Entry_Kind;
- end Is_Subprogram_Or_Entry;
-
- function Is_Subprogram_Or_Generic_Subprogram (Id : E) return B is
- begin
- return Ekind (Id) in Subprogram_Kind
- or else
- Ekind (Id) in Generic_Subprogram_Kind;
- end Is_Subprogram_Or_Generic_Subprogram;
-
- function Is_Task_Type (Id : E) return B is
- begin
- return Ekind (Id) in Task_Kind;
- end Is_Task_Type;
-
- function Is_Type (Id : E) return B is
- begin
- return Ekind (Id) in Type_Kind;
- end Is_Type;
-
- ------------------------------
- -- Attribute Set Procedures --
- ------------------------------
-
- -- Note: in many of these set procedures an "obvious" assertion is missing.
- -- The reason for this is that in many cases, a field is set before the
- -- Ekind field is set, so that the field is set when Ekind = E_Void. It
- -- it is possible to add assertions that specifically include the E_Void
- -- possibility, but in some cases, we just omit the assertions.
-
- procedure Set_Abstract_States (Id : E; V : L) is
- begin
- pragma Assert (Is_Package_Or_Generic_Package (Id));
- Set_Elist25 (Id, V);
- end Set_Abstract_States;
-
- procedure Set_Accept_Address (Id : E; V : L) is
- begin
- Set_Elist21 (Id, V);
- end Set_Accept_Address;
-
- procedure Set_Access_Disp_Table (Id : E; V : L) is
- begin
- pragma Assert (Ekind (Id) = E_Record_Type
- and then Id = Implementation_Base_Type (Id));
- pragma Assert (V = No_Elist or else Is_Tagged_Type (Id));
- Set_Elist16 (Id, V);
- end Set_Access_Disp_Table;
-
- procedure Set_Access_Disp_Table_Elab_Flag (Id : E; V : E) is
- begin
- pragma Assert (Ekind (Id) = E_Record_Type
- and then Id = Implementation_Base_Type (Id));
- pragma Assert (Is_Tagged_Type (Id));
- 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);
- Set_Node35 (Id, V);
- end Set_Anonymous_Designated_Type;
-
- procedure Set_Anonymous_Masters (Id : E; V : L) is
- begin
- 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 (Id) in E_Protected_Type | E_Task_Type);
- Set_Node30 (Id, V);
- end Set_Anonymous_Object;
-
- procedure Set_Associated_Entity (Id : E; V : E) is
- begin
- Set_Node37 (Id, V);
- end Set_Associated_Entity;
-
- procedure Set_Associated_Formal_Package (Id : E; V : E) is
- begin
- Set_Node12 (Id, V);
- end Set_Associated_Formal_Package;
-
- procedure Set_Associated_Node_For_Itype (Id : E; V : E) is
- begin
- Set_Node8 (Id, V);
- end Set_Associated_Node_For_Itype;
-
- procedure Set_Associated_Storage_Pool (Id : E; V : E) is
- begin
- pragma Assert (Is_Access_Type (Id) and then Is_Base_Type (Id));
- Set_Node22 (Id, V);
- end Set_Associated_Storage_Pool;
-
- procedure Set_Activation_Record_Component (Id : E; V : E) is
- begin
- 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 (Id) in E_Constant | E_Variable | E_Generic_In_Out_Parameter
- or else Is_Formal (Id));
- Set_Node17 (Id, V);
- end Set_Actual_Subtype;
-
- procedure Set_Address_Taken (Id : E; V : B := True) is
- begin
- Set_Flag104 (Id, V);
- end Set_Address_Taken;
-
- procedure Set_Alias (Id : E; V : E) is
- begin
- pragma Assert
- (Is_Overloadable (Id) or else Ekind (Id) = E_Subprogram_Type);
- Set_Node18 (Id, V);
- end Set_Alias;
-
- procedure Set_Alignment (Id : E; V : U) is
- begin
- pragma Assert (Is_Type (Id)
- or else Is_Formal (Id)
- or else Ekind (Id) in E_Loop_Parameter
- | E_Constant
- | E_Exception
- | E_Variable);
- Set_Uint14 (Id, V);
- end Set_Alignment;
-
- procedure Set_Barrier_Function (Id : E; V : N) is
- begin
- pragma Assert (Is_Entry (Id));
- Set_Node12 (Id, V);
- end Set_Barrier_Function;
-
- procedure Set_Block_Node (Id : E; V : N) is
- begin
- pragma Assert (Ekind (Id) = E_Block);
- Set_Node11 (Id, V);
- end Set_Block_Node;
-
- procedure Set_Body_Entity (Id : E; V : E) is
- begin
- pragma Assert (Is_Package_Or_Generic_Package (Id));
- Set_Node19 (Id, V);
- end Set_Body_Entity;
-
- procedure Set_Body_Needed_For_Inlining (Id : E; V : B := True) is
- begin
- pragma Assert (Ekind (Id) = E_Package);
- Set_Flag299 (Id, V);
- end Set_Body_Needed_For_Inlining;
-
- procedure Set_Body_Needed_For_SAL (Id : E; V : B := True) is
- begin
- pragma Assert
- (Ekind (Id) = E_Package
- or else Is_Subprogram (Id)
- or else Is_Generic_Unit (Id));
- Set_Flag40 (Id, V);
- end Set_Body_Needed_For_SAL;
-
- procedure Set_Body_References (Id : E; V : L) is
- begin
- pragma Assert (Ekind (Id) = E_Abstract_State);
- Set_Elist16 (Id, V);
- end Set_Body_References;
-
- procedure Set_BIP_Initialization_Call (Id : E; V : N) is
- begin
- pragma Assert (Ekind (Id) in E_Constant | E_Variable);
- Set_Node29 (Id, V);
- end Set_BIP_Initialization_Call;
-
- procedure Set_C_Pass_By_Copy (Id : E; V : B := True) is
- begin
- pragma Assert (Is_Record_Type (Id) and then Is_Base_Type (Id));
- Set_Flag125 (Id, V);
- end Set_C_Pass_By_Copy;
-
- procedure Set_Can_Never_Be_Null (Id : E; V : B := True) is
- begin
- Set_Flag38 (Id, V);
- end Set_Can_Never_Be_Null;
-
- procedure Set_Can_Use_Internal_Rep (Id : E; V : B := True) is
- begin
- pragma Assert
- (Is_Access_Subprogram_Type (Id) and then Is_Base_Type (Id));
- Set_Flag229 (Id, V);
- end Set_Can_Use_Internal_Rep;
-
- procedure Set_Checks_May_Be_Suppressed (Id : E; V : B := True) is
- begin
- Set_Flag31 (Id, V);
- end Set_Checks_May_Be_Suppressed;
-
- procedure Set_Class_Wide_Clone (Id : E; V : E) is
- begin
- pragma Assert (Is_Subprogram (Id));
- Set_Node38 (Id, V);
- end Set_Class_Wide_Clone;
-
- procedure Set_Class_Wide_Type (Id : E; V : E) is
- begin
- pragma Assert (Is_Type (Id));
- Set_Node9 (Id, V);
- end Set_Class_Wide_Type;
-
- procedure Set_Cloned_Subtype (Id : E; V : E) is
- begin
- 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 (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 (Id) in E_Component | E_Discriminant);
- Set_Node13 (Id, V);
- end Set_Component_Clause;
-
- procedure Set_Component_Size (Id : E; V : U) is
- begin
- pragma Assert (Is_Array_Type (Id) and then Is_Base_Type (Id));
- Set_Uint22 (Id, V);
- end Set_Component_Size;
-
- procedure Set_Component_Type (Id : E; V : E) is
- begin
- pragma Assert (Is_Array_Type (Id) and then Is_Base_Type (Id));
- Set_Node20 (Id, V);
- end Set_Component_Type;
-
- procedure Set_Contains_Ignored_Ghost_Code (Id : E; V : B := True) is
- begin
- pragma Assert
- (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 (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 (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 (Id) in E_Generic_Package -- packages
- | E_Package
- | E_Package_Body
-
- or else
- 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 (Is_Entry (Id));
- Set_Node25 (Id, V);
- end Set_Contract_Wrapper;
-
- procedure Set_Corresponding_Concurrent_Type (Id : E; V : E) is
- begin
- pragma Assert
- (Ekind (Id) = E_Record_Type and then Is_Concurrent_Type (V));
- Set_Node18 (Id, V);
- end Set_Corresponding_Concurrent_Type;
-
- procedure Set_Corresponding_Discriminant (Id : E; V : E) is
- begin
- pragma Assert (Ekind (Id) = E_Discriminant);
- Set_Node19 (Id, V);
- end Set_Corresponding_Discriminant;
-
- procedure Set_Corresponding_Equality (Id : E; V : E) is
- begin
- pragma Assert
- (Ekind (Id) = E_Function
- and then not Comes_From_Source (Id)
- and then Chars (Id) = Name_Op_Ne);
- Set_Node30 (Id, V);
- end Set_Corresponding_Equality;
-
- procedure Set_Corresponding_Function (Id : E; V : E) is
- begin
- pragma Assert (Ekind (Id) = E_Procedure and then Rewritten_For_C (V));
- Set_Node32 (Id, V);
- end Set_Corresponding_Function;
-
- procedure Set_Corresponding_Procedure (Id : E; V : E) is
- begin
- pragma Assert (Ekind (Id) = E_Function and then Rewritten_For_C (Id));
- Set_Node32 (Id, V);
- end Set_Corresponding_Procedure;
-
- procedure Set_Corresponding_Protected_Entry (Id : E; V : E) is
- begin
- 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 (Id) in E_Component | E_Discriminant);
- Set_Node21 (Id, V);
- end Set_Corresponding_Record_Component;
-
- procedure Set_Corresponding_Record_Type (Id : E; V : E) is
- begin
- pragma Assert (Is_Concurrent_Type (Id));
- Set_Node18 (Id, V);
- end Set_Corresponding_Record_Type;
-
- procedure Set_Corresponding_Remote_Type (Id : E; V : E) is
- begin
- Set_Node22 (Id, V);
- end Set_Corresponding_Remote_Type;
-
- procedure Set_Current_Use_Clause (Id : E; V : E) is
- begin
- pragma Assert (Ekind (Id) = E_Package or else Is_Type (Id));
- Set_Node27 (Id, V);
- end Set_Current_Use_Clause;
-
- procedure Set_Current_Value (Id : E; V : N) is
- begin
- pragma Assert (Ekind (Id) in Object_Kind or else Ekind (Id) = E_Void);
- Set_Node9 (Id, V);
- end Set_Current_Value;
-
- procedure Set_CR_Discriminant (Id : E; V : E) is
- begin
- Set_Node23 (Id, V);
- end Set_CR_Discriminant;
-
- procedure Set_Debug_Info_Off (Id : E; V : B := True) is
- begin
- Set_Flag166 (Id, V);
- end Set_Debug_Info_Off;
-
- procedure Set_Debug_Renaming_Link (Id : E; V : E) is
- begin
- Set_Node25 (Id, V);
- end Set_Debug_Renaming_Link;
-
- procedure Set_Default_Aspect_Component_Value (Id : E; V : E) is
- begin
- pragma Assert (Is_Array_Type (Id) and then Is_Base_Type (Id));
- Set_Node19 (Id, V);
- end Set_Default_Aspect_Component_Value;
-
- procedure Set_Default_Aspect_Value (Id : E; V : E) is
- begin
- pragma Assert (Is_Scalar_Type (Id) and then Is_Base_Type (Id));
- Set_Node19 (Id, V);
- end Set_Default_Aspect_Value;
-
- procedure Set_Default_Expr_Function (Id : E; V : E) is
- begin
- pragma Assert (Is_Formal (Id));
- Set_Node21 (Id, V);
- end Set_Default_Expr_Function;
-
- procedure Set_Default_Expressions_Processed (Id : E; V : B := True) is
- begin
- Set_Flag108 (Id, V);
- end Set_Default_Expressions_Processed;
-
- procedure Set_Default_Value (Id : E; V : N) is
- begin
- pragma Assert (Is_Formal (Id));
- Set_Node20 (Id, V);
- end Set_Default_Value;
-
- procedure Set_Delay_Cleanups (Id : E; V : B := True) is
- begin
- pragma Assert
- (Is_Subprogram (Id)
- or else Is_Task_Type (Id)
- or else Ekind (Id) = E_Block);
- Set_Flag114 (Id, V);
- end Set_Delay_Cleanups;
-
- procedure Set_Delay_Subprogram_Descriptors (Id : E; V : B := True) is
- begin
- pragma Assert
- (Is_Subprogram (Id) or else Ekind (Id) in E_Package | E_Package_Body);
-
- Set_Flag50 (Id, V);
- end Set_Delay_Subprogram_Descriptors;
-
- procedure Set_Delta_Value (Id : E; V : R) is
- begin
- pragma Assert (Is_Fixed_Point_Type (Id));
- Set_Ureal18 (Id, V);
- end Set_Delta_Value;
-
- procedure Set_Dependent_Instances (Id : E; V : L) is
- begin
- pragma Assert (Is_Generic_Instance (Id));
- Set_Elist8 (Id, V);
- end Set_Dependent_Instances;
-
- procedure Set_Depends_On_Private (Id : E; V : B := True) is
- begin
- pragma Assert (Nkind (Id) in N_Entity);
- Set_Flag14 (Id, V);
- end Set_Depends_On_Private;
-
- procedure Set_Derived_Type_Link (Id : E; V : E) is
- begin
- pragma Assert (Is_Type (Id) and then Is_Base_Type (Id));
- Set_Node31 (Id, V);
- end Set_Derived_Type_Link;
-
- procedure Set_Digits_Value (Id : E; V : U) is
- begin
- pragma Assert
- (Is_Floating_Point_Type (Id)
- or else Is_Decimal_Fixed_Point_Type (Id));
- Set_Uint17 (Id, V);
- end Set_Digits_Value;
-
- procedure Set_Directly_Designated_Type (Id : E; V : E) is
- begin
- Set_Node20 (Id, V);
- end Set_Directly_Designated_Type;
-
- procedure Set_Disable_Controlled (Id : E; V : B := True) is
- begin
- pragma Assert (Is_Type (Id) and then Is_Base_Type (Id));
- Set_Flag253 (Id, V);
- end Set_Disable_Controlled;
-
- procedure Set_Discard_Names (Id : E; V : B := True) is
- begin
- Set_Flag88 (Id, V);
- end Set_Discard_Names;
-
- procedure Set_Discriminal (Id : E; V : E) is
- begin
- pragma Assert (Ekind (Id) = E_Discriminant);
- Set_Node17 (Id, V);
- end Set_Discriminal;
-
- procedure Set_Discriminal_Link (Id : E; V : E) is
- begin
- Set_Node10 (Id, V);
- end Set_Discriminal_Link;
-
- procedure Set_Discriminant_Checking_Func (Id : E; V : E) is
- begin
- pragma Assert (Ekind (Id) = E_Component);
- Set_Node20 (Id, V);
- end Set_Discriminant_Checking_Func;
-
- procedure Set_Discriminant_Constraint (Id : E; V : L) is
- begin
- pragma Assert (Nkind (Id) in N_Entity);
- Set_Elist21 (Id, V);
- end Set_Discriminant_Constraint;
-
- procedure Set_Discriminant_Default_Value (Id : E; V : N) is
- begin
- Set_Node20 (Id, V);
- end Set_Discriminant_Default_Value;
-
- procedure Set_Discriminant_Number (Id : E; V : U) is
- begin
- Set_Uint15 (Id, V);
- end Set_Discriminant_Number;
-
- procedure Set_Dispatch_Table_Wrappers (Id : E; V : L) is
- begin
- pragma Assert (Ekind (Id) = E_Record_Type
- and then Id = Implementation_Base_Type (Id));
- pragma Assert (V = No_Elist or else Is_Tagged_Type (Id));
- Set_Elist26 (Id, V);
- end Set_Dispatch_Table_Wrappers;
-
- procedure Set_DT_Entry_Count (Id : E; V : U) is
- begin
- pragma Assert (Ekind (Id) = E_Component);
- Set_Uint15 (Id, V);
- end Set_DT_Entry_Count;
-
- procedure Set_DT_Offset_To_Top_Func (Id : E; V : E) is
- begin
- pragma Assert (Ekind (Id) = E_Component and then Is_Tag (Id));
- Set_Node25 (Id, V);
- end Set_DT_Offset_To_Top_Func;
-
- procedure Set_DT_Position (Id : E; V : U) is
- begin
- 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 (Id) in E_Function | E_Procedure);
- Set_Node16 (Id, V);
- end Set_DTC_Entity;
-
- procedure Set_Elaborate_Body_Desirable (Id : E; V : B := True) is
- begin
- pragma Assert (Ekind (Id) = E_Package);
- Set_Flag210 (Id, V);
- end Set_Elaborate_Body_Desirable;
-
- procedure Set_Elaboration_Entity (Id : E; V : E) is
- begin
- pragma Assert
- (Is_Subprogram (Id)
- or else
- Ekind (Id) in E_Entry | E_Entry_Family | E_Package
- or else
- Is_Generic_Unit (Id));
- Set_Node13 (Id, V);
- end Set_Elaboration_Entity;
-
- procedure Set_Elaboration_Entity_Required (Id : E; V : B := True) is
- begin
- pragma Assert
- (Is_Subprogram (Id)
- or else
- Ekind (Id) in E_Entry | E_Entry_Family | E_Package
- or else
- Is_Generic_Unit (Id));
- Set_Flag174 (Id, V);
- end Set_Elaboration_Entity_Required;
-
- procedure Set_Encapsulating_State (Id : E; V : E) is
- begin
- pragma Assert (Ekind (Id) in E_Abstract_State | E_Constant | E_Variable);
- Set_Node32 (Id, V);
- end Set_Encapsulating_State;
-
- procedure Set_Enclosing_Scope (Id : E; V : E) is
- begin
- Set_Node18 (Id, V);
- end Set_Enclosing_Scope;
-
- procedure Set_Entry_Accepted (Id : E; V : B := True) is
- begin
- pragma Assert (Is_Entry (Id));
- Set_Flag152 (Id, V);
- end Set_Entry_Accepted;
-
- procedure Set_Entry_Bodies_Array (Id : E; V : E) is
- begin
- Set_Node19 (Id, V);
- end Set_Entry_Bodies_Array;
-
- procedure Set_Entry_Cancel_Parameter (Id : E; V : E) is
- begin
- Set_Node23 (Id, V);
- end Set_Entry_Cancel_Parameter;
-
- procedure Set_Entry_Component (Id : E; V : E) is
- begin
- Set_Node11 (Id, V);
- end Set_Entry_Component;
-
- procedure Set_Entry_Formal (Id : E; V : E) is
- begin
- Set_Node16 (Id, V);
- end Set_Entry_Formal;
-
- procedure Set_Entry_Index_Constant (Id : E; V : E) is
- begin
- pragma Assert (Ekind (Id) = E_Entry_Index_Parameter);
- Set_Node18 (Id, V);
- end Set_Entry_Index_Constant;
-
- procedure Set_Entry_Max_Queue_Lengths_Array (Id : E; V : E) is
- begin
- pragma Assert (Ekind (Id) = E_Protected_Type);
- Set_Node35 (Id, V);
- end Set_Entry_Max_Queue_Lengths_Array;
-
- procedure Set_Entry_Parameters_Type (Id : E; V : E) is
- begin
- Set_Node15 (Id, V);
- end Set_Entry_Parameters_Type;
-
- procedure Set_Enum_Pos_To_Rep (Id : E; V : E) is
- begin
- pragma Assert (Ekind (Id) = E_Enumeration_Type);
- Set_Node23 (Id, V);
- end Set_Enum_Pos_To_Rep;
-
- procedure Set_Enumeration_Pos (Id : E; V : U) is
- begin
- pragma Assert (Ekind (Id) = E_Enumeration_Literal);
- Set_Uint11 (Id, V);
- end Set_Enumeration_Pos;
-
- procedure Set_Enumeration_Rep (Id : E; V : U) is
- begin
- pragma Assert (Ekind (Id) = E_Enumeration_Literal);
- Set_Uint12 (Id, V);
- end Set_Enumeration_Rep;
-
- procedure Set_Enumeration_Rep_Expr (Id : E; V : N) is
- begin
- pragma Assert (Ekind (Id) = E_Enumeration_Literal);
- Set_Node22 (Id, V);
- end Set_Enumeration_Rep_Expr;
-
- procedure Set_Equivalent_Type (Id : E; V : E) is
- begin
- pragma Assert
- (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;
-
- procedure Set_Esize (Id : E; V : U) is
- begin
- Set_Uint12 (Id, V);
- end Set_Esize;
-
- procedure Set_Extra_Accessibility (Id : E; V : E) is
- begin
- pragma Assert
- (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 (Id) in E_Function | E_Operator | E_Subprogram_Type);
- Set_Node19 (Id, V);
- end Set_Extra_Accessibility_Of_Result;
-
- procedure Set_Extra_Constrained (Id : E; V : E) is
- begin
- pragma Assert (Is_Formal (Id) or else Ekind (Id) = E_Variable);
- Set_Node23 (Id, V);
- end Set_Extra_Constrained;
-
- procedure Set_Extra_Formal (Id : E; V : E) is
- begin
- Set_Node15 (Id, V);
- end Set_Extra_Formal;
-
- procedure Set_Extra_Formals (Id : E; V : E) is
- begin
- pragma Assert
- (Is_Overloadable (Id)
- or else Ekind (Id) in E_Entry_Family
- | E_Subprogram_Body
- | E_Subprogram_Type);
- Set_Node28 (Id, V);
- end Set_Extra_Formals;
-
- procedure Set_Finalization_Master (Id : E; V : E) is
- begin
- pragma Assert (Is_Access_Type (Id) and then Is_Base_Type (Id));
- Set_Node23 (Id, V);
- end Set_Finalization_Master;
-
- procedure Set_Finalize_Storage_Only (Id : E; V : B := True) is
- begin
- pragma Assert (Is_Type (Id) and then Is_Base_Type (Id));
- Set_Flag158 (Id, V);
- end Set_Finalize_Storage_Only;
-
- procedure Set_Finalizer (Id : E; V : E) is
- begin
- pragma Assert (Ekind (Id) in E_Package | E_Package_Body);
- Set_Node28 (Id, V);
- end Set_Finalizer;
-
- procedure Set_First_Entity (Id : E; V : E) is
- begin
- Set_Node17 (Id, V);
- end Set_First_Entity;
-
- procedure Set_First_Exit_Statement (Id : E; V : N) is
- begin
- pragma Assert (Ekind (Id) = E_Loop);
- Set_Node8 (Id, V);
- end Set_First_Exit_Statement;
-
- procedure Set_First_Index (Id : E; V : N) is
- begin
- pragma Assert (Is_Array_Type (Id));
- Set_Node17 (Id, V);
- end Set_First_Index;
-
- procedure Set_First_Literal (Id : E; V : E) is
- begin
- pragma Assert (Is_Enumeration_Type (Id));
- Set_Node17 (Id, V);
- end Set_First_Literal;
-
- procedure Set_First_Private_Entity (Id : E; V : E) is
- begin
- pragma Assert (Is_Package_Or_Generic_Package (Id)
- or else Is_Concurrent_Type (Id));
- Set_Node16 (Id, V);
- end Set_First_Private_Entity;
-
- procedure Set_First_Rep_Item (Id : E; V : N) is
- begin
- Set_Node6 (Id, V);
- end Set_First_Rep_Item;
-
- procedure Set_Float_Rep (Id : E; V : F) is
- pragma Assert (Ekind (Id) = E_Floating_Point_Type);
- begin
- Set_Uint10 (Id, UI_From_Int (F'Pos (V)));
- end Set_Float_Rep;
-
- procedure Set_Freeze_Node (Id : E; V : N) is
- begin
- Set_Node7 (Id, V);
- end Set_Freeze_Node;
-
- procedure Set_From_Limited_With (Id : E; V : B := True) is
- begin
- pragma Assert
- (Is_Type (Id) or else Ekind (Id) in E_Abstract_State | E_Package);
- Set_Flag159 (Id, V);
- end Set_From_Limited_With;
-
- procedure Set_Full_View (Id : E; V : E) is
- begin
- pragma Assert (Is_Type (Id) or else Ekind (Id) = E_Constant);
- Set_Node11 (Id, V);
- end Set_Full_View;
-
- procedure Set_Generic_Homonym (Id : E; V : E) is
- begin
- Set_Node11 (Id, V);
- end Set_Generic_Homonym;
-
- procedure Set_Generic_Renamings (Id : E; V : L) is
- begin
- Set_Elist23 (Id, V);
- end Set_Generic_Renamings;
-
- procedure Set_Handler_Records (Id : E; V : S) is
- begin
- Set_List10 (Id, V);
- end Set_Handler_Records;
-
- procedure Set_Has_Aliased_Components (Id : E; V : B := True) is
- begin
- pragma Assert (Id = Base_Type (Id));
- Set_Flag135 (Id, V);
- end Set_Has_Aliased_Components;
-
- procedure Set_Has_Alignment_Clause (Id : E; V : B := True) is
- begin
- Set_Flag46 (Id, V);
- end Set_Has_Alignment_Clause;
-
- procedure Set_Has_All_Calls_Remote (Id : E; V : B := True) is
- begin
- Set_Flag79 (Id, V);
- end Set_Has_All_Calls_Remote;
-
- procedure Set_Has_Atomic_Components (Id : E; V : B := True) is
- begin
- pragma Assert (not Is_Type (Id) or else Is_Base_Type (Id));
- Set_Flag86 (Id, V);
- end Set_Has_Atomic_Components;
-
- procedure Set_Has_Biased_Representation (Id : E; V : B := True) is
- begin
- pragma Assert
- ((V = False) or else (Is_Discrete_Type (Id) or else Is_Object (Id)));
- Set_Flag139 (Id, V);
- end Set_Has_Biased_Representation;
-
- procedure Set_Has_Completion (Id : E; V : B := True) is
- begin
- Set_Flag26 (Id, V);
- end Set_Has_Completion;
-
- procedure Set_Has_Completion_In_Body (Id : E; V : B := True) is
- begin
- pragma Assert (Is_Type (Id));
- Set_Flag71 (Id, V);
- end Set_Has_Completion_In_Body;
-
- procedure Set_Has_Complex_Representation (Id : E; V : B := True) is
- begin
- pragma Assert (Is_Record_Type (Id) and then Is_Base_Type (Id));
- Set_Flag140 (Id, V);
- end Set_Has_Complex_Representation;
-
- procedure Set_Has_Component_Size_Clause (Id : E; V : B := True) is
- begin
- pragma Assert (Ekind (Id) = E_Array_Type);
- Set_Flag68 (Id, V);
- end Set_Has_Component_Size_Clause;
-
- procedure Set_Has_Constrained_Partial_View (Id : E; V : B := True) is
- begin
- pragma Assert (Is_Type (Id));
- Set_Flag187 (Id, V);
- end Set_Has_Constrained_Partial_View;
-
- procedure Set_Has_Contiguous_Rep (Id : E; V : B := True) is
- begin
- Set_Flag181 (Id, V);
- end Set_Has_Contiguous_Rep;
-
- procedure Set_Has_Controlled_Component (Id : E; V : B := True) is
- begin
- pragma Assert (Id = Base_Type (Id));
- Set_Flag43 (Id, V);
- end Set_Has_Controlled_Component;
-
- procedure Set_Has_Controlling_Result (Id : E; V : B := True) is
- begin
- Set_Flag98 (Id, V);
- end Set_Has_Controlling_Result;
-
- procedure Set_Has_Convention_Pragma (Id : E; V : B := True) is
- begin
- Set_Flag119 (Id, V);
- end Set_Has_Convention_Pragma;
-
- procedure Set_Has_Default_Aspect (Id : E; V : B := True) is
- begin
- pragma Assert
- ((Is_Scalar_Type (Id) or else Is_Array_Type (Id))
- and then Is_Base_Type (Id));
- Set_Flag39 (Id, V);
- end Set_Has_Default_Aspect;
-
- procedure Set_Has_Delayed_Aspects (Id : E; V : B := True) is
- begin
- pragma Assert (Nkind (Id) in N_Entity);
- Set_Flag200 (Id, V);
- end Set_Has_Delayed_Aspects;
-
- procedure Set_Has_Delayed_Freeze (Id : E; V : B := True) is
- begin
- pragma Assert (Nkind (Id) in N_Entity);
- Set_Flag18 (Id, V);
- end Set_Has_Delayed_Freeze;
-
- procedure Set_Has_Delayed_Rep_Aspects (Id : E; V : B := True) is
- begin
- pragma Assert (Nkind (Id) in N_Entity);
- Set_Flag261 (Id, V);
- end Set_Has_Delayed_Rep_Aspects;
-
- procedure Set_Has_Discriminants (Id : E; V : B := True) is
- begin
- pragma Assert (Is_Type (Id));
- Set_Flag5 (Id, V);
- end Set_Has_Discriminants;
-
- procedure Set_Has_Dispatch_Table (Id : E; V : B := True) is
- begin
- pragma Assert (Ekind (Id) = E_Record_Type
- and then Is_Tagged_Type (Id));
- Set_Flag220 (Id, V);
- end Set_Has_Dispatch_Table;
-
- procedure Set_Has_Dynamic_Predicate_Aspect (Id : E; V : B := True) is
- begin
- pragma Assert (Is_Type (Id));
- Set_Flag258 (Id, V);
- end Set_Has_Dynamic_Predicate_Aspect;
-
- procedure Set_Has_Enumeration_Rep_Clause (Id : E; V : B := True) is
- begin
- pragma Assert (Is_Enumeration_Type (Id));
- Set_Flag66 (Id, V);
- end Set_Has_Enumeration_Rep_Clause;
-
- procedure Set_Has_Exit (Id : E; V : B := True) is
- begin
- Set_Flag47 (Id, V);
- end Set_Has_Exit;
-
- procedure Set_Has_Expanded_Contract (Id : E; V : B := True) is
- begin
- pragma Assert
- (Ekind (Id) in E_Entry | E_Entry_Family | E_Function | E_Procedure);
- Set_Flag240 (Id, V);
- end Set_Has_Expanded_Contract;
-
- procedure Set_Has_Forward_Instantiation (Id : E; V : B := True) is
- begin
- Set_Flag175 (Id, V);
- end Set_Has_Forward_Instantiation;
-
- procedure Set_Has_Fully_Qualified_Name (Id : E; V : B := True) is
- begin
- Set_Flag173 (Id, V);
- end Set_Has_Fully_Qualified_Name;
-
- procedure Set_Has_Gigi_Rep_Item (Id : E; V : B := True) is
- begin
- Set_Flag82 (Id, V);
- end Set_Has_Gigi_Rep_Item;
-
- procedure Set_Has_Homonym (Id : E; V : B := True) is
- begin
- Set_Flag56 (Id, V);
- end Set_Has_Homonym;
-
- procedure Set_Has_Implicit_Dereference (Id : E; V : B := True) is
- begin
- Set_Flag251 (Id, V);
- end Set_Has_Implicit_Dereference;
-
- procedure Set_Has_Independent_Components (Id : E; V : B := True) is
- begin
- pragma Assert (not Is_Type (Id) or else Is_Base_Type (Id));
- Set_Flag34 (Id, V);
- end Set_Has_Independent_Components;
-
- procedure Set_Has_Inheritable_Invariants (Id : E; V : B := True) is
- begin
- pragma Assert (Is_Type (Id));
- Set_Flag248 (Base_Type (Id), V);
- end Set_Has_Inheritable_Invariants;
-
- procedure Set_Has_Inherited_DIC (Id : E; V : B := True) is
- begin
- pragma Assert (Is_Type (Id));
- Set_Flag133 (Base_Type (Id), V);
- end Set_Has_Inherited_DIC;
-
- procedure Set_Has_Inherited_Invariants (Id : E; V : B := True) is
- begin
- pragma Assert (Is_Type (Id));
- Set_Flag291 (Base_Type (Id), V);
- end Set_Has_Inherited_Invariants;
-
- procedure Set_Has_Initial_Value (Id : E; V : B := True) is
- begin
- pragma Assert (Ekind (Id) in E_Variable | E_Out_Parameter);
- Set_Flag219 (Id, V);
- end Set_Has_Initial_Value;
-
- procedure Set_Has_Loop_Entry_Attributes (Id : E; V : B := True) is
- begin
- pragma Assert (Ekind (Id) = E_Loop);
- Set_Flag260 (Id, V);
- end Set_Has_Loop_Entry_Attributes;
-
- procedure Set_Has_Machine_Radix_Clause (Id : E; V : B := True) is
- begin
- pragma Assert (Is_Decimal_Fixed_Point_Type (Id));
- Set_Flag83 (Id, V);
- end Set_Has_Machine_Radix_Clause;
-
- procedure Set_Has_Master_Entity (Id : E; V : B := True) is
- begin
- Set_Flag21 (Id, V);
- end Set_Has_Master_Entity;
-
- procedure Set_Has_Missing_Return (Id : E; V : B := True) is
- begin
- pragma Assert (Ekind (Id) in E_Function | E_Generic_Function);
- Set_Flag142 (Id, V);
- end Set_Has_Missing_Return;
-
- procedure Set_Has_Nested_Block_With_Handler (Id : E; V : B := True) is
- begin
- Set_Flag101 (Id, V);
- end Set_Has_Nested_Block_With_Handler;
-
- procedure Set_Has_Nested_Subprogram (Id : E; V : B := True) is
- begin
- pragma Assert (Is_Subprogram (Id));
- Set_Flag282 (Id, V);
- end Set_Has_Nested_Subprogram;
-
- procedure Set_Has_Non_Standard_Rep (Id : E; V : B := True) is
- begin
- pragma Assert (Id = Base_Type (Id));
- Set_Flag75 (Id, V);
- end Set_Has_Non_Standard_Rep;
-
- procedure Set_Has_Object_Size_Clause (Id : E; V : B := True) is
- begin
- pragma Assert (Is_Type (Id));
- Set_Flag172 (Id, V);
- end Set_Has_Object_Size_Clause;
-
- procedure Set_Has_Out_Or_In_Out_Parameter (Id : E; V : B := True) is
- begin
- pragma Assert
- (Is_Entry (Id)
- or else Is_Subprogram_Or_Generic_Subprogram (Id));
- Set_Flag110 (Id, V);
- end Set_Has_Out_Or_In_Out_Parameter;
-
- procedure Set_Has_Own_DIC (Id : E; V : B := True) is
- begin
- pragma Assert (Is_Type (Id));
- Set_Flag3 (Base_Type (Id), V);
- end Set_Has_Own_DIC;
-
- procedure Set_Has_Own_Invariants (Id : E; V : B := True) is
- begin
- pragma Assert (Is_Type (Id));
- Set_Flag232 (Base_Type (Id), V);
- end Set_Has_Own_Invariants;
-
- procedure Set_Has_Partial_Visible_Refinement (Id : E; V : B := True) is
- begin
- pragma Assert (Ekind (Id) = E_Abstract_State);
- Set_Flag296 (Id, V);
- end Set_Has_Partial_Visible_Refinement;
-
- procedure Set_Has_Per_Object_Constraint (Id : E; V : B := True) is
- begin
- Set_Flag154 (Id, V);
- end Set_Has_Per_Object_Constraint;
-
- procedure Set_Has_Pragma_Controlled (Id : E; V : B := True) is
- begin
- pragma Assert (Is_Access_Type (Id));
- Set_Flag27 (Base_Type (Id), V);
- end Set_Has_Pragma_Controlled;
-
- procedure Set_Has_Pragma_Elaborate_Body (Id : E; V : B := True) is
- begin
- Set_Flag150 (Id, V);
- end Set_Has_Pragma_Elaborate_Body;
-
- procedure Set_Has_Pragma_Inline (Id : E; V : B := True) is
- begin
- Set_Flag157 (Id, V);
- end Set_Has_Pragma_Inline;
-
- procedure Set_Has_Pragma_Inline_Always (Id : E; V : B := True) is
- begin
- Set_Flag230 (Id, V);
- end Set_Has_Pragma_Inline_Always;
-
- procedure Set_Has_Pragma_No_Inline (Id : E; V : B := True) is
- begin
- Set_Flag201 (Id, V);
- end Set_Has_Pragma_No_Inline;
-
- procedure Set_Has_Pragma_Ordered (Id : E; V : B := True) is
- begin
- pragma Assert (Is_Enumeration_Type (Id));
- pragma Assert (Id = Base_Type (Id));
- Set_Flag198 (Id, V);
- end Set_Has_Pragma_Ordered;
-
- procedure Set_Has_Pragma_Pack (Id : E; V : B := True) is
- begin
- pragma Assert (Is_Array_Type (Id) or else Is_Record_Type (Id));
- pragma Assert (Id = Base_Type (Id));
- Set_Flag121 (Id, V);
- end Set_Has_Pragma_Pack;
-
- procedure Set_Has_Pragma_Preelab_Init (Id : E; V : B := True) is
- begin
- Set_Flag221 (Id, V);
- end Set_Has_Pragma_Preelab_Init;
-
- procedure Set_Has_Pragma_Pure (Id : E; V : B := True) is
- begin
- Set_Flag203 (Id, V);
- end Set_Has_Pragma_Pure;
-
- procedure Set_Has_Pragma_Pure_Function (Id : E; V : B := True) is
- begin
- Set_Flag179 (Id, V);
- end Set_Has_Pragma_Pure_Function;
-
- procedure Set_Has_Pragma_Thread_Local_Storage (Id : E; V : B := True) is
- begin
- Set_Flag169 (Id, V);
- end Set_Has_Pragma_Thread_Local_Storage;
-
- procedure Set_Has_Pragma_Unmodified (Id : E; V : B := True) is
- begin
- Set_Flag233 (Id, V);
- end Set_Has_Pragma_Unmodified;
-
- procedure Set_Has_Pragma_Unreferenced (Id : E; V : B := True) is
- begin
- Set_Flag180 (Id, V);
- end Set_Has_Pragma_Unreferenced;
-
- procedure Set_Has_Pragma_Unreferenced_Objects (Id : E; V : B := True) is
- begin
- pragma Assert (Is_Type (Id));
- Set_Flag212 (Id, V);
- end Set_Has_Pragma_Unreferenced_Objects;
-
- procedure Set_Has_Pragma_Unused (Id : E; V : B := True) is
- begin
- Set_Flag294 (Id, V);
- end Set_Has_Pragma_Unused;
-
- procedure Set_Has_Predicates (Id : E; V : B := True) is
- begin
- pragma Assert (Is_Type (Id) or else Ekind (Id) = E_Void);
- Set_Flag250 (Id, V);
- end Set_Has_Predicates;
-
- procedure Set_Has_Primitive_Operations (Id : E; V : B := True) is
- begin
- pragma Assert (Id = Base_Type (Id));
- Set_Flag120 (Id, V);
- end Set_Has_Primitive_Operations;
-
- procedure Set_Has_Private_Ancestor (Id : E; V : B := True) is
- begin
- pragma Assert (Is_Type (Id));
- Set_Flag151 (Id, V);
- end Set_Has_Private_Ancestor;
-
- procedure Set_Has_Private_Declaration (Id : E; V : B := True) is
- begin
- Set_Flag155 (Id, V);
- end Set_Has_Private_Declaration;
-
- procedure Set_Has_Private_Extension (Id : E; V : B := True) is
- begin
- pragma Assert (Is_Tagged_Type (Id));
- Set_Flag300 (Id, V);
- end Set_Has_Private_Extension;
-
- procedure Set_Has_Protected (Id : E; V : B := True) is
- begin
- Set_Flag271 (Id, V);
- end Set_Has_Protected;
-
- procedure Set_Has_Qualified_Name (Id : E; V : B := True) is
- begin
- Set_Flag161 (Id, V);
- end Set_Has_Qualified_Name;
-
- procedure Set_Has_RACW (Id : E; V : B := True) is
- begin
- pragma Assert (Ekind (Id) = E_Package);
- Set_Flag214 (Id, V);
- end Set_Has_RACW;
-
- procedure Set_Has_Record_Rep_Clause (Id : E; V : B := True) is
- begin
- pragma Assert (Id = Base_Type (Id));
- Set_Flag65 (Id, V);
- end Set_Has_Record_Rep_Clause;
-
- procedure Set_Has_Recursive_Call (Id : E; V : B := True) is
- begin
- pragma Assert (Is_Subprogram (Id));
- Set_Flag143 (Id, V);
- end Set_Has_Recursive_Call;
-
- procedure Set_Has_Shift_Operator (Id : E; V : B := True) is
- begin
- pragma Assert (Is_Integer_Type (Id) and then Is_Base_Type (Id));
- Set_Flag267 (Id, V);
- end Set_Has_Shift_Operator;
-
- procedure Set_Has_Size_Clause (Id : E; V : B := True) is
- begin
- Set_Flag29 (Id, V);
- end Set_Has_Size_Clause;
-
- procedure Set_Has_Small_Clause (Id : E; V : B := True) is
- begin
- pragma Assert (Is_Ordinary_Fixed_Point_Type (Id));
- Set_Flag67 (Id, V);
- end Set_Has_Small_Clause;
-
- procedure Set_Has_Specified_Layout (Id : E; V : B := True) is
- begin
- pragma Assert (Id = Base_Type (Id));
- Set_Flag100 (Id, V);
- end Set_Has_Specified_Layout;
-
- procedure Set_Has_Specified_Stream_Input (Id : E; V : B := True) is
- begin
- pragma Assert (Is_Type (Id));
- Set_Flag190 (Id, V);
- end Set_Has_Specified_Stream_Input;
-
- procedure Set_Has_Specified_Stream_Output (Id : E; V : B := True) is
- begin
- pragma Assert (Is_Type (Id));
- Set_Flag191 (Id, V);
- end Set_Has_Specified_Stream_Output;
-
- procedure Set_Has_Specified_Stream_Read (Id : E; V : B := True) is
- begin
- pragma Assert (Is_Type (Id));
- Set_Flag192 (Id, V);
- end Set_Has_Specified_Stream_Read;
-
- procedure Set_Has_Specified_Stream_Write (Id : E; V : B := True) is
- begin
- pragma Assert (Is_Type (Id));
- Set_Flag193 (Id, V);
- end Set_Has_Specified_Stream_Write;
-
- procedure Set_Has_Static_Discriminants (Id : E; V : B := True) is
- begin
- Set_Flag211 (Id, V);
- end Set_Has_Static_Discriminants;
-
- procedure Set_Has_Static_Predicate (Id : E; V : B := True) is
- begin
- pragma Assert (Is_Type (Id));
- Set_Flag269 (Id, V);
- end Set_Has_Static_Predicate;
-
- procedure Set_Has_Static_Predicate_Aspect (Id : E; V : B := True) is
- begin
- pragma Assert (Is_Type (Id));
- Set_Flag259 (Id, V);
- end Set_Has_Static_Predicate_Aspect;
-
- procedure Set_Has_Storage_Size_Clause (Id : E; V : B := True) is
- begin
- pragma Assert (Is_Access_Type (Id) or else Is_Task_Type (Id));
- pragma Assert (Id = Base_Type (Id));
- Set_Flag23 (Id, V);
- end Set_Has_Storage_Size_Clause;
-
- procedure Set_Has_Stream_Size_Clause (Id : E; V : B := True) is
- begin
- pragma Assert (Is_Elementary_Type (Id));
- Set_Flag184 (Id, V);
- end Set_Has_Stream_Size_Clause;
-
- procedure Set_Has_Task (Id : E; V : B := True) is
- begin
- pragma Assert (Id = Base_Type (Id));
- Set_Flag30 (Id, V);
- end Set_Has_Task;
-
- procedure Set_Has_Thunks (Id : E; V : B := True) is
- begin
- pragma Assert (Is_Tag (Id));
- Set_Flag228 (Id, V);
- end Set_Has_Thunks;
-
- procedure Set_Has_Timing_Event (Id : E; V : B := True) is
- begin
- pragma Assert (Id = Base_Type (Id));
- Set_Flag289 (Id, V);
- end Set_Has_Timing_Event;
-
- procedure Set_Has_Unchecked_Union (Id : E; V : B := True) is
- begin
- pragma Assert (Id = Base_Type (Id));
- Set_Flag123 (Id, V);
- end Set_Has_Unchecked_Union;
-
- procedure Set_Has_Unknown_Discriminants (Id : E; V : B := True) is
- begin
- pragma Assert (Is_Type (Id));
- Set_Flag72 (Id, V);
- end Set_Has_Unknown_Discriminants;
-
- procedure Set_Has_Visible_Refinement (Id : E; V : B := True) is
- begin
- pragma Assert (Ekind (Id) = E_Abstract_State);
- Set_Flag263 (Id, V);
- end Set_Has_Visible_Refinement;
-
- procedure Set_Has_Volatile_Components (Id : E; V : B := True) is
- begin
- pragma Assert (not Is_Type (Id) or else Is_Base_Type (Id));
- Set_Flag87 (Id, V);
- end Set_Has_Volatile_Components;
-
- procedure Set_Has_Xref_Entry (Id : E; V : B := True) is
- begin
- 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);
- Set_Node8 (Id, V);
- end Set_Hiding_Loop_Variable;
-
- procedure Set_Hidden_In_Formal_Instance (Id : E; V : L) is
- begin
- pragma Assert (Ekind (Id) = E_Package);
- Set_Elist30 (Id, V);
- end Set_Hidden_In_Formal_Instance;
-
- procedure Set_Homonym (Id : E; V : E) is
- begin
- pragma Assert (Id /= V);
- Set_Node4 (Id, V);
- end Set_Homonym;
-
- procedure Set_Incomplete_Actuals (Id : E; V : L) is
- begin
- pragma Assert (Ekind (Id) = E_Package);
- Set_Elist24 (Id, V);
- end Set_Incomplete_Actuals;
-
- procedure Set_Ignore_SPARK_Mode_Pragmas (Id : E; V : B := True) is
- begin
- pragma Assert
- (Ekind (Id) in E_Protected_Body -- concurrent types
- | E_Protected_Type
- | E_Task_Body
- | E_Task_Type
- or else
- 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 (Id) in E_Generic_Package -- packages
- | E_Package
- | E_Package_Body);
- Set_Flag301 (Id, V);
- end Set_Ignore_SPARK_Mode_Pragmas;
-
- procedure Set_Import_Pragma (Id : E; V : E) is
- begin
- pragma Assert (Is_Subprogram (Id));
- Set_Node35 (Id, V);
- end Set_Import_Pragma;
-
- procedure Set_Interface_Alias (Id : E; V : E) is
- begin
- pragma Assert
- (Is_Internal (Id)
- and then Is_Hidden (Id)
- and then (Ekind (Id) in E_Procedure | E_Function));
- Set_Node25 (Id, V);
- end Set_Interface_Alias;
-
- procedure Set_Interfaces (Id : E; V : L) is
- begin
- pragma Assert (Is_Record_Type (Id));
- Set_Elist25 (Id, V);
- end Set_Interfaces;
-
- procedure Set_In_Package_Body (Id : E; V : B := True) is
- begin
- Set_Flag48 (Id, V);
- end Set_In_Package_Body;
-
- procedure Set_In_Private_Part (Id : E; V : B := True) is
- begin
- Set_Flag45 (Id, V);
- end Set_In_Private_Part;
-
- procedure Set_In_Use (Id : E; V : B := True) is
- begin
- pragma Assert (Nkind (Id) in N_Entity);
- Set_Flag8 (Id, V);
- end Set_In_Use;
-
- procedure Set_Initialization_Statements (Id : E; V : N) is
- begin
- -- Tolerate an E_Void entity since this can be called while resolving
- -- 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 (Id) in E_Void | E_Constant | E_Variable);
- Set_Node28 (Id, V);
- end Set_Initialization_Statements;
-
- procedure Set_Inner_Instances (Id : E; V : L) is
- begin
- Set_Elist23 (Id, V);
- end Set_Inner_Instances;
-
- procedure Set_Interface_Name (Id : E; V : N) is
- begin
- Set_Node21 (Id, V);
- end Set_Interface_Name;
-
- procedure Set_Is_Abstract_Subprogram (Id : E; V : B := True) is
- begin
- pragma Assert (Is_Overloadable (Id));
- Set_Flag19 (Id, V);
- end Set_Is_Abstract_Subprogram;
-
- procedure Set_Is_Abstract_Type (Id : E; V : B := True) is
- begin
- pragma Assert (Is_Type (Id));
- Set_Flag146 (Id, V);
- end Set_Is_Abstract_Type;
-
- procedure Set_Is_Local_Anonymous_Access (Id : E; V : B := True) is
- begin
- pragma Assert (Is_Access_Type (Id));
- Set_Flag194 (Id, V);
- end Set_Is_Local_Anonymous_Access;
-
- procedure Set_Is_Access_Constant (Id : E; V : B := True) is
- begin
- pragma Assert (Is_Access_Type (Id));
- Set_Flag69 (Id, V);
- end Set_Is_Access_Constant;
-
- procedure Set_Is_Activation_Record (Id : E; V : B := True) is
- begin
- pragma Assert (Ekind (Id) = E_In_Parameter);
- Set_Flag305 (Id, V);
- end Set_Is_Activation_Record;
-
- procedure Set_Is_Actual_Subtype (Id : E; V : B := True) is
- begin
- pragma Assert (Is_Type (Id));
- Set_Flag293 (Id, V);
- end Set_Is_Actual_Subtype;
-
- procedure Set_Is_Ada_2005_Only (Id : E; V : B := True) is
- begin
- Set_Flag185 (Id, V);
- end Set_Is_Ada_2005_Only;
-
- procedure Set_Is_Ada_2012_Only (Id : E; V : B := True) is
- begin
- Set_Flag199 (Id, V);
- end Set_Is_Ada_2012_Only;
-
- procedure Set_Is_Aliased (Id : E; V : B := True) is
- begin
- pragma Assert (Nkind (Id) in N_Entity);
- Set_Flag15 (Id, V);
- end Set_Is_Aliased;
-
- procedure Set_Is_Asynchronous (Id : E; V : B := True) is
- begin
- pragma Assert
- (Ekind (Id) = E_Procedure or else Is_Type (Id));
- Set_Flag81 (Id, V);
- end Set_Is_Asynchronous;
-
- procedure Set_Is_Atomic (Id : E; V : B := True) is
- begin
- Set_Flag85 (Id, V);
- end Set_Is_Atomic;
-
- procedure Set_Is_Bit_Packed_Array (Id : E; V : B := True) is
- begin
- pragma Assert ((not V)
- or else (Is_Array_Type (Id) and then Is_Base_Type (Id)));
- Set_Flag122 (Id, V);
- end Set_Is_Bit_Packed_Array;
-
- procedure Set_Is_Called (Id : E; V : B := True) is
- begin
- pragma Assert (Ekind (Id) in E_Procedure | E_Function | E_Package);
- Set_Flag102 (Id, V);
- end Set_Is_Called;
-
- procedure Set_Is_Character_Type (Id : E; V : B := True) is
- begin
- Set_Flag63 (Id, V);
- end Set_Is_Character_Type;
-
- procedure Set_Is_Checked_Ghost_Entity (Id : E; V : B := True) is
- begin
- -- Allow this attribute to appear on unanalyzed entities
-
- pragma Assert (Nkind (Id) in N_Entity
- or else Ekind (Id) = E_Void);
- Set_Flag277 (Id, V);
- end Set_Is_Checked_Ghost_Entity;
-
- procedure Set_Is_Child_Unit (Id : E; V : B := True) is
- begin
- Set_Flag73 (Id, V);
- end Set_Is_Child_Unit;
-
- procedure Set_Is_Class_Wide_Clone (Id : E; V : B := True) is
- begin
- Set_Flag290 (Id, V);
- end Set_Is_Class_Wide_Clone;
-
- procedure Set_Is_Class_Wide_Equivalent_Type (Id : E; V : B := True) is
- begin
- Set_Flag35 (Id, V);
- end Set_Is_Class_Wide_Equivalent_Type;
-
- procedure Set_Is_Compilation_Unit (Id : E; V : B := True) is
- begin
- Set_Flag149 (Id, V);
- end Set_Is_Compilation_Unit;
-
- procedure Set_Is_Completely_Hidden (Id : E; V : B := True) is
- begin
- pragma Assert (Ekind (Id) = E_Discriminant);
- Set_Flag103 (Id, V);
- end Set_Is_Completely_Hidden;
-
- procedure Set_Is_Concurrent_Record_Type (Id : E; V : B := True) is
- begin
- Set_Flag20 (Id, V);
- end Set_Is_Concurrent_Record_Type;
-
- procedure Set_Is_Constr_Subt_For_U_Nominal (Id : E; V : B := True) is
- begin
- Set_Flag80 (Id, V);
- end Set_Is_Constr_Subt_For_U_Nominal;
-
- procedure Set_Is_Constr_Subt_For_UN_Aliased (Id : E; V : B := True) is
- begin
- Set_Flag141 (Id, V);
- end Set_Is_Constr_Subt_For_UN_Aliased;
-
- procedure Set_Is_Constrained (Id : E; V : B := True) is
- begin
- pragma Assert (Nkind (Id) in N_Entity);
- Set_Flag12 (Id, V);
- end Set_Is_Constrained;
-
- procedure Set_Is_Constructor (Id : E; V : B := True) is
- begin
- Set_Flag76 (Id, V);
- end Set_Is_Constructor;
-
- procedure Set_Is_Controlled_Active (Id : E; V : B := True) is
- begin
- pragma Assert (Id = Base_Type (Id));
- Set_Flag42 (Id, V);
- end Set_Is_Controlled_Active;
-
- procedure Set_Is_Controlling_Formal (Id : E; V : B := True) is
- begin
- pragma Assert (Is_Formal (Id));
- Set_Flag97 (Id, V);
- end Set_Is_Controlling_Formal;
-
- procedure Set_Is_CPP_Class (Id : E; V : B := True) is
- begin
- 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);
- Set_Flag132 (Id, V);
- end Set_Is_DIC_Procedure;
-
- procedure Set_Is_Descendant_Of_Address (Id : E; V : B := True) is
- begin
- pragma Assert (Is_Type (Id));
- Set_Flag223 (Id, V);
- end Set_Is_Descendant_Of_Address;
-
- procedure Set_Is_Discrim_SO_Function (Id : E; V : B := True) is
- begin
- Set_Flag176 (Id, V);
- end Set_Is_Discrim_SO_Function;
-
- procedure Set_Is_Discriminant_Check_Function (Id : E; V : B := True) is
- begin
- Set_Flag264 (Id, V);
- end Set_Is_Discriminant_Check_Function;
-
- procedure Set_Is_Dispatch_Table_Entity (Id : E; V : B := True) is
- begin
- Set_Flag234 (Id, V);
- end Set_Is_Dispatch_Table_Entity;
-
- procedure Set_Is_Dispatching_Operation (Id : E; V : B := True) is
- begin
- pragma Assert
- (V = False
- or else
- Is_Overloadable (Id)
- or else
- Ekind (Id) = E_Subprogram_Type);
-
- Set_Flag6 (Id, V);
- end Set_Is_Dispatching_Operation;
-
- procedure Set_Is_Elaboration_Checks_OK_Id (Id : E; V : B := True) is
- begin
- pragma Assert (Is_Elaboration_Target (Id));
- Set_Flag148 (Id, V);
- end Set_Is_Elaboration_Checks_OK_Id;
-
- procedure Set_Is_Elaboration_Warnings_OK_Id (Id : E; V : B := True) is
- begin
- pragma Assert (Is_Elaboration_Target (Id));
- Set_Flag304 (Id, V);
- end Set_Is_Elaboration_Warnings_OK_Id;
-
- procedure Set_Is_Eliminated (Id : E; V : B := True) is
- begin
- Set_Flag124 (Id, V);
- end Set_Is_Eliminated;
-
- procedure Set_Is_Entry_Formal (Id : E; V : B := True) is
- begin
- Set_Flag52 (Id, V);
- end Set_Is_Entry_Formal;
-
- procedure Set_Is_Entry_Wrapper (Id : E; V : B := True) is
- begin
- Set_Flag297 (Id, V);
- end Set_Is_Entry_Wrapper;
-
- procedure Set_Is_Exception_Handler (Id : E; V : B := True) is
- begin
- pragma Assert (Ekind (Id) = E_Block);
- Set_Flag286 (Id, V);
- end Set_Is_Exception_Handler;
-
- procedure Set_Is_Exported (Id : E; V : B := True) is
- begin
- Set_Flag99 (Id, V);
- end Set_Is_Exported;
-
- procedure Set_Is_Finalized_Transient (Id : E; V : B := True) is
- begin
- pragma Assert (Ekind (Id) in E_Constant | E_Loop_Parameter | E_Variable);
- Set_Flag252 (Id, V);
- end Set_Is_Finalized_Transient;
-
- procedure Set_Is_First_Subtype (Id : E; V : B := True) is
- begin
- Set_Flag70 (Id, V);
- end Set_Is_First_Subtype;
-
- procedure Set_Is_Formal_Subprogram (Id : E; V : B := True) is
- begin
- Set_Flag111 (Id, V);
- end Set_Is_Formal_Subprogram;
-
- procedure Set_Is_Frozen (Id : E; V : B := True) is
- begin
- pragma Assert (Nkind (Id) in N_Entity);
- Set_Flag4 (Id, V);
- end Set_Is_Frozen;
-
- procedure Set_Is_Generic_Actual_Subprogram (Id : E; V : B := True) is
- begin
- pragma Assert (Ekind (Id) in E_Function | E_Procedure);
- Set_Flag274 (Id, V);
- end Set_Is_Generic_Actual_Subprogram;
-
- procedure Set_Is_Generic_Actual_Type (Id : E; V : B := True) is
- begin
- pragma Assert (Is_Type (Id));
- Set_Flag94 (Id, V);
- end Set_Is_Generic_Actual_Type;
-
- procedure Set_Is_Generic_Instance (Id : E; V : B := True) is
- begin
- Set_Flag130 (Id, V);
- end Set_Is_Generic_Instance;
-
- procedure Set_Is_Generic_Type (Id : E; V : B := True) is
- begin
- pragma Assert (Nkind (Id) in N_Entity);
- Set_Flag13 (Id, V);
- end Set_Is_Generic_Type;
-
- procedure Set_Is_Hidden (Id : E; V : B := True) is
- begin
- Set_Flag57 (Id, V);
- end Set_Is_Hidden;
-
- procedure Set_Is_Hidden_Non_Overridden_Subpgm (Id : E; V : B := True) is
- begin
- pragma Assert (Ekind (Id) in E_Function | E_Procedure);
- Set_Flag2 (Id, V);
- end Set_Is_Hidden_Non_Overridden_Subpgm;
-
- procedure Set_Is_Hidden_Open_Scope (Id : E; V : B := True) is
- begin
- Set_Flag171 (Id, V);
- end Set_Is_Hidden_Open_Scope;
-
- procedure Set_Is_Ignored_Ghost_Entity (Id : E; V : B := True) is
- begin
- -- Allow this attribute to appear on unanalyzed entities
-
- pragma Assert (Nkind (Id) in N_Entity
- or else Ekind (Id) = E_Void);
- Set_Flag278 (Id, V);
- end Set_Is_Ignored_Ghost_Entity;
-
- procedure Set_Is_Ignored_Transient (Id : E; V : B := True) is
- begin
- pragma Assert (Ekind (Id) in E_Constant | E_Loop_Parameter | E_Variable);
- Set_Flag295 (Id, V);
- end Set_Is_Ignored_Transient;
-
- procedure Set_Is_Immediately_Visible (Id : E; V : B := True) is
- begin
- pragma Assert (Nkind (Id) in N_Entity);
- Set_Flag7 (Id, V);
- end Set_Is_Immediately_Visible;
-
- procedure Set_Is_Implementation_Defined (Id : E; V : B := True) is
- begin
- Set_Flag254 (Id, V);
- end Set_Is_Implementation_Defined;
-
- procedure Set_Is_Imported (Id : E; V : B := True) is
- begin
- Set_Flag24 (Id, V);
- end Set_Is_Imported;
-
- procedure Set_Is_Independent (Id : E; V : B := True) is
- begin
- Set_Flag268 (Id, V);
- end Set_Is_Independent;
-
- procedure Set_Is_Initial_Condition_Procedure (Id : E; V : B := True) is
- begin
- pragma Assert (Ekind (Id) in E_Function | E_Procedure);
- Set_Flag302 (Id, V);
- end Set_Is_Initial_Condition_Procedure;
-
- procedure Set_Is_Inlined (Id : E; V : B := True) is
- begin
- Set_Flag11 (Id, V);
- end Set_Is_Inlined;
-
- procedure Set_Is_Inlined_Always (Id : E; V : B := True) is
- begin
- pragma Assert (Ekind (Id) in E_Function | E_Procedure);
- Set_Flag1 (Id, V);
- end Set_Is_Inlined_Always;
-
- procedure Set_Is_Interface (Id : E; V : B := True) is
- begin
- pragma Assert (Is_Record_Type (Id));
- Set_Flag186 (Id, V);
- end Set_Is_Interface;
-
- procedure Set_Is_Instantiated (Id : E; V : B := True) is
- begin
- Set_Flag126 (Id, V);
- end Set_Is_Instantiated;
-
- procedure Set_Is_Internal (Id : E; V : B := True) is
- begin
- pragma Assert (Nkind (Id) in N_Entity);
- Set_Flag17 (Id, V);
- end Set_Is_Internal;
-
- procedure Set_Is_Interrupt_Handler (Id : E; V : B := True) is
- begin
- pragma Assert (Nkind (Id) in N_Entity);
- Set_Flag89 (Id, V);
- end Set_Is_Interrupt_Handler;
-
- procedure Set_Is_Intrinsic_Subprogram (Id : E; V : B := True) is
- begin
- Set_Flag64 (Id, V);
- end Set_Is_Intrinsic_Subprogram;
-
- procedure Set_Is_Invariant_Procedure (Id : E; V : B := True) is
- begin
- pragma Assert (Ekind (Id) = E_Procedure);
- Set_Flag257 (Id, V);
- end Set_Is_Invariant_Procedure;
-
- procedure Set_Is_Itype (Id : E; V : B := True) is
- begin
- Set_Flag91 (Id, V);
- end Set_Is_Itype;
-
- procedure Set_Is_Known_Non_Null (Id : E; V : B := True) is
- begin
- Set_Flag37 (Id, V);
- end Set_Is_Known_Non_Null;
-
- procedure Set_Is_Known_Null (Id : E; V : B := True) is
- begin
- Set_Flag204 (Id, V);
- end Set_Is_Known_Null;
-
- procedure Set_Is_Known_Valid (Id : E; V : B := True) is
- begin
- Set_Flag170 (Id, V);
- end Set_Is_Known_Valid;
-
- procedure Set_Is_Limited_Composite (Id : E; V : B := True) is
- begin
- pragma Assert (Is_Type (Id));
- Set_Flag106 (Id, V);
- end Set_Is_Limited_Composite;
-
- procedure Set_Is_Limited_Interface (Id : E; V : B := True) is
- begin
- pragma Assert (Is_Interface (Id));
- Set_Flag197 (Id, V);
- end Set_Is_Limited_Interface;
-
- procedure Set_Is_Limited_Record (Id : E; V : B := True) is
- begin
- Set_Flag25 (Id, V);
- end Set_Is_Limited_Record;
-
- procedure Set_Is_Loop_Parameter (Id : E; V : B := True) is
- begin
- Set_Flag307 (Id, V);
- end Set_Is_Loop_Parameter;
-
- procedure Set_Is_Machine_Code_Subprogram (Id : E; V : B := True) is
- begin
- pragma Assert (Is_Subprogram (Id));
- Set_Flag137 (Id, V);
- end Set_Is_Machine_Code_Subprogram;
-
- procedure Set_Is_Non_Static_Subtype (Id : E; V : B := True) is
- begin
- pragma Assert (Is_Type (Id));
- Set_Flag109 (Id, V);
- end Set_Is_Non_Static_Subtype;
-
- procedure Set_Is_Null_Init_Proc (Id : E; V : B := True) is
- begin
- pragma Assert (Ekind (Id) = E_Procedure);
- Set_Flag178 (Id, V);
- end Set_Is_Null_Init_Proc;
-
- procedure Set_Is_Obsolescent (Id : E; V : B := True) is
- begin
- Set_Flag153 (Id, V);
- end Set_Is_Obsolescent;
-
- procedure Set_Is_Only_Out_Parameter (Id : E; V : B := True) is
- begin
- pragma Assert (Ekind (Id) = E_Out_Parameter);
- Set_Flag226 (Id, V);
- end Set_Is_Only_Out_Parameter;
-
- procedure Set_Is_Package_Body_Entity (Id : E; V : B := True) is
- begin
- Set_Flag160 (Id, V);
- end Set_Is_Package_Body_Entity;
-
- procedure Set_Is_Packed (Id : E; V : B := True) is
- begin
- pragma Assert (Id = Base_Type (Id));
- Set_Flag51 (Id, V);
- end Set_Is_Packed;
-
- procedure Set_Is_Packed_Array_Impl_Type (Id : E; V : B := True) is
- begin
- Set_Flag138 (Id, V);
- end Set_Is_Packed_Array_Impl_Type;
-
- procedure Set_Is_Param_Block_Component_Type (Id : E; V : B := True) is
- begin
- pragma Assert (Ekind (Id) in E_Void | E_General_Access_Type);
- Set_Flag215 (Id, V);
- end Set_Is_Param_Block_Component_Type;
-
- procedure Set_Is_Partial_Invariant_Procedure (Id : E; V : B := True) is
- begin
- pragma Assert (Ekind (Id) = E_Procedure);
- Set_Flag292 (Id, V);
- end Set_Is_Partial_Invariant_Procedure;
-
- procedure Set_Is_Potentially_Use_Visible (Id : E; V : B := True) is
- begin
- pragma Assert (Nkind (Id) in N_Entity);
- Set_Flag9 (Id, V);
- end Set_Is_Potentially_Use_Visible;
-
- procedure Set_Is_Predicate_Function (Id : E; V : B := True) is
- begin
- pragma Assert (Ekind (Id) = E_Function);
- Set_Flag255 (Id, V);
- end Set_Is_Predicate_Function;
-
- procedure Set_Is_Predicate_Function_M (Id : E; V : B := True) is
- begin
- pragma Assert (Ekind (Id) in E_Function | E_Procedure);
- Set_Flag256 (Id, V);
- end Set_Is_Predicate_Function_M;
-
- procedure Set_Is_Preelaborated (Id : E; V : B := True) is
- begin
- Set_Flag59 (Id, V);
- end Set_Is_Preelaborated;
-
- procedure Set_Is_Primitive (Id : E; V : B := True) is
- begin
- 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 (Id) in E_Function | E_Procedure);
- Set_Flag195 (Id, V);
- end Set_Is_Primitive_Wrapper;
-
- procedure Set_Is_Private_Composite (Id : E; V : B := True) is
- begin
- pragma Assert (Is_Type (Id));
- Set_Flag107 (Id, V);
- end Set_Is_Private_Composite;
-
- procedure Set_Is_Private_Descendant (Id : E; V : B := True) is
- begin
- Set_Flag53 (Id, V);
- end Set_Is_Private_Descendant;
-
- procedure Set_Is_Private_Primitive (Id : E; V : B := True) is
- begin
- pragma Assert (Ekind (Id) in E_Function | E_Procedure);
- Set_Flag245 (Id, V);
- end Set_Is_Private_Primitive;
-
- procedure Set_Is_Public (Id : E; V : B := True) is
- begin
- pragma Assert (Nkind (Id) in N_Entity);
- Set_Flag10 (Id, V);
- end Set_Is_Public;
-
- procedure Set_Is_Pure (Id : E; V : B := True) is
- begin
- Set_Flag44 (Id, V);
- end Set_Is_Pure;
-
- procedure Set_Is_Pure_Unit_Access_Type (Id : E; V : B := True) is
- begin
- pragma Assert (Is_Access_Type (Id));
- Set_Flag189 (Id, V);
- end Set_Is_Pure_Unit_Access_Type;
-
- procedure Set_Is_RACW_Stub_Type (Id : E; V : B := True) is
- begin
- pragma Assert (Is_Type (Id));
- Set_Flag244 (Id, V);
- end Set_Is_RACW_Stub_Type;
-
- procedure Set_Is_Raised (Id : E; V : B := True) is
- begin
- pragma Assert (Ekind (Id) = E_Exception);
- Set_Flag224 (Id, V);
- end Set_Is_Raised;
-
- procedure Set_Is_Remote_Call_Interface (Id : E; V : B := True) is
- begin
- Set_Flag62 (Id, V);
- end Set_Is_Remote_Call_Interface;
-
- procedure Set_Is_Remote_Types (Id : E; V : B := True) is
- begin
- Set_Flag61 (Id, V);
- end Set_Is_Remote_Types;
-
- procedure Set_Is_Renaming_Of_Object (Id : E; V : B := True) is
- begin
- Set_Flag112 (Id, V);
- end Set_Is_Renaming_Of_Object;
-
- procedure Set_Is_Return_Object (Id : E; V : B := True) is
- begin
- Set_Flag209 (Id, V);
- end Set_Is_Return_Object;
-
- procedure Set_Is_Safe_To_Reevaluate (Id : E; V : B := True) is
- begin
- pragma Assert (Ekind (Id) = E_Variable);
- Set_Flag249 (Id, V);
- end Set_Is_Safe_To_Reevaluate;
-
- procedure Set_Is_Shared_Passive (Id : E; V : B := True) is
- begin
- Set_Flag60 (Id, V);
- end Set_Is_Shared_Passive;
-
- procedure Set_Is_Static_Type (Id : E; V : B := True) is
- begin
- pragma Assert (Is_Type (Id));
- Set_Flag281 (Id, V);
- end Set_Is_Static_Type;
-
- procedure Set_Is_Statically_Allocated (Id : E; V : B := True) is
- begin
- pragma Assert
- (Is_Type (Id)
- 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 (Id) in E_Component | E_Constant | E_Variable);
- Set_Flag78 (Id, V);
- end Set_Is_Tag;
-
- procedure Set_Is_Tagged_Type (Id : E; V : B := True) is
- begin
- Set_Flag55 (Id, V);
- end Set_Is_Tagged_Type;
-
- procedure Set_Is_Thunk (Id : E; V : B := True) is
- begin
- pragma Assert (Is_Subprogram (Id));
- Set_Flag225 (Id, V);
- end Set_Is_Thunk;
-
- procedure Set_Is_Trivial_Subprogram (Id : E; V : B := True) is
- begin
- Set_Flag235 (Id, V);
- end Set_Is_Trivial_Subprogram;
-
- procedure Set_Is_True_Constant (Id : E; V : B := True) is
- begin
- Set_Flag163 (Id, V);
- end Set_Is_True_Constant;
-
- procedure Set_Is_Unchecked_Union (Id : E; V : B := True) is
- begin
- pragma Assert (Id = Base_Type (Id));
- Set_Flag117 (Id, V);
- end Set_Is_Unchecked_Union;
-
- procedure Set_Is_Underlying_Full_View (Id : E; V : B := True) is
- begin
- pragma Assert (Is_Type (Id));
- Set_Flag298 (Id, V);
- end Set_Is_Underlying_Full_View;
-
- procedure Set_Is_Underlying_Record_View (Id : E; V : B := True) is
- begin
- pragma Assert (Ekind (Id) = E_Record_Type);
- Set_Flag246 (Id, V);
- end Set_Is_Underlying_Record_View;
-
- procedure Set_Is_Unimplemented (Id : E; V : B := True) is
- begin
- Set_Flag284 (Id, V);
- end Set_Is_Unimplemented;
-
- procedure Set_Is_Unsigned_Type (Id : E; V : B := True) is
- begin
- pragma Assert (Is_Discrete_Or_Fixed_Point_Type (Id));
- Set_Flag144 (Id, V);
- end Set_Is_Unsigned_Type;
-
- procedure Set_Is_Uplevel_Referenced_Entity (Id : E; V : B := True) is
- begin
- pragma Assert
- (Ekind (Id) in E_Constant | E_Loop_Parameter | E_Variable
- or else Is_Formal (Id)
- or else Is_Type (Id));
- Set_Flag283 (Id, V);
- end Set_Is_Uplevel_Referenced_Entity;
-
- procedure Set_Is_Valued_Procedure (Id : E; V : B := True) is
- begin
- pragma Assert (Ekind (Id) = E_Procedure);
- Set_Flag127 (Id, V);
- end Set_Is_Valued_Procedure;
-
- procedure Set_Is_Visible_Formal (Id : E; V : B := True) is
- begin
- Set_Flag206 (Id, V);
- end Set_Is_Visible_Formal;
-
- procedure Set_Is_Visible_Lib_Unit (Id : E; V : B := True) is
- begin
- Set_Flag116 (Id, V);
- end Set_Is_Visible_Lib_Unit;
-
- procedure Set_Is_Volatile (Id : E; V : B := True) is
- begin
- pragma Assert (Nkind (Id) in N_Entity);
- Set_Flag16 (Id, V);
- end Set_Is_Volatile;
-
- procedure Set_Is_Volatile_Full_Access (Id : E; V : B := True) is
- begin
- Set_Flag285 (Id, V);
- end Set_Is_Volatile_Full_Access;
-
- procedure Set_Itype_Printed (Id : E; V : B := True) is
- begin
- pragma Assert (Is_Itype (Id));
- Set_Flag202 (Id, V);
- end Set_Itype_Printed;
-
- procedure Set_Kill_Elaboration_Checks (Id : E; V : B := True) is
- begin
- Set_Flag32 (Id, V);
- end Set_Kill_Elaboration_Checks;
-
- procedure Set_Kill_Range_Checks (Id : E; V : B := True) is
- begin
- Set_Flag33 (Id, V);
- end Set_Kill_Range_Checks;
-
- procedure Set_Known_To_Have_Preelab_Init (Id : E; V : B := True) is
- begin
- pragma Assert (Is_Type (Id));
- Set_Flag207 (Id, V);
- end Set_Known_To_Have_Preelab_Init;
-
- procedure Set_Last_Aggregate_Assignment (Id : E; V : N) is
- begin
- pragma Assert (Ekind (Id) in E_Constant | E_Variable);
- Set_Node30 (Id, V);
- end Set_Last_Aggregate_Assignment;
-
- procedure Set_Last_Assignment (Id : E; V : N) is
- begin
- pragma Assert (Is_Assignable (Id));
- Set_Node26 (Id, V);
- end Set_Last_Assignment;
-
- procedure Set_Last_Entity (Id : E; V : E) is
- begin
- Set_Node20 (Id, V);
- end Set_Last_Entity;
-
- procedure Set_Limited_View (Id : E; V : E) is
- begin
- pragma Assert (Ekind (Id) = E_Package
- and then not Is_Generic_Instance (Id));
- Set_Node23 (Id, V);
- end Set_Limited_View;
-
- procedure Set_Linker_Section_Pragma (Id : E; V : N) is
- begin
- pragma Assert
- (Is_Object (Id) or else Is_Subprogram (Id) or else Is_Type (Id));
- Set_Node33 (Id, V);
- end Set_Linker_Section_Pragma;
-
- procedure Set_Lit_Indexes (Id : E; V : E) is
- begin
- pragma Assert (Is_Enumeration_Type (Id) and then Root_Type (Id) = Id);
- Set_Node18 (Id, V);
- end Set_Lit_Indexes;
-
- procedure Set_Lit_Strings (Id : E; V : E) is
- begin
- pragma Assert (Is_Enumeration_Type (Id) and then Root_Type (Id) = Id);
- Set_Node16 (Id, V);
- end Set_Lit_Strings;
-
- procedure Set_Low_Bound_Tested (Id : E; V : B := True) is
- begin
- pragma Assert (Is_Formal (Id));
- Set_Flag205 (Id, V);
- end Set_Low_Bound_Tested;
-
- procedure Set_Machine_Radix_10 (Id : E; V : B := True) is
- begin
- pragma Assert (Is_Decimal_Fixed_Point_Type (Id));
- Set_Flag84 (Id, V);
- end Set_Machine_Radix_10;
-
- procedure Set_Master_Id (Id : E; V : E) is
- begin
- pragma Assert (Is_Access_Type (Id));
- Set_Node17 (Id, V);
- end Set_Master_Id;
-
- procedure Set_Materialize_Entity (Id : E; V : B := True) is
- begin
- Set_Flag168 (Id, V);
- end Set_Materialize_Entity;
-
- procedure Set_May_Inherit_Delayed_Rep_Aspects (Id : E; V : B := True) is
- begin
- Set_Flag262 (Id, V);
- end Set_May_Inherit_Delayed_Rep_Aspects;
-
- procedure Set_Mechanism (Id : E; V : M) is
- begin
- pragma Assert (Ekind (Id) = E_Function or else Is_Formal (Id));
- Set_Uint8 (Id, UI_From_Int (V));
- end Set_Mechanism;
-
- procedure Set_Minimum_Accessibility (Id : E; V : E) is
- begin
- pragma Assert (Is_Formal (Id));
- Set_Node24 (Id, V);
- end Set_Minimum_Accessibility;
-
- procedure Set_Modulus (Id : E; V : U) is
- begin
- pragma Assert (Ekind (Id) = E_Modular_Integer_Type);
- Set_Uint17 (Id, V);
- end Set_Modulus;
-
- procedure Set_Must_Be_On_Byte_Boundary (Id : E; V : B := True) is
- begin
- pragma Assert (Is_Type (Id));
- Set_Flag183 (Id, V);
- end Set_Must_Be_On_Byte_Boundary;
-
- procedure Set_Must_Have_Preelab_Init (Id : E; V : B := True) is
- begin
- pragma Assert (Is_Type (Id));
- Set_Flag208 (Id, V);
- end Set_Must_Have_Preelab_Init;
-
- procedure Set_Needs_Activation_Record (Id : E; V : B := True) is
- begin
- Set_Flag306 (Id, V);
- end Set_Needs_Activation_Record;
-
- procedure Set_Needs_Debug_Info (Id : E; V : B := True) is
- begin
- Set_Flag147 (Id, V);
- end Set_Needs_Debug_Info;
-
- procedure Set_Needs_No_Actuals (Id : E; V : B := True) is
- begin
- pragma Assert
- (Is_Overloadable (Id)
- or else Ekind (Id) in E_Subprogram_Type | E_Entry_Family);
- Set_Flag22 (Id, V);
- end Set_Needs_No_Actuals;
-
- procedure Set_Never_Set_In_Source (Id : E; V : B := True) is
- begin
- Set_Flag115 (Id, V);
- end Set_Never_Set_In_Source;
-
- procedure Set_Next_Inlined_Subprogram (Id : E; V : E) is
- begin
- Set_Node12 (Id, V);
- end Set_Next_Inlined_Subprogram;
-
- procedure Set_No_Dynamic_Predicate_On_Actual (Id : E; V : B := True) is
- begin
- pragma Assert (Is_Discrete_Type (Id));
- Set_Flag276 (Id, V);
- end Set_No_Dynamic_Predicate_On_Actual;
-
- procedure Set_No_Pool_Assigned (Id : E; V : B := True) is
- begin
- pragma Assert (Is_Access_Type (Id) and then Is_Base_Type (Id));
- Set_Flag131 (Id, V);
- end Set_No_Pool_Assigned;
-
- procedure Set_No_Predicate_On_Actual (Id : E; V : B := True) is
- begin
- pragma Assert (Is_Discrete_Type (Id));
- Set_Flag275 (Id, V);
- end Set_No_Predicate_On_Actual;
-
- procedure Set_No_Reordering (Id : E; V : B := True) is
- begin
- pragma Assert (Is_Record_Type (Id) and then Is_Base_Type (Id));
- Set_Flag239 (Id, V);
- end Set_No_Reordering;
-
- procedure Set_No_Return (Id : E; V : B := True) is
- begin
- pragma Assert (Is_Subprogram_Or_Generic_Subprogram (Id));
- Set_Flag113 (Id, V);
- end Set_No_Return;
-
- procedure Set_No_Strict_Aliasing (Id : E; V : B := True) is
- begin
- pragma Assert (Is_Access_Type (Id) and then Is_Base_Type (Id));
- Set_Flag136 (Id, V);
- end Set_No_Strict_Aliasing;
-
- procedure Set_No_Tagged_Streams_Pragma (Id : E; V : E) is
- begin
- pragma Assert (Is_Tagged_Type (Id));
- Set_Node32 (Id, V);
- end Set_No_Tagged_Streams_Pragma;
-
- procedure Set_Non_Binary_Modulus (Id : E; V : B := True) is
- begin
- pragma Assert (Is_Type (Id) and then Is_Base_Type (Id));
- Set_Flag58 (Id, V);
- end Set_Non_Binary_Modulus;
-
- procedure Set_Non_Limited_View (Id : E; V : E) is
- begin
- pragma Assert
- (Ekind (Id) in Incomplete_Kind
- or else Ekind (Id) in E_Abstract_State | E_Class_Wide_Type);
- Set_Node19 (Id, V);
- end Set_Non_Limited_View;
-
- procedure Set_Nonzero_Is_True (Id : E; V : B := True) is
- begin
- pragma Assert
- (Root_Type (Id) = Standard_Boolean
- and then Ekind (Id) = E_Enumeration_Type);
- Set_Flag162 (Id, V);
- end Set_Nonzero_Is_True;
-
- procedure Set_Normalized_First_Bit (Id : E; V : U) is
- begin
- 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 (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 (Id) in E_Component | E_Discriminant);
- Set_Uint10 (Id, V);
- end Set_Normalized_Position_Max;
-
- procedure Set_OK_To_Rename (Id : E; V : B := True) is
- begin
- pragma Assert (Ekind (Id) = E_Variable);
- Set_Flag247 (Id, V);
- end Set_OK_To_Rename;
-
- procedure Set_Optimize_Alignment_Space (Id : E; V : B := True) is
- begin
- pragma Assert
- (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 (Id) in E_Constant | E_Variable);
- Set_Flag242 (Id, V);
- end Set_Optimize_Alignment_Time;
-
- procedure Set_Original_Access_Type (Id : E; V : E) is
- begin
- pragma Assert (Ekind (Id) = E_Access_Subprogram_Type);
- Set_Node28 (Id, V);
- end Set_Original_Access_Type;
-
- procedure Set_Original_Array_Type (Id : E; V : E) is
- begin
- pragma Assert (Is_Array_Type (Id) or else Is_Modular_Integer_Type (Id));
- Set_Node21 (Id, V);
- end Set_Original_Array_Type;
-
- procedure Set_Original_Protected_Subprogram (Id : E; V : N) is
- begin
- 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 (Id) in E_Void | E_Component | E_Discriminant);
- Set_Node22 (Id, V);
- end Set_Original_Record_Component;
-
- procedure Set_Overlays_Constant (Id : E; V : B := True) is
- begin
- Set_Flag243 (Id, V);
- end Set_Overlays_Constant;
-
- procedure Set_Overridden_Operation (Id : E; V : E) is
- begin
- pragma Assert (Is_Subprogram_Or_Generic_Subprogram (Id));
- Set_Node26 (Id, V);
- end Set_Overridden_Operation;
-
- procedure Set_Package_Instantiation (Id : E; V : N) is
- begin
- pragma Assert (Ekind (Id) in E_Void | E_Generic_Package | E_Package);
- Set_Node26 (Id, V);
- end Set_Package_Instantiation;
-
- procedure Set_Packed_Array_Impl_Type (Id : E; V : E) is
- begin
- pragma Assert (Is_Array_Type (Id));
- Set_Node23 (Id, V);
- end Set_Packed_Array_Impl_Type;
-
- procedure Set_Parent_Subtype (Id : E; V : E) is
- begin
- pragma Assert (Ekind (Id) = E_Record_Type);
- Set_Node19 (Id, V);
- end Set_Parent_Subtype;
-
- procedure Set_Part_Of_Constituents (Id : E; V : L) is
- begin
- pragma Assert (Ekind (Id) in E_Abstract_State | E_Variable);
- Set_Elist10 (Id, V);
- end Set_Part_Of_Constituents;
-
- procedure Set_Part_Of_References (Id : E; V : L) is
- begin
- pragma Assert (Ekind (Id) = E_Variable);
- Set_Elist11 (Id, V);
- end Set_Part_Of_References;
-
- procedure Set_Partial_View_Has_Unknown_Discr (Id : E; V : B := True) is
- begin
- pragma Assert (Is_Type (Id));
- Set_Flag280 (Id, V);
- end Set_Partial_View_Has_Unknown_Discr;
-
- procedure Set_Pending_Access_Types (Id : E; V : L) is
- begin
- pragma Assert (Is_Type (Id));
- Set_Elist15 (Id, V);
- end Set_Pending_Access_Types;
-
- procedure Set_Postconditions_Proc (Id : E; V : E) is
- begin
- 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 (Id) in E_Array_Subtype
- | E_Record_Subtype
- | E_Record_Subtype_With_Private);
- Set_Node38 (Id, V);
- end Set_Predicated_Parent;
-
- procedure Set_Predicates_Ignored (Id : E; V : B) is
- begin
- pragma Assert (Is_Type (Id));
- Set_Flag288 (Id, V);
- end Set_Predicates_Ignored;
-
- procedure Set_Direct_Primitive_Operations (Id : E; V : L) is
- begin
- pragma Assert (Is_Tagged_Type (Id));
- Set_Elist10 (Id, V);
- end Set_Direct_Primitive_Operations;
-
- procedure Set_Prival (Id : E; V : E) is
- begin
- pragma Assert (Is_Protected_Component (Id));
- Set_Node17 (Id, V);
- end Set_Prival;
-
- procedure Set_Prival_Link (Id : E; V : E) is
- begin
- pragma Assert (Ekind (Id) in E_Constant | E_Variable);
- Set_Node20 (Id, V);
- end Set_Prival_Link;
-
- procedure Set_Private_Dependents (Id : E; V : L) is
- begin
- pragma Assert (Is_Incomplete_Or_Private_Type (Id));
- Set_Elist18 (Id, V);
- end Set_Private_Dependents;
-
- procedure Set_Prev_Entity (Id : E; V : E) is
- begin
- Set_Node36 (Id, V);
- end Set_Prev_Entity;
-
- procedure Set_Protected_Body_Subprogram (Id : E; V : E) is
- begin
- pragma Assert (Is_Subprogram_Or_Entry (Id));
- Set_Node11 (Id, V);
- end Set_Protected_Body_Subprogram;
-
- procedure Set_Protected_Formal (Id : E; V : E) is
- begin
- pragma Assert (Is_Formal (Id));
- Set_Node22 (Id, V);
- end Set_Protected_Formal;
-
- procedure Set_Protected_Subprogram (Id : E; V : E) is
- begin
- 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 (Id) in E_Entry
- | E_Entry_Family
- | E_Function
- | E_Procedure);
- Set_Node23 (Id, V);
- end Set_Protection_Object;
-
- procedure Set_Reachable (Id : E; V : B := True) is
- begin
- Set_Flag49 (Id, V);
- end Set_Reachable;
-
- procedure Set_Receiving_Entry (Id : E; V : E) is
- begin
- pragma Assert (Ekind (Id) = E_Procedure);
- Set_Node19 (Id, V);
- end Set_Receiving_Entry;
-
- procedure Set_Referenced (Id : E; V : B := True) is
- begin
- Set_Flag156 (Id, V);
- end Set_Referenced;
-
- procedure Set_Referenced_As_LHS (Id : E; V : B := True) is
- begin
- Set_Flag36 (Id, V);
- end Set_Referenced_As_LHS;
-
- procedure Set_Referenced_As_Out_Parameter (Id : E; V : B := True) is
- begin
- Set_Flag227 (Id, V);
- end Set_Referenced_As_Out_Parameter;
-
- procedure Set_Refinement_Constituents (Id : E; V : L) is
- begin
- pragma Assert (Ekind (Id) = E_Abstract_State);
- Set_Elist8 (Id, V);
- end Set_Refinement_Constituents;
-
- procedure Set_Register_Exception_Call (Id : E; V : N) is
- begin
- pragma Assert (Ekind (Id) = E_Exception);
- Set_Node20 (Id, V);
- end Set_Register_Exception_Call;
-
- procedure Set_Related_Array_Object (Id : E; V : E) is
- begin
- pragma Assert (Is_Array_Type (Id));
- Set_Node25 (Id, V);
- end Set_Related_Array_Object;
-
- procedure Set_Related_Expression (Id : E; V : N) is
- begin
- pragma Assert
- (Ekind (Id) in
- Type_Kind | E_Constant | E_Variable | E_Function | E_Void);
- Set_Node24 (Id, V);
- end Set_Related_Expression;
-
- procedure Set_Related_Instance (Id : E; V : E) is
- begin
- 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 (Id) in E_Component | E_Constant | E_Variable);
- Set_Node27 (Id, V);
- end Set_Related_Type;
-
- procedure Set_Relative_Deadline_Variable (Id : E; V : E) is
- begin
- pragma Assert (Is_Task_Type (Id) and then Is_Base_Type (Id));
- Set_Node28 (Id, V);
- end Set_Relative_Deadline_Variable;
-
- procedure Set_Renamed_Entity (Id : E; V : N) is
- begin
- Set_Node18 (Id, V);
- end Set_Renamed_Entity;
-
- procedure Set_Renamed_In_Spec (Id : E; V : B := True) is
- begin
- pragma Assert (Ekind (Id) = E_Package);
- Set_Flag231 (Id, V);
- end Set_Renamed_In_Spec;
-
- procedure Set_Renamed_Object (Id : E; V : N) is
- begin
- Set_Node18 (Id, V);
- end Set_Renamed_Object;
-
- procedure Set_Renaming_Map (Id : E; V : U) is
- begin
- Set_Uint9 (Id, V);
- end Set_Renaming_Map;
-
- procedure Set_Requires_Overriding (Id : E; V : B := True) is
- begin
- pragma Assert (Is_Overloadable (Id));
- Set_Flag213 (Id, V);
- end Set_Requires_Overriding;
-
- procedure Set_Return_Present (Id : E; V : B := True) is
- begin
- Set_Flag54 (Id, V);
- end Set_Return_Present;
-
- procedure Set_Return_Applies_To (Id : E; V : N) is
- begin
- Set_Node8 (Id, V);
- end Set_Return_Applies_To;
-
- procedure Set_Returns_By_Ref (Id : E; V : B := True) is
- begin
- Set_Flag90 (Id, V);
- end Set_Returns_By_Ref;
-
- procedure Set_Reverse_Bit_Order (Id : E; V : B := True) is
- begin
- pragma Assert
- (Is_Record_Type (Id) and then Is_Base_Type (Id));
- Set_Flag164 (Id, V);
- end Set_Reverse_Bit_Order;
-
- procedure Set_Reverse_Storage_Order (Id : E; V : B := True) is
- begin
- pragma Assert
- (Is_Base_Type (Id)
- and then (Is_Record_Type (Id) or else Is_Array_Type (Id)));
- Set_Flag93 (Id, V);
- end Set_Reverse_Storage_Order;
-
- procedure Set_Rewritten_For_C (Id : E; V : B := True) is
- begin
- pragma Assert (Ekind (Id) = E_Function);
- Set_Flag287 (Id, V);
- end Set_Rewritten_For_C;
-
- procedure Set_RM_Size (Id : E; V : U) is
- begin
- pragma Assert (Is_Type (Id));
- Set_Uint13 (Id, V);
- end Set_RM_Size;
-
- procedure Set_Scalar_Range (Id : E; V : N) is
- begin
- Set_Node20 (Id, V);
- end Set_Scalar_Range;
-
- procedure Set_Scale_Value (Id : E; V : U) is
- begin
- Set_Uint16 (Id, V);
- end Set_Scale_Value;
-
- procedure Set_Scope_Depth_Value (Id : E; V : U) is
- begin
- pragma Assert
- (Ekind (Id) in
- Concurrent_Kind | Entry_Kind | Generic_Unit_Kind |
- E_Package | E_Package_Body | Subprogram_Kind |
- E_Block | E_Subprogram_Body |
- E_Private_Type .. E_Limited_Private_Subtype |
- E_Void | E_Loop | E_Return_Statement);
- Set_Uint22 (Id, V);
- end Set_Scope_Depth_Value;
-
- procedure Set_Sec_Stack_Needed_For_Return (Id : E; V : B := True) is
- begin
- Set_Flag167 (Id, V);
- end Set_Sec_Stack_Needed_For_Return;
-
- procedure Set_Shared_Var_Procs_Instance (Id : E; V : E) is
- begin
- pragma Assert (Ekind (Id) = E_Variable);
- Set_Node22 (Id, V);
- end Set_Shared_Var_Procs_Instance;
-
- procedure Set_Size_Check_Code (Id : E; V : N) is
- begin
- pragma Assert (Ekind (Id) in E_Constant | E_Variable);
- Set_Node19 (Id, V);
- end Set_Size_Check_Code;
-
- procedure Set_Size_Depends_On_Discriminant (Id : E; V : B := True) is
- begin
- Set_Flag177 (Id, V);
- end Set_Size_Depends_On_Discriminant;
-
- procedure Set_Size_Known_At_Compile_Time (Id : E; V : B := True) is
- begin
- Set_Flag92 (Id, V);
- end Set_Size_Known_At_Compile_Time;
-
- procedure Set_Small_Value (Id : E; V : R) is
- begin
- pragma Assert (Is_Fixed_Point_Type (Id));
- Set_Ureal21 (Id, V);
- end Set_Small_Value;
-
- procedure Set_SPARK_Aux_Pragma (Id : E; V : N) is
- begin
- pragma Assert
- (Ekind (Id) in E_Protected_Type -- concurrent types
- | E_Task_Type
- or else
- 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 (Id) in E_Protected_Type -- concurrent types
- | E_Task_Type
- or else
- 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 (Id) in E_Constant -- objects
- | E_Variable
- or else
- 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 (Id) in E_Generic_Package -- packages
- | E_Package
- | E_Package_Body
- or else
- Ekind (Id) = E_Void -- special purpose
- or else
- Ekind (Id) in E_Protected_Body -- types
- | E_Task_Body
- or else
- Is_Type (Id));
- Set_Node40 (Id, V);
- end Set_SPARK_Pragma;
-
- procedure Set_SPARK_Pragma_Inherited (Id : E; V : B := True) is
- begin
- pragma Assert
- (Ekind (Id) in E_Constant -- objects
- | E_Variable
- or else
- 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 (Id) in E_Generic_Package -- packages
- | E_Package
- | E_Package_Body
- or else
- Ekind (Id) = E_Void -- special purpose
- or else
- Ekind (Id) in E_Protected_Body -- types
- | E_Task_Body
- or else
- Is_Type (Id));
- Set_Flag265 (Id, V);
- end Set_SPARK_Pragma_Inherited;
-
- procedure Set_Spec_Entity (Id : E; V : E) is
- begin
- pragma Assert (Ekind (Id) = E_Package_Body or else Is_Formal (Id));
- Set_Node19 (Id, V);
- end Set_Spec_Entity;
-
- procedure Set_SSO_Set_High_By_Default (Id : E; V : B := True) is
- begin
- pragma Assert
- (Is_Base_Type (Id)
- and then (Is_Record_Type (Id) or else Is_Array_Type (Id)));
- Set_Flag273 (Id, V);
- end Set_SSO_Set_High_By_Default;
-
- procedure Set_SSO_Set_Low_By_Default (Id : E; V : B := True) is
- begin
- pragma Assert
- (Is_Base_Type (Id)
- and then (Is_Record_Type (Id) or else Is_Array_Type (Id)));
- Set_Flag272 (Id, V);
- end Set_SSO_Set_Low_By_Default;
-
- procedure Set_Static_Discrete_Predicate (Id : E; V : S) is
- begin
- pragma Assert (Is_Discrete_Type (Id) and then Has_Predicates (Id));
- Set_List25 (Id, V);
- end Set_Static_Discrete_Predicate;
-
- procedure Set_Static_Real_Or_String_Predicate (Id : E; V : N) is
- begin
- pragma Assert ((Is_Real_Type (Id) or else Is_String_Type (Id))
- and then Has_Predicates (Id));
- Set_Node25 (Id, V);
- end Set_Static_Real_Or_String_Predicate;
-
- procedure Set_Status_Flag_Or_Transient_Decl (Id : E; V : E) is
- begin
- pragma Assert (Ekind (Id) in E_Constant
- | E_Loop_Parameter
- | E_Variable);
- Set_Node15 (Id, V);
- end Set_Status_Flag_Or_Transient_Decl;
-
- procedure Set_Storage_Size_Variable (Id : E; V : E) is
- begin
- pragma Assert (Is_Access_Type (Id) or else Is_Task_Type (Id));
- pragma Assert (Id = Base_Type (Id));
- Set_Node26 (Id, V);
- end Set_Storage_Size_Variable;
-
- procedure Set_Static_Elaboration_Desired (Id : E; V : B) is
- begin
- pragma Assert (Ekind (Id) = E_Package);
- Set_Flag77 (Id, V);
- end Set_Static_Elaboration_Desired;
-
- procedure Set_Static_Initialization (Id : E; V : N) is
- begin
- pragma Assert
- (Ekind (Id) = E_Procedure and then not Is_Dispatching_Operation (Id));
- Set_Node30 (Id, V);
- end Set_Static_Initialization;
-
- procedure Set_Stored_Constraint (Id : E; V : L) is
- begin
- pragma Assert (Nkind (Id) in N_Entity);
- Set_Elist23 (Id, V);
- end Set_Stored_Constraint;
-
- procedure Set_Stores_Attribute_Old_Prefix (Id : E; V : B := True) is
- begin
- pragma Assert (Is_Type (Id)
- or else (Ekind (Id) in E_Constant
- | E_Variable));
- Set_Flag270 (Id, V);
- end Set_Stores_Attribute_Old_Prefix;
-
- procedure Set_Strict_Alignment (Id : E; V : B := True) is
- begin
- pragma Assert (Id = Base_Type (Id));
- Set_Flag145 (Id, V);
- end Set_Strict_Alignment;
-
- procedure Set_String_Literal_Length (Id : E; V : U) is
- begin
- pragma Assert (Ekind (Id) = E_String_Literal_Subtype);
- Set_Uint16 (Id, V);
- end Set_String_Literal_Length;
-
- procedure Set_String_Literal_Low_Bound (Id : E; V : N) is
- begin
- pragma Assert (Ekind (Id) = E_String_Literal_Subtype);
- Set_Node18 (Id, V);
- end Set_String_Literal_Low_Bound;
-
- procedure Set_Subprograms_For_Type (Id : E; V : L) is
- begin
- pragma Assert (Is_Type (Id));
- Set_Elist29 (Id, V);
- end Set_Subprograms_For_Type;
-
- procedure Set_Subps_Index (Id : E; V : U) is
- begin
- pragma Assert (Is_Subprogram (Id));
- Set_Uint24 (Id, V);
- end Set_Subps_Index;
-
- procedure Set_Suppress_Elaboration_Warnings (Id : E; V : B := True) is
- begin
- Set_Flag303 (Id, V);
- end Set_Suppress_Elaboration_Warnings;
-
- procedure Set_Suppress_Initialization (Id : E; V : B := True) is
- begin
- pragma Assert (Is_Type (Id) or else Ekind (Id) = E_Variable);
- Set_Flag105 (Id, V);
- end Set_Suppress_Initialization;
-
- procedure Set_Suppress_Style_Checks (Id : E; V : B := True) is
- begin
- Set_Flag165 (Id, V);
- end Set_Suppress_Style_Checks;
-
- procedure Set_Suppress_Value_Tracking_On_Call (Id : E; V : B := True) is
- begin
- Set_Flag217 (Id, V);
- end Set_Suppress_Value_Tracking_On_Call;
-
- procedure Set_Task_Body_Procedure (Id : E; V : N) is
- begin
- pragma Assert (Ekind (Id) in Task_Kind);
- Set_Node25 (Id, V);
- end Set_Task_Body_Procedure;
-
- procedure Set_Thunk_Entity (Id : E; V : E) is
- begin
- pragma Assert (Ekind (Id) in E_Function | E_Procedure
- and then Is_Thunk (Id));
- Set_Node31 (Id, V);
- end Set_Thunk_Entity;
-
- procedure Set_Treat_As_Volatile (Id : E; V : B := True) is
- begin
- Set_Flag41 (Id, V);
- end Set_Treat_As_Volatile;
-
- procedure Set_Underlying_Full_View (Id : E; V : E) is
- begin
- pragma Assert (Ekind (Id) in Private_Kind);
- Set_Node19 (Id, V);
- end Set_Underlying_Full_View;
-
- procedure Set_Underlying_Record_View (Id : E; V : E) is
- begin
- pragma Assert (Ekind (Id) = E_Record_Type);
- Set_Node28 (Id, V);
- end Set_Underlying_Record_View;
-
- procedure Set_Universal_Aliasing (Id : E; V : B := True) is
- begin
- pragma Assert (Is_Type (Id) and then Is_Base_Type (Id));
- Set_Flag216 (Id, V);
- end Set_Universal_Aliasing;
-
- procedure Set_Unset_Reference (Id : E; V : N) is
- begin
- Set_Node16 (Id, V);
- end Set_Unset_Reference;
-
- procedure Set_Used_As_Generic_Actual (Id : E; V : B := True) is
- begin
- Set_Flag222 (Id, V);
- end Set_Used_As_Generic_Actual;
-
- procedure Set_Uses_Lock_Free (Id : E; V : B := True) is
- begin
- pragma Assert (Ekind (Id) = E_Protected_Type);
- Set_Flag188 (Id, V);
- end Set_Uses_Lock_Free;
-
- procedure Set_Uses_Sec_Stack (Id : E; V : B := True) is
- begin
- Set_Flag95 (Id, V);
- end Set_Uses_Sec_Stack;
-
- procedure Set_Validated_Object (Id : E; V : N) is
- begin
- pragma Assert (Ekind (Id) = E_Variable);
- Set_Node38 (Id, V);
- end Set_Validated_Object;
-
- procedure Set_Warnings_Off (Id : E; V : B := True) is
- begin
- Set_Flag96 (Id, V);
- end Set_Warnings_Off;
-
- procedure Set_Warnings_Off_Used (Id : E; V : B := True) is
- begin
- Set_Flag236 (Id, V);
- end Set_Warnings_Off_Used;
-
- procedure Set_Warnings_Off_Used_Unmodified (Id : E; V : B := True) is
- begin
- Set_Flag237 (Id, V);
- end Set_Warnings_Off_Used_Unmodified;
-
- procedure Set_Warnings_Off_Used_Unreferenced (Id : E; V : B := True) is
- begin
- Set_Flag238 (Id, V);
- end Set_Warnings_Off_Used_Unreferenced;
-
- procedure Set_Was_Hidden (Id : E; V : B := True) is
- begin
- Set_Flag196 (Id, V);
- end Set_Was_Hidden;
-
- procedure Set_Wrapped_Entity (Id : E; V : E) is
- begin
- pragma Assert (Ekind (Id) in E_Function | E_Procedure
- and then Is_Primitive_Wrapper (Id));
- Set_Node27 (Id, V);
- end Set_Wrapped_Entity;
-
- -----------------------------------
- -- Field Initialization Routines --
- -----------------------------------
-
- procedure Init_Alignment (Id : E) is
- begin
- Set_Uint14 (Id, Uint_0);
- end Init_Alignment;
-
- procedure Init_Alignment (Id : E; V : Int) is
- begin
- Set_Uint14 (Id, UI_From_Int (V));
- end Init_Alignment;
-
- procedure Init_Component_Bit_Offset (Id : E) is
- begin
- Set_Uint11 (Id, No_Uint);
- end Init_Component_Bit_Offset;
-
- procedure Init_Component_Bit_Offset (Id : E; V : Int) is
- begin
- Set_Uint11 (Id, UI_From_Int (V));
- end Init_Component_Bit_Offset;
-
- procedure Init_Component_Size (Id : E) is
- begin
- Set_Uint22 (Id, Uint_0);
- end Init_Component_Size;
-
- procedure Init_Component_Size (Id : E; V : Int) is
- begin
- Set_Uint22 (Id, UI_From_Int (V));
- end Init_Component_Size;
-
- procedure Init_Digits_Value (Id : E) is
- begin
- Set_Uint17 (Id, Uint_0);
- end Init_Digits_Value;
-
- procedure Init_Digits_Value (Id : E; V : Int) is
- begin
- Set_Uint17 (Id, UI_From_Int (V));
- end Init_Digits_Value;
-
- procedure Init_Esize (Id : E) is
- begin
- Set_Uint12 (Id, Uint_0);
- end Init_Esize;
-
- procedure Init_Esize (Id : E; V : Int) is
- begin
- Set_Uint12 (Id, UI_From_Int (V));
- end Init_Esize;
-
- procedure Init_Normalized_First_Bit (Id : E) is
- begin
- Set_Uint8 (Id, No_Uint);
- end Init_Normalized_First_Bit;
-
- procedure Init_Normalized_First_Bit (Id : E; V : Int) is
- begin
- Set_Uint8 (Id, UI_From_Int (V));
- end Init_Normalized_First_Bit;
-
- procedure Init_Normalized_Position (Id : E) is
- begin
- Set_Uint14 (Id, No_Uint);
- end Init_Normalized_Position;
-
- procedure Init_Normalized_Position (Id : E; V : Int) is
- begin
- Set_Uint14 (Id, UI_From_Int (V));
- end Init_Normalized_Position;
-
- procedure Init_Normalized_Position_Max (Id : E) is
- begin
- Set_Uint10 (Id, No_Uint);
- end Init_Normalized_Position_Max;
-
- procedure Init_Normalized_Position_Max (Id : E; V : Int) is
- begin
- Set_Uint10 (Id, UI_From_Int (V));
- end Init_Normalized_Position_Max;
-
- procedure Init_RM_Size (Id : E) is
- begin
- Set_Uint13 (Id, Uint_0);
- end Init_RM_Size;
-
- procedure Init_RM_Size (Id : E; V : Int) is
- begin
- Set_Uint13 (Id, UI_From_Int (V));
- end Init_RM_Size;
-
- -----------------------------
- -- Init_Component_Location --
- -----------------------------
-
- procedure Init_Component_Location (Id : E) is
- begin
- Set_Uint8 (Id, No_Uint); -- Normalized_First_Bit
- Set_Uint10 (Id, No_Uint); -- Normalized_Position_Max
- Set_Uint11 (Id, No_Uint); -- Component_Bit_Offset
- Set_Uint12 (Id, Uint_0); -- Esize
- Set_Uint14 (Id, No_Uint); -- Normalized_Position
- end Init_Component_Location;
-
- ----------------------------
- -- Init_Object_Size_Align --
- ----------------------------
-
- procedure Init_Object_Size_Align (Id : E) is
- begin
- Set_Uint12 (Id, Uint_0); -- Esize
- Set_Uint14 (Id, Uint_0); -- Alignment
- end Init_Object_Size_Align;
-
- ---------------
- -- Init_Size --
- ---------------
-
- procedure Init_Size (Id : E; V : Int) is
- begin
- pragma Assert (not Is_Object (Id));
- Set_Uint12 (Id, UI_From_Int (V)); -- Esize
- Set_Uint13 (Id, UI_From_Int (V)); -- RM_Size
- end Init_Size;
-
- ---------------------
- -- Init_Size_Align --
- ---------------------
-
- procedure Init_Size_Align (Id : E) is
- begin
- pragma Assert (not Is_Object (Id));
- Set_Uint12 (Id, Uint_0); -- Esize
- Set_Uint13 (Id, Uint_0); -- RM_Size
- Set_Uint14 (Id, Uint_0); -- Alignment
- end Init_Size_Align;
-
- ----------------------------------------------
- -- Type Representation Attribute Predicates --
- ----------------------------------------------
-
- function Known_Alignment (E : Entity_Id) return B is
- begin
- return Uint14 (E) /= Uint_0
- and then Uint14 (E) /= No_Uint;
- end Known_Alignment;
-
- function Known_Component_Bit_Offset (E : Entity_Id) return B is
- begin
- return Uint11 (E) /= No_Uint;
- end Known_Component_Bit_Offset;
-
- function Known_Component_Size (E : Entity_Id) return B is
- begin
- return Uint22 (Base_Type (E)) /= Uint_0
- and then Uint22 (Base_Type (E)) /= No_Uint;
- end Known_Component_Size;
-
- function Known_Esize (E : Entity_Id) return B is
- begin
- return Uint12 (E) /= Uint_0
- and then Uint12 (E) /= No_Uint;
- end Known_Esize;
-
- function Known_Normalized_First_Bit (E : Entity_Id) return B is
- begin
- return Uint8 (E) /= No_Uint;
- end Known_Normalized_First_Bit;
-
- function Known_Normalized_Position (E : Entity_Id) return B is
- begin
- return Uint14 (E) /= No_Uint;
- end Known_Normalized_Position;
-
- function Known_Normalized_Position_Max (E : Entity_Id) return B is
- begin
- return Uint10 (E) /= No_Uint;
- end Known_Normalized_Position_Max;
-
- function Known_RM_Size (E : Entity_Id) return B is
- begin
- return Uint13 (E) /= No_Uint
- and then (Uint13 (E) /= Uint_0
- or else Is_Discrete_Type (E)
- or else Is_Fixed_Point_Type (E));
- end Known_RM_Size;
-
- function Known_Static_Component_Bit_Offset (E : Entity_Id) return B is
- begin
- return Uint11 (E) /= No_Uint
- and then Uint11 (E) >= Uint_0;
- end Known_Static_Component_Bit_Offset;
-
- function Known_Static_Component_Size (E : Entity_Id) return B is
- begin
- return Uint22 (Base_Type (E)) > Uint_0;
- end Known_Static_Component_Size;
-
- function Known_Static_Esize (E : Entity_Id) return B is
- begin
- return Uint12 (E) > Uint_0
- and then not Is_Generic_Type (E);
- end Known_Static_Esize;
-
- function Known_Static_Normalized_First_Bit (E : Entity_Id) return B is
- begin
- return Uint8 (E) /= No_Uint
- and then Uint8 (E) >= Uint_0;
- end Known_Static_Normalized_First_Bit;
-
- function Known_Static_Normalized_Position (E : Entity_Id) return B is
- begin
- return Uint14 (E) /= No_Uint
- and then Uint14 (E) >= Uint_0;
- end Known_Static_Normalized_Position;
-
- function Known_Static_Normalized_Position_Max (E : Entity_Id) return B is
- begin
- return Uint10 (E) /= No_Uint
- and then Uint10 (E) >= Uint_0;
- end Known_Static_Normalized_Position_Max;
-
- function Known_Static_RM_Size (E : Entity_Id) return B is
- begin
- return (Uint13 (E) > Uint_0
- or else Is_Discrete_Type (E)
- or else Is_Fixed_Point_Type (E))
- and then not Is_Generic_Type (E);
- end Known_Static_RM_Size;
-
- function Unknown_Alignment (E : Entity_Id) return B is
- begin
- return Uint14 (E) = Uint_0
- or else Uint14 (E) = No_Uint;
- end Unknown_Alignment;
-
- function Unknown_Component_Bit_Offset (E : Entity_Id) return B is
- begin
- return Uint11 (E) = No_Uint;
- end Unknown_Component_Bit_Offset;
-
- function Unknown_Component_Size (E : Entity_Id) return B is
- begin
- return Uint22 (Base_Type (E)) = Uint_0
- or else
- Uint22 (Base_Type (E)) = No_Uint;
- end Unknown_Component_Size;
-
- function Unknown_Esize (E : Entity_Id) return B is
- begin
- return Uint12 (E) = No_Uint
- or else
- Uint12 (E) = Uint_0;
- end Unknown_Esize;
-
- function Unknown_Normalized_First_Bit (E : Entity_Id) return B is
- begin
- return Uint8 (E) = No_Uint;
- end Unknown_Normalized_First_Bit;
-
- function Unknown_Normalized_Position (E : Entity_Id) return B is
- begin
- return Uint14 (E) = No_Uint;
- end Unknown_Normalized_Position;
-
- function Unknown_Normalized_Position_Max (E : Entity_Id) return B is
- begin
- return Uint10 (E) = No_Uint;
- end Unknown_Normalized_Position_Max;
-
- function Unknown_RM_Size (E : Entity_Id) return B is
- begin
- return (Uint13 (E) = Uint_0
- and then not Is_Discrete_Type (E)
- and then not Is_Fixed_Point_Type (E))
- or else Uint13 (E) = No_Uint;
- end Unknown_RM_Size;
-
- --------------------
- -- Address_Clause --
- --------------------
-
- function Address_Clause (Id : E) return N is
- begin
- return Get_Attribute_Definition_Clause (Id, Attribute_Address);
- end Address_Clause;
-
- ---------------
- -- Aft_Value --
- ---------------
-
- function Aft_Value (Id : E) return U is
- Result : Nat := 1;
- Delta_Val : Ureal := Delta_Value (Id);
- begin
- while Delta_Val < Ureal_Tenth loop
- Delta_Val := Delta_Val * Ureal_10;
- Result := Result + 1;
- end loop;
-
- return UI_From_Int (Result);
- end Aft_Value;
-
- ----------------------
- -- Alignment_Clause --
- ----------------------
-
- function Alignment_Clause (Id : E) return N is
- begin
- return Get_Attribute_Definition_Clause (Id, Attribute_Alignment);
- end Alignment_Clause;
-
- -------------------
- -- Append_Entity --
- -------------------
-
- procedure Append_Entity (Id : Entity_Id; Scop : Entity_Id) is
- Last : constant Entity_Id := Last_Entity (Scop);
-
- begin
- Set_Scope (Id, Scop);
- Set_Prev_Entity (Id, Empty); -- Empty <-- Id
-
- -- The entity chain is empty
-
- if No (Last) then
- Set_First_Entity (Scop, Id);
-
- -- Otherwise the entity chain has at least one element
-
- else
- Link_Entities (Last, Id); -- Last <-- Id, Last --> Id
- end if;
-
- -- NOTE: The setting of the Next_Entity attribute of Id must happen
- -- here as opposed to at the beginning of the routine because doing
- -- so causes the binder to hang. It is not clear why ???
-
- Set_Next_Entity (Id, Empty); -- Id --> Empty
-
- Set_Last_Entity (Scop, Id);
- end Append_Entity;
-
- ---------------
- -- Base_Type --
- ---------------
-
- function Base_Type (Id : E) return E is
- begin
- if Is_Base_Type (Id) then
- return Id;
- else
- pragma Assert (Is_Type (Id));
- return Etype (Id);
- end if;
- end Base_Type;
-
- -------------------------
- -- Component_Alignment --
- -------------------------
-
- -- Component Alignment is encoded using two flags, Flag128/129 as
- -- follows. Note that both flags False = Align_Default, so that the
- -- default initialization of flags to False initializes component
- -- alignment to the default value as required.
-
- -- Flag128 Flag129 Value
- -- ------- ------- -----
- -- False False Calign_Default
- -- False True Calign_Component_Size
- -- True False Calign_Component_Size_4
- -- True True Calign_Storage_Unit
-
- function Component_Alignment (Id : E) return C is
- BT : constant Node_Id := Base_Type (Id);
-
- begin
- pragma Assert (Is_Array_Type (Id) or else Is_Record_Type (Id));
-
- if Flag128 (BT) then
- if Flag129 (BT) then
- return Calign_Storage_Unit;
- else
- return Calign_Component_Size_4;
- end if;
-
- else
- if Flag129 (BT) then
- return Calign_Component_Size;
- else
- return Calign_Default;
- end if;
- end if;
- end Component_Alignment;
-
- ----------------------
- -- Declaration_Node --
- ----------------------
-
- function Declaration_Node (Id : E) return N is
- P : Node_Id;
-
- begin
- if Ekind (Id) = E_Incomplete_Type
- and then Present (Full_View (Id))
- then
- P := Parent (Full_View (Id));
- else
- P := Parent (Id);
- end if;
-
- loop
- 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
- P := Parent (P);
- else
- return P;
- end if;
- end loop;
- end Declaration_Node;
-
- ---------------------
- -- Designated_Type --
- ---------------------
-
- function Designated_Type (Id : E) return E is
- Desig_Type : Entity_Id;
-
- begin
- Desig_Type := Directly_Designated_Type (Id);
-
- if Is_Incomplete_Type (Desig_Type)
- and then Present (Full_View (Desig_Type))
- then
- return Full_View (Desig_Type);
-
- elsif Is_Class_Wide_Type (Desig_Type)
- and then Is_Incomplete_Type (Etype (Desig_Type))
- and then Present (Full_View (Etype (Desig_Type)))
- and then Present (Class_Wide_Type (Full_View (Etype (Desig_Type))))
- then
- return Class_Wide_Type (Full_View (Etype (Desig_Type)));
-
- else
- return Desig_Type;
- end if;
- end Designated_Type;
-
- -------------------
- -- DIC_Procedure --
- -------------------
-
- function DIC_Procedure (Id : E) return E is
- Subp_Elmt : Elmt_Id;
- Subp_Id : Entity_Id;
- Subps : Elist_Id;
-
- begin
- pragma Assert (Is_Type (Id));
-
- Subps := Subprograms_For_Type (Base_Type (Id));
-
- if Present (Subps) then
- Subp_Elmt := First_Elmt (Subps);
- while Present (Subp_Elmt) loop
- Subp_Id := Node (Subp_Elmt);
-
- -- Currently the flag Is_DIC_Procedure is set for both normal DIC
- -- check procedures as well as for partial DIC check procedures,
- -- and we don't have a flag for the partial procedures.
-
- if Is_DIC_Procedure (Subp_Id)
- and then not Is_Partial_DIC_Procedure (Subp_Id)
- then
- return Subp_Id;
- end if;
-
- Next_Elmt (Subp_Elmt);
- end loop;
- end if;
-
- return Empty;
- end DIC_Procedure;
-
- ----------------------
- -- Entry_Index_Type --
- ----------------------
-
- function Entry_Index_Type (Id : E) return N is
- begin
- pragma Assert (Ekind (Id) = E_Entry_Family);
- return Etype (Discrete_Subtype_Definition (Parent (Id)));
- end Entry_Index_Type;
-
- ---------------------
- -- First_Component --
- ---------------------
-
- function First_Component (Id : E) return E is
- Comp_Id : Entity_Id;
-
- begin
- pragma Assert
- (Is_Concurrent_Type (Id)
- or else Is_Incomplete_Or_Private_Type (Id)
- or else Is_Record_Type (Id));
-
- Comp_Id := First_Entity (Id);
- while Present (Comp_Id) loop
- exit when Ekind (Comp_Id) = E_Component;
- Next_Entity (Comp_Id);
- end loop;
-
- return Comp_Id;
- end First_Component;
-
- -------------------------------------
- -- First_Component_Or_Discriminant --
- -------------------------------------
-
- function First_Component_Or_Discriminant (Id : E) return E is
- Comp_Id : Entity_Id;
-
- begin
- pragma Assert
- (Is_Concurrent_Type (Id)
- or else Is_Incomplete_Or_Private_Type (Id)
- or else Is_Record_Type (Id)
- or else Has_Discriminants (Id));
-
- Comp_Id := First_Entity (Id);
- while Present (Comp_Id) loop
- exit when Ekind (Comp_Id) in E_Component | E_Discriminant;
- Next_Entity (Comp_Id);
- end loop;
-
- return Comp_Id;
- end First_Component_Or_Discriminant;
-
- ------------------
- -- First_Formal --
- ------------------
-
- function First_Formal (Id : E) return E is
- Formal : Entity_Id;
-
- begin
- pragma Assert
- (Is_Generic_Subprogram (Id)
- or else Is_Overloadable (Id)
- or else Ekind (Id) in E_Entry_Family
- | E_Subprogram_Body
- | E_Subprogram_Type);
-
- if Ekind (Id) = E_Enumeration_Literal then
- return Empty;
-
- else
- Formal := First_Entity (Id);
-
- -- Deal with the common, non-generic case first
-
- if No (Formal) or else Is_Formal (Formal) then
- return Formal;
- end if;
-
- -- The first/next entity chain of a generic subprogram contains all
- -- generic formal parameters, followed by the formal parameters.
-
- if Is_Generic_Subprogram (Id) then
- while Present (Formal) and then not Is_Formal (Formal) loop
- Next_Entity (Formal);
- end loop;
- return Formal;
- else
- return Empty;
- end if;
- end if;
- end First_Formal;
-
- ------------------------------
- -- First_Formal_With_Extras --
- ------------------------------
-
- function First_Formal_With_Extras (Id : E) return E is
- Formal : Entity_Id;
-
- begin
- pragma Assert
- (Is_Generic_Subprogram (Id)
- or else Is_Overloadable (Id)
- or else Ekind (Id) in E_Entry_Family
- | E_Subprogram_Body
- | E_Subprogram_Type);
-
- if Ekind (Id) = E_Enumeration_Literal then
- return Empty;
-
- else
- Formal := First_Entity (Id);
-
- -- The first/next entity chain of a generic subprogram contains all
- -- generic formal parameters, followed by the formal parameters. Go
- -- directly to the parameters by skipping the formal part.
-
- if Is_Generic_Subprogram (Id) then
- while Present (Formal) and then not Is_Formal (Formal) loop
- Next_Entity (Formal);
- end loop;
- end if;
-
- if Present (Formal) and then Is_Formal (Formal) then
- return Formal;
- else
- return Extra_Formals (Id); -- Empty if no extra formals
- end if;
- end if;
- end First_Formal_With_Extras;
-
- -------------------------------------
- -- Get_Attribute_Definition_Clause --
- -------------------------------------
-
- function Get_Attribute_Definition_Clause
- (E : Entity_Id;
- Id : Attribute_Id) return Node_Id
- is
- N : Node_Id;
-
- begin
- N := First_Rep_Item (E);
- while Present (N) loop
- if Nkind (N) = N_Attribute_Definition_Clause
- and then Get_Attribute_Id (Chars (N)) = Id
- then
- return N;
- else
- Next_Rep_Item (N);
- end if;
- end loop;
-
- return Empty;
- end Get_Attribute_Definition_Clause;
-
- ---------------------------
- -- Get_Class_Wide_Pragma --
- ---------------------------
-
- function Get_Class_Wide_Pragma
- (E : Entity_Id;
- Id : Pragma_Id) return Node_Id
- is
- Item : Node_Id;
- Items : Node_Id;
-
- begin
- Items := Contract (E);
-
- if No (Items) then
- return Empty;
- end if;
-
- Item := Pre_Post_Conditions (Items);
- while Present (Item) loop
- if Nkind (Item) = N_Pragma
- and then Get_Pragma_Id (Pragma_Name_Unmapped (Item)) = Id
- and then Class_Present (Item)
- then
- return Item;
- end if;
-
- Item := Next_Pragma (Item);
- end loop;
-
- return Empty;
- end Get_Class_Wide_Pragma;
-
- -------------------
- -- Get_Full_View --
- -------------------
-
- function Get_Full_View (T : Entity_Id) return Entity_Id is
- begin
- if Is_Incomplete_Type (T) and then Present (Full_View (T)) then
- return Full_View (T);
-
- elsif Is_Class_Wide_Type (T)
- and then Is_Incomplete_Type (Root_Type (T))
- and then Present (Full_View (Root_Type (T)))
- then
- return Class_Wide_Type (Full_View (Root_Type (T)));
-
- else
- return T;
- end if;
- end Get_Full_View;
-
- ----------------
- -- Get_Pragma --
- ----------------
-
- function Get_Pragma (E : Entity_Id; Id : Pragma_Id) return Node_Id is
-
- -- Classification pragmas
-
- Is_CLS : constant Boolean :=
- Id = Pragma_Abstract_State or else
- Id = Pragma_Attach_Handler or else
- Id = Pragma_Async_Readers or else
- Id = Pragma_Async_Writers or else
- Id = Pragma_Constant_After_Elaboration or else
- Id = Pragma_Depends or else
- Id = Pragma_Effective_Reads or else
- Id = Pragma_Effective_Writes or else
- Id = Pragma_Extensions_Visible or else
- Id = Pragma_Global or else
- Id = Pragma_Initial_Condition or else
- Id = Pragma_Initializes or else
- Id = Pragma_Interrupt_Handler or else
- Id = Pragma_No_Caching or else
- Id = Pragma_Part_Of or else
- Id = Pragma_Refined_Depends or else
- Id = Pragma_Refined_Global or else
- Id = Pragma_Refined_State or else
- Id = Pragma_Volatile_Function;
-
- -- Contract / subprogram variant / test case pragmas
-
- Is_CTC : constant Boolean :=
- Id = Pragma_Contract_Cases or else
- Id = Pragma_Subprogram_Variant or else
- Id = Pragma_Test_Case;
-
- -- Pre / postcondition pragmas
-
- Is_PPC : constant Boolean :=
- Id = Pragma_Precondition or else
- Id = Pragma_Postcondition or else
- Id = Pragma_Refined_Post;
-
- In_Contract : constant Boolean := Is_CLS or Is_CTC or Is_PPC;
-
- Item : Node_Id;
- Items : Node_Id;
-
- begin
- -- Handle pragmas that appear in N_Contract nodes. Those have to be
- -- extracted from their specialized list.
-
- if In_Contract then
- Items := Contract (E);
-
- if No (Items) then
- return Empty;
-
- elsif Is_CLS then
- Item := Classifications (Items);
-
- elsif Is_CTC then
- Item := Contract_Test_Cases (Items);
-
- else
- Item := Pre_Post_Conditions (Items);
- end if;
-
- -- Regular pragmas
-
- else
- Item := First_Rep_Item (E);
- end if;
-
- while Present (Item) loop
- if Nkind (Item) = N_Pragma
- and then Get_Pragma_Id (Pragma_Name_Unmapped (Item)) = Id
- then
- return Item;
-
- -- All nodes in N_Contract are chained using Next_Pragma
-
- elsif In_Contract then
- Item := Next_Pragma (Item);
-
- -- Regular pragmas
-
- else
- Next_Rep_Item (Item);
- end if;
- end loop;
-
- return Empty;
- end Get_Pragma;
-
- --------------------------------------
- -- Get_Record_Representation_Clause --
- --------------------------------------
-
- function Get_Record_Representation_Clause (E : Entity_Id) return Node_Id is
- N : Node_Id;
-
- begin
- N := First_Rep_Item (E);
- while Present (N) loop
- if Nkind (N) = N_Record_Representation_Clause then
- return N;
- end if;
-
- Next_Rep_Item (N);
- end loop;
-
- return Empty;
- end Get_Record_Representation_Clause;
-
- ------------------------
- -- Has_Attach_Handler --
- ------------------------
-
- function Has_Attach_Handler (Id : E) return B is
- Ritem : Node_Id;
-
- begin
- pragma Assert (Is_Protected_Type (Id));
-
- Ritem := First_Rep_Item (Id);
- while Present (Ritem) loop
- if Nkind (Ritem) = N_Pragma
- and then Pragma_Name (Ritem) = Name_Attach_Handler
- then
- return True;
- else
- Next_Rep_Item (Ritem);
- end if;
- end loop;
-
- return False;
- end Has_Attach_Handler;
-
- -------------
- -- Has_DIC --
- -------------
-
- function Has_DIC (Id : E) return B is
- begin
- return Has_Own_DIC (Id) or else Has_Inherited_DIC (Id);
- end Has_DIC;
-
- -----------------
- -- Has_Entries --
- -----------------
-
- function Has_Entries (Id : E) return B is
- Ent : Entity_Id;
-
- begin
- pragma Assert (Is_Concurrent_Type (Id));
-
- Ent := First_Entity (Id);
- while Present (Ent) loop
- if Is_Entry (Ent) then
- return True;
- end if;
-
- Next_Entity (Ent);
- end loop;
-
- return False;
- end Has_Entries;
-
- ----------------------------
- -- Has_Foreign_Convention --
- ----------------------------
-
- function Has_Foreign_Convention (Id : E) return B is
- begin
- -- While regular Intrinsics such as the Standard operators fit in the
- -- "Ada" convention, those with an Interface_Name materialize GCC
- -- builtin imports for which Ada special treatments shouldn't apply.
-
- return Convention (Id) in Foreign_Convention
- or else (Convention (Id) = Convention_Intrinsic
- and then Present (Interface_Name (Id)));
- end Has_Foreign_Convention;
-
- ---------------------------
- -- Has_Interrupt_Handler --
- ---------------------------
-
- function Has_Interrupt_Handler (Id : E) return B is
- Ritem : Node_Id;
-
- begin
- pragma Assert (Is_Protected_Type (Id));
-
- Ritem := First_Rep_Item (Id);
- while Present (Ritem) loop
- if Nkind (Ritem) = N_Pragma
- and then Pragma_Name (Ritem) = Name_Interrupt_Handler
- then
- return True;
- else
- Next_Rep_Item (Ritem);
- end if;
- end loop;
-
- return False;
- end Has_Interrupt_Handler;
-
- --------------------
- -- Has_Invariants --
- --------------------
-
- function Has_Invariants (Id : E) return B is
- begin
- return Has_Own_Invariants (Id) or else Has_Inherited_Invariants (Id);
- end Has_Invariants;
-
- --------------------------
- -- Has_Limited_View --
- --------------------------
-
- function Has_Limited_View (Id : E) return B is
- begin
- return Ekind (Id) = E_Package
- and then not Is_Generic_Instance (Id)
- and then Present (Limited_View (Id));
- end Has_Limited_View;
-
- --------------------------
- -- Has_Non_Limited_View --
- --------------------------
-
- function Has_Non_Limited_View (Id : E) return B is
- begin
- return (Ekind (Id) in Incomplete_Kind
- or else Ekind (Id) in Class_Wide_Kind
- or else Ekind (Id) = E_Abstract_State)
- and then Present (Non_Limited_View (Id));
- end Has_Non_Limited_View;
-
- ---------------------------------
- -- Has_Non_Null_Abstract_State --
- ---------------------------------
-
- function Has_Non_Null_Abstract_State (Id : E) return B is
- begin
- pragma Assert (Is_Package_Or_Generic_Package (Id));
-
- return
- Present (Abstract_States (Id))
- and then
- not Is_Null_State (Node (First_Elmt (Abstract_States (Id))));
- end Has_Non_Null_Abstract_State;
-
- -------------------------------------
- -- Has_Non_Null_Visible_Refinement --
- -------------------------------------
-
- function Has_Non_Null_Visible_Refinement (Id : E) return B is
- Constits : Elist_Id;
-
- begin
- -- "Refinement" is a concept applicable only to abstract states
-
- pragma Assert (Ekind (Id) = E_Abstract_State);
- Constits := Refinement_Constituents (Id);
-
- -- A partial refinement is always non-null. For a full refinement to be
- -- non-null, the first constituent must be anything other than null.
-
- return
- Has_Partial_Visible_Refinement (Id)
- or else (Has_Visible_Refinement (Id)
- and then Present (Constits)
- and then Nkind (Node (First_Elmt (Constits))) /= N_Null);
- end Has_Non_Null_Visible_Refinement;
-
- -----------------------------
- -- Has_Null_Abstract_State --
- -----------------------------
-
- function Has_Null_Abstract_State (Id : E) return B is
- pragma Assert (Is_Package_Or_Generic_Package (Id));
-
- States : constant Elist_Id := Abstract_States (Id);
-
- begin
- -- Check first available state of related package. A null abstract
- -- state always appears as the sole element of the state list.
-
- return
- Present (States)
- and then Is_Null_State (Node (First_Elmt (States)));
- end Has_Null_Abstract_State;
-
- ---------------------------------
- -- Has_Null_Visible_Refinement --
- ---------------------------------
-
- function Has_Null_Visible_Refinement (Id : E) return B is
- Constits : Elist_Id;
-
- begin
- -- "Refinement" is a concept applicable only to abstract states
-
- pragma Assert (Ekind (Id) = E_Abstract_State);
- Constits := Refinement_Constituents (Id);
-
- -- For a refinement to be null, the state's sole constituent must be a
- -- null.
-
- return
- Has_Visible_Refinement (Id)
- and then Present (Constits)
- and then Nkind (Node (First_Elmt (Constits))) = N_Null;
- end Has_Null_Visible_Refinement;
-
- --------------------
- -- Has_Unmodified --
- --------------------
-
- function Has_Unmodified (E : Entity_Id) return Boolean is
- begin
- if Has_Pragma_Unmodified (E) then
- return True;
- elsif Warnings_Off (E) then
- Set_Warnings_Off_Used_Unmodified (E);
- return True;
- else
- return False;
- end if;
- end Has_Unmodified;
-
- ---------------------
- -- Has_Unreferenced --
- ---------------------
-
- function Has_Unreferenced (E : Entity_Id) return Boolean is
- begin
- if Has_Pragma_Unreferenced (E) then
- return True;
- elsif Warnings_Off (E) then
- Set_Warnings_Off_Used_Unreferenced (E);
- return True;
- else
- return False;
- end if;
- end Has_Unreferenced;
-
- ----------------------
- -- Has_Warnings_Off --
- ----------------------
-
- function Has_Warnings_Off (E : Entity_Id) return Boolean is
- begin
- if Warnings_Off (E) then
- Set_Warnings_Off_Used (E);
- return True;
- else
- return False;
- end if;
- end Has_Warnings_Off;
-
- ------------------------------
- -- Implementation_Base_Type --
- ------------------------------
-
- function Implementation_Base_Type (Id : E) return E is
- Bastyp : Entity_Id;
- Imptyp : Entity_Id;
-
- begin
- Bastyp := Base_Type (Id);
-
- if Is_Incomplete_Or_Private_Type (Bastyp) then
- Imptyp := Underlying_Type (Bastyp);
-
- -- If we have an implementation type, then just return it,
- -- otherwise we return the Base_Type anyway. This can only
- -- happen in error situations and should avoid some error bombs.
-
- if Present (Imptyp) then
- return Base_Type (Imptyp);
- else
- return Bastyp;
- end if;
-
- else
- return Bastyp;
- end if;
- end Implementation_Base_Type;
-
- -------------------------
- -- Invariant_Procedure --
- -------------------------
-
- function Invariant_Procedure (Id : E) return E is
- Subp_Elmt : Elmt_Id;
- Subp_Id : Entity_Id;
- Subps : Elist_Id;
-
- begin
- pragma Assert (Is_Type (Id));
-
- Subps := Subprograms_For_Type (Base_Type (Id));
-
- if Present (Subps) then
- Subp_Elmt := First_Elmt (Subps);
- while Present (Subp_Elmt) loop
- Subp_Id := Node (Subp_Elmt);
-
- if Is_Invariant_Procedure (Subp_Id) then
- return Subp_Id;
- end if;
-
- Next_Elmt (Subp_Elmt);
- end loop;
- end if;
-
- return Empty;
- end Invariant_Procedure;
-
- ------------------
- -- Is_Base_Type --
- ------------------
-
- -- Global flag table allowing rapid computation of this function
-
- Entity_Is_Base_Type : constant array (Entity_Kind) of Boolean :=
- (E_Enumeration_Subtype |
- E_Incomplete_Subtype |
- E_Signed_Integer_Subtype |
- E_Modular_Integer_Subtype |
- E_Floating_Point_Subtype |
- E_Ordinary_Fixed_Point_Subtype |
- E_Decimal_Fixed_Point_Subtype |
- E_Array_Subtype |
- E_Record_Subtype |
- E_Private_Subtype |
- E_Record_Subtype_With_Private |
- E_Limited_Private_Subtype |
- E_Access_Subtype |
- E_Protected_Subtype |
- E_Task_Subtype |
- E_String_Literal_Subtype |
- E_Class_Wide_Subtype => False,
- others => True);
-
- function Is_Base_Type (Id : E) return Boolean is
- begin
- return Entity_Is_Base_Type (Ekind (Id));
- end Is_Base_Type;
-
- ---------------------
- -- Is_Boolean_Type --
- ---------------------
-
- function Is_Boolean_Type (Id : E) return B is
- begin
- return Root_Type (Id) = Standard_Boolean;
- end Is_Boolean_Type;
-
- ------------------------
- -- Is_Constant_Object --
- ------------------------
-
- function Is_Constant_Object (Id : E) return B is
- begin
- return Ekind (Id) in E_Constant | E_In_Parameter | E_Loop_Parameter;
- end Is_Constant_Object;
-
- -------------------
- -- Is_Controlled --
- -------------------
-
- function Is_Controlled (Id : E) return B is
- begin
- return Is_Controlled_Active (Id) and then not Disable_Controlled (Id);
- end Is_Controlled;
-
- --------------------
- -- Is_Discriminal --
- --------------------
-
- function Is_Discriminal (Id : E) return B is
- begin
- return Ekind (Id) in E_Constant | E_In_Parameter
- and then Present (Discriminal_Link (Id));
- end Is_Discriminal;
-
- ----------------------
- -- Is_Dynamic_Scope --
- ----------------------
-
- function Is_Dynamic_Scope (Id : E) return B is
- begin
- return
- Ekind (Id) = E_Block
- or else
- Ekind (Id) = E_Function
- or else
- Ekind (Id) = E_Procedure
- or else
- Ekind (Id) = E_Subprogram_Body
- or else
- Ekind (Id) = E_Task_Type
- or else
- (Ekind (Id) = E_Limited_Private_Type
- and then Present (Full_View (Id))
- and then Ekind (Full_View (Id)) = E_Task_Type)
- or else
- Ekind (Id) = E_Entry
- or else
- Ekind (Id) = E_Entry_Family
- or else
- Ekind (Id) = E_Return_Statement;
- end Is_Dynamic_Scope;
-
- --------------------
- -- Is_Entity_Name --
- --------------------
-
- function Is_Entity_Name (N : Node_Id) return Boolean is
- Kind : constant Node_Kind := Nkind (N);
-
- begin
- -- Identifiers, operator symbols, expanded names are entity names
-
- return Kind in N_Identifier | N_Operator_Symbol | N_Expanded_Name
-
- -- Attribute references are entity names if they refer to an entity.
- -- Note that we don't do this by testing for the presence of the
- -- Entity field in the N_Attribute_Reference node, since it may not
- -- have been set yet.
-
- or else (Kind = N_Attribute_Reference
- and then Is_Entity_Attribute_Name (Attribute_Name (N)));
- end Is_Entity_Name;
-
- ---------------------------
- -- Is_Elaboration_Target --
- ---------------------------
-
- function Is_Elaboration_Target (Id : Entity_Id) return Boolean is
- begin
- return
- Ekind (Id) in E_Constant | E_Package | E_Variable
- or else Is_Generic_Unit (Id)
- or else Is_Subprogram_Or_Entry (Id)
- or else Is_Task_Type (Id);
- end Is_Elaboration_Target;
-
- -----------------------
- -- Is_External_State --
- -----------------------
-
- function Is_External_State (Id : E) return B is
- begin
- -- To qualify, the abstract state must appear with option "external" or
- -- "synchronous" (SPARK RM 7.1.4(7) and (9)).
-
- return
- Ekind (Id) = E_Abstract_State
- and then (Has_Option (Id, Name_External)
- or else
- Has_Option (Id, Name_Synchronous));
- end Is_External_State;
-
- ------------------
- -- Is_Finalizer --
- ------------------
-
- function Is_Finalizer (Id : E) return B is
- begin
- return Ekind (Id) = E_Procedure and then Chars (Id) = Name_uFinalizer;
- end Is_Finalizer;
-
- ----------------------
- -- Is_Full_Access --
- ----------------------
-
- function Is_Full_Access (Id : E) return B is
- begin
- return Is_Atomic (Id) or else Is_Volatile_Full_Access (Id);
- end Is_Full_Access;
-
- -------------------
- -- Is_Null_State --
- -------------------
-
- function Is_Null_State (Id : E) return B is
- begin
- return
- 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 --
- ---------------------
-
- function Is_Packed_Array (Id : E) return B is
- begin
- return Is_Array_Type (Id) and then Is_Packed (Id);
- end Is_Packed_Array;
-
- ---------------
- -- Is_Prival --
- ---------------
-
- function Is_Prival (Id : E) return B is
- begin
- return Ekind (Id) in E_Constant | E_Variable
- and then Present (Prival_Link (Id));
- end Is_Prival;
-
- ----------------------------
- -- Is_Protected_Component --
- ----------------------------
-
- function Is_Protected_Component (Id : E) return B is
- begin
- return Ekind (Id) = E_Component and then Is_Protected_Type (Scope (Id));
- end Is_Protected_Component;
-
- ----------------------------
- -- Is_Protected_Interface --
- ----------------------------
-
- function Is_Protected_Interface (Id : E) return B is
- Typ : constant Entity_Id := Base_Type (Id);
- begin
- if not Is_Interface (Typ) then
- return False;
- elsif Is_Class_Wide_Type (Typ) then
- return Is_Protected_Interface (Etype (Typ));
- else
- return Protected_Present (Type_Definition (Parent (Typ)));
- end if;
- end Is_Protected_Interface;
-
- ------------------------------
- -- Is_Protected_Record_Type --
- ------------------------------
-
- function Is_Protected_Record_Type (Id : E) return B is
- begin
- return
- Is_Concurrent_Record_Type (Id)
- 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 --
- --------------------------------
-
- function Is_Standard_Character_Type (Id : E) return B is
- begin
- return Is_Type (Id)
- and then Root_Type (Id) in Standard_Character
- | Standard_Wide_Character
- | Standard_Wide_Wide_Character;
- end Is_Standard_Character_Type;
-
- -----------------------------
- -- Is_Standard_String_Type --
- -----------------------------
-
- function Is_Standard_String_Type (Id : E) return B is
- begin
- return Is_Type (Id)
- and then Root_Type (Id) in Standard_String
- | Standard_Wide_String
- | Standard_Wide_Wide_String;
- end Is_Standard_String_Type;
-
- --------------------
- -- Is_String_Type --
- --------------------
-
- function Is_String_Type (Id : E) return B is
- begin
- return Is_Array_Type (Id)
- and then Id /= Any_Composite
- and then Number_Dimensions (Id) = 1
- and then Is_Character_Type (Component_Type (Id));
- end Is_String_Type;
-
- -------------------------------
- -- Is_Synchronized_Interface --
- -------------------------------
-
- function Is_Synchronized_Interface (Id : E) return B is
- Typ : constant Entity_Id := Base_Type (Id);
-
- begin
- if not Is_Interface (Typ) then
- return False;
-
- elsif Is_Class_Wide_Type (Typ) then
- return Is_Synchronized_Interface (Etype (Typ));
-
- else
- return Protected_Present (Type_Definition (Parent (Typ)))
- or else Synchronized_Present (Type_Definition (Parent (Typ)))
- or else Task_Present (Type_Definition (Parent (Typ)));
- end if;
- end Is_Synchronized_Interface;
-
- ---------------------------
- -- Is_Synchronized_State --
- ---------------------------
-
- function Is_Synchronized_State (Id : E) return B is
- begin
- -- To qualify, the abstract state must appear with simple option
- -- "synchronous" (SPARK RM 7.1.4(9)).
-
- return
- Ekind (Id) = E_Abstract_State
- and then Has_Option (Id, Name_Synchronous);
- end Is_Synchronized_State;
-
- -----------------------
- -- Is_Task_Interface --
- -----------------------
-
- function Is_Task_Interface (Id : E) return B is
- Typ : constant Entity_Id := Base_Type (Id);
- begin
- if not Is_Interface (Typ) then
- return False;
- elsif Is_Class_Wide_Type (Typ) then
- return Is_Task_Interface (Etype (Typ));
- else
- return Task_Present (Type_Definition (Parent (Typ)));
- end if;
- end Is_Task_Interface;
-
- -------------------------
- -- Is_Task_Record_Type --
- -------------------------
-
- function Is_Task_Record_Type (Id : E) return B is
- begin
- return
- Is_Concurrent_Record_Type (Id)
- and then Is_Task_Type (Corresponding_Concurrent_Type (Id));
- end Is_Task_Record_Type;
-
- ------------------------
- -- Is_Wrapper_Package --
- ------------------------
-
- function Is_Wrapper_Package (Id : E) return B is
- begin
- return Ekind (Id) = E_Package and then Present (Related_Instance (Id));
- end Is_Wrapper_Package;
-
- -----------------
- -- Last_Formal --
- -----------------
-
- function Last_Formal (Id : E) return E is
- Formal : Entity_Id;
-
- begin
- pragma Assert
- (Is_Overloadable (Id)
- or else Ekind (Id) in E_Entry_Family
- | E_Subprogram_Body
- | E_Subprogram_Type);
-
- if Ekind (Id) = E_Enumeration_Literal then
- return Empty;
-
- else
- Formal := First_Formal (Id);
-
- if Present (Formal) then
- while Present (Next_Formal (Formal)) loop
- Next_Formal (Formal);
- end loop;
- end if;
-
- return Formal;
- end if;
- end Last_Formal;
-
- -------------------
- -- Link_Entities --
- -------------------
-
- procedure Link_Entities (First : Entity_Id; Second : Node_Id) is
- begin
- if Present (Second) then
- Set_Prev_Entity (Second, First); -- First <-- Second
- end if;
-
- Set_Next_Entity (First, Second); -- First --> Second
- end Link_Entities;
-
- ------------------------
- -- Machine_Emax_Value --
- ------------------------
-
- function Machine_Emax_Value (Id : E) return Uint is
- Digs : constant Pos := UI_To_Int (Digits_Value (Base_Type (Id)));
-
- begin
- case Float_Rep (Id) is
- when IEEE_Binary =>
- case Digs is
- when 1 .. 6 => return Uint_128;
- when 7 .. 15 => return 2**10;
- when 16 .. 33 => return 2**14;
- when others => return No_Uint;
- end case;
-
- when AAMP =>
- return Uint_2 ** Uint_7 - Uint_1;
- end case;
- end Machine_Emax_Value;
-
- ------------------------
- -- Machine_Emin_Value --
- ------------------------
-
- function Machine_Emin_Value (Id : E) return Uint is
- begin
- case Float_Rep (Id) is
- when IEEE_Binary => return Uint_3 - Machine_Emax_Value (Id);
- when AAMP => return -Machine_Emax_Value (Id);
- end case;
- end Machine_Emin_Value;
-
- ----------------------------
- -- Machine_Mantissa_Value --
- ----------------------------
-
- function Machine_Mantissa_Value (Id : E) return Uint is
- Digs : constant Pos := UI_To_Int (Digits_Value (Base_Type (Id)));
-
- begin
- case Float_Rep (Id) is
- when IEEE_Binary =>
- case Digs is
- when 1 .. 6 => return Uint_24;
- when 7 .. 15 => return UI_From_Int (53);
- when 16 .. 18 => return Uint_64;
- when 19 .. 33 => return UI_From_Int (113);
- when others => return No_Uint;
- end case;
-
- when AAMP =>
- case Digs is
- when 1 .. 6 => return Uint_24;
- when 7 .. 9 => return UI_From_Int (40);
- when others => return No_Uint;
- end case;
- end case;
- end Machine_Mantissa_Value;
-
- -------------------------
- -- Machine_Radix_Value --
- -------------------------
-
- function Machine_Radix_Value (Id : E) return U is
- begin
- case Float_Rep (Id) is
- when AAMP
- | IEEE_Binary
- =>
- return Uint_2;
- 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 --
- --------------------
-
- function Next_Component (Id : E) return E is
- Comp_Id : Entity_Id;
-
- begin
- Comp_Id := Next_Entity (Id);
- while Present (Comp_Id) loop
- exit when Ekind (Comp_Id) = E_Component;
- Next_Entity (Comp_Id);
- end loop;
-
- return Comp_Id;
- end Next_Component;
-
- ------------------------------------
- -- Next_Component_Or_Discriminant --
- ------------------------------------
-
- function Next_Component_Or_Discriminant (Id : E) return E is
- Comp_Id : Entity_Id;
-
- begin
- Comp_Id := Next_Entity (Id);
- while Present (Comp_Id) loop
- exit when Ekind (Comp_Id) in E_Component | E_Discriminant;
- Next_Entity (Comp_Id);
- end loop;
-
- return Comp_Id;
- end Next_Component_Or_Discriminant;
-
- -----------------------
- -- Next_Discriminant --
- -----------------------
-
- -- This function actually implements both Next_Discriminant and
- -- Next_Stored_Discriminant by making sure that the Discriminant
- -- returned is of the same variety as Id.
-
- function Next_Discriminant (Id : E) return E is
-
- -- Derived Tagged types with private extensions look like this...
-
- -- E_Discriminant d1
- -- E_Discriminant d2
- -- E_Component _tag
- -- E_Discriminant d1
- -- E_Discriminant d2
- -- ...
-
- -- so it is critical not to go past the leading discriminants
-
- D : E := Id;
-
- begin
- pragma Assert (Ekind (Id) = E_Discriminant);
-
- loop
- Next_Entity (D);
- if No (D)
- or else (Ekind (D) /= E_Discriminant
- and then not Is_Itype (D))
- then
- return Empty;
- end if;
-
- exit when Ekind (D) = E_Discriminant
- and then (Is_Completely_Hidden (D) = Is_Completely_Hidden (Id));
- end loop;
-
- return D;
- end Next_Discriminant;
-
- -----------------
- -- Next_Formal --
- -----------------
-
- function Next_Formal (Id : E) return E is
- P : Entity_Id;
-
- begin
- -- Follow the chain of declared entities as long as the kind of the
- -- entity corresponds to a formal parameter. Skip internal entities
- -- that may have been created for implicit subtypes, in the process
- -- of analyzing default expressions.
-
- P := Id;
- loop
- Next_Entity (P);
-
- if No (P) or else Is_Formal (P) then
- return P;
- elsif not Is_Internal (P) then
- return Empty;
- end if;
- end loop;
- end Next_Formal;
-
- -----------------------------
- -- Next_Formal_With_Extras --
- -----------------------------
-
- function Next_Formal_With_Extras (Id : E) return E is
- begin
- if Present (Extra_Formal (Id)) then
- return Extra_Formal (Id);
- else
- return Next_Formal (Id);
- end if;
- end Next_Formal_With_Extras;
-
- ----------------
- -- Next_Index --
- ----------------
-
- function Next_Index (Id : Node_Id) return Node_Id is
- begin
- return Next (Id);
- end Next_Index;
-
- ------------------
- -- Next_Literal --
- ------------------
-
- function Next_Literal (Id : E) return E is
- begin
- pragma Assert (Nkind (Id) in N_Entity);
- return Next (Id);
- end Next_Literal;
-
- ------------------------------
- -- Next_Stored_Discriminant --
- ------------------------------
-
- function Next_Stored_Discriminant (Id : E) return E is
- begin
- -- See comment in Next_Discriminant
-
- return Next_Discriminant (Id);
- end Next_Stored_Discriminant;
-
- -----------------------
- -- Number_Dimensions --
- -----------------------
-
- function Number_Dimensions (Id : E) return Pos is
- N : Int;
- T : Node_Id;
-
- begin
- if Ekind (Id) = E_String_Literal_Subtype then
- return 1;
-
- else
- N := 0;
- T := First_Index (Id);
- while Present (T) loop
- N := N + 1;
- Next_Index (T);
- end loop;
-
- return N;
- end if;
- end Number_Dimensions;
-
- --------------------
- -- Number_Entries --
- --------------------
-
- function Number_Entries (Id : E) return Nat is
- N : Int;
- Ent : Entity_Id;
-
- begin
- pragma Assert (Is_Concurrent_Type (Id));
-
- N := 0;
- Ent := First_Entity (Id);
- while Present (Ent) loop
- if Is_Entry (Ent) then
- N := N + 1;
- end if;
-
- Next_Entity (Ent);
- end loop;
-
- return N;
- end Number_Entries;
-
- --------------------
- -- Number_Formals --
- --------------------
-
- function Number_Formals (Id : E) return Pos is
- N : Int;
- Formal : Entity_Id;
-
- begin
- N := 0;
- Formal := First_Formal (Id);
- while Present (Formal) loop
- N := N + 1;
- Next_Formal (Formal);
- end loop;
-
- return N;
- end Number_Formals;
-
- ------------------------
- -- Object_Size_Clause --
- ------------------------
-
- function Object_Size_Clause (Id : E) return N is
- begin
- return Get_Attribute_Definition_Clause (Id, Attribute_Object_Size);
- end Object_Size_Clause;
-
- --------------------
- -- Parameter_Mode --
- --------------------
-
- function Parameter_Mode (Id : E) return Formal_Kind is
- begin
- return Ekind (Id);
- end Parameter_Mode;
-
- ---------------------------
- -- Partial_DIC_Procedure --
- ---------------------------
-
- function Partial_DIC_Procedure (Id : E) return E is
- Subp_Elmt : Elmt_Id;
- Subp_Id : Entity_Id;
- Subps : Elist_Id;
-
- begin
- pragma Assert (Is_Type (Id));
-
- Subps := Subprograms_For_Type (Base_Type (Id));
-
- if Present (Subps) then
- Subp_Elmt := First_Elmt (Subps);
- while Present (Subp_Elmt) loop
- Subp_Id := Node (Subp_Elmt);
-
- if Is_Partial_DIC_Procedure (Subp_Id) then
- return Subp_Id;
- end if;
-
- Next_Elmt (Subp_Elmt);
- end loop;
- end if;
-
- return Empty;
- end Partial_DIC_Procedure;
-
- ---------------------------------
- -- Partial_Invariant_Procedure --
- ---------------------------------
-
- function Partial_Invariant_Procedure (Id : E) return E is
- Subp_Elmt : Elmt_Id;
- Subp_Id : Entity_Id;
- Subps : Elist_Id;
-
- begin
- pragma Assert (Is_Type (Id));
-
- Subps := Subprograms_For_Type (Base_Type (Id));
-
- if Present (Subps) then
- Subp_Elmt := First_Elmt (Subps);
- while Present (Subp_Elmt) loop
- Subp_Id := Node (Subp_Elmt);
-
- if Is_Partial_Invariant_Procedure (Subp_Id) then
- return Subp_Id;
- end if;
-
- Next_Elmt (Subp_Elmt);
- end loop;
- end if;
-
- return Empty;
- end Partial_Invariant_Procedure;
-
- -------------------------------------
- -- Partial_Refinement_Constituents --
- -------------------------------------
-
- function Partial_Refinement_Constituents (Id : E) return L is
- Constits : Elist_Id := No_Elist;
-
- procedure Add_Usable_Constituents (Item : E);
- -- Add global item Item and/or its constituents to list Constits when
- -- they can be used in a global refinement within the current scope. The
- -- criteria are:
- -- 1) If Item is an abstract state with full refinement visible, add
- -- its constituents.
- -- 2) If Item is an abstract state with only partial refinement
- -- visible, add both Item and its constituents.
- -- 3) If Item is an abstract state without a visible refinement, add
- -- it.
- -- 4) If Id is not an abstract state, add it.
-
- procedure Add_Usable_Constituents (List : Elist_Id);
- -- Apply Add_Usable_Constituents to every constituent in List
-
- -----------------------------
- -- Add_Usable_Constituents --
- -----------------------------
-
- procedure Add_Usable_Constituents (Item : E) is
- begin
- if Ekind (Item) = E_Abstract_State then
- if Has_Visible_Refinement (Item) then
- Add_Usable_Constituents (Refinement_Constituents (Item));
-
- elsif Has_Partial_Visible_Refinement (Item) then
- Append_New_Elmt (Item, Constits);
- Add_Usable_Constituents (Part_Of_Constituents (Item));
-
- else
- Append_New_Elmt (Item, Constits);
- end if;
-
- else
- Append_New_Elmt (Item, Constits);
- end if;
- end Add_Usable_Constituents;
-
- procedure Add_Usable_Constituents (List : Elist_Id) is
- Constit_Elmt : Elmt_Id;
- begin
- if Present (List) then
- Constit_Elmt := First_Elmt (List);
- while Present (Constit_Elmt) loop
- Add_Usable_Constituents (Node (Constit_Elmt));
- Next_Elmt (Constit_Elmt);
- end loop;
- end if;
- end Add_Usable_Constituents;
-
- -- Start of processing for Partial_Refinement_Constituents
-
- begin
- -- "Refinement" is a concept applicable only to abstract states
-
- pragma Assert (Ekind (Id) = E_Abstract_State);
-
- if Has_Visible_Refinement (Id) then
- Constits := Refinement_Constituents (Id);
-
- -- A refinement may be partially visible when objects declared in the
- -- private part of a package are subject to a Part_Of indicator.
-
- elsif Has_Partial_Visible_Refinement (Id) then
- Add_Usable_Constituents (Part_Of_Constituents (Id));
-
- -- Function should only be called when full or partial refinement is
- -- visible.
-
- else
- raise Program_Error;
- end if;
-
- return Constits;
- end Partial_Refinement_Constituents;
-
- ------------------------
- -- Predicate_Function --
- ------------------------
-
- function Predicate_Function (Id : E) return E is
- Subp_Elmt : Elmt_Id;
- Subp_Id : Entity_Id;
- Subps : Elist_Id;
- Typ : Entity_Id;
-
- begin
- pragma Assert (Is_Type (Id));
-
- -- If type is private and has a completion, predicate may be defined on
- -- the full view.
-
- if Is_Private_Type (Id)
- and then
- (not Has_Predicates (Id) or else No (Subprograms_For_Type (Id)))
- and then Present (Full_View (Id))
- then
- Typ := Full_View (Id);
-
- 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);
-
- else
- Typ := Id;
- end if;
-
- Subps := Subprograms_For_Type (Typ);
-
- if Present (Subps) then
- Subp_Elmt := First_Elmt (Subps);
- while Present (Subp_Elmt) loop
- Subp_Id := Node (Subp_Elmt);
-
- if Ekind (Subp_Id) = E_Function
- and then Is_Predicate_Function (Subp_Id)
- then
- return Subp_Id;
- end if;
-
- Next_Elmt (Subp_Elmt);
- end loop;
- end if;
-
- return Empty;
- end Predicate_Function;
-
- --------------------------
- -- Predicate_Function_M --
- --------------------------
-
- function Predicate_Function_M (Id : E) return E is
- Subp_Elmt : Elmt_Id;
- Subp_Id : Entity_Id;
- Subps : Elist_Id;
- Typ : Entity_Id;
-
- begin
- pragma Assert (Is_Type (Id));
-
- -- If type is private and has a completion, predicate may be defined on
- -- the full view.
-
- if Is_Private_Type (Id)
- and then
- (not Has_Predicates (Id) or else No (Subprograms_For_Type (Id)))
- and then Present (Full_View (Id))
- then
- Typ := Full_View (Id);
-
- else
- Typ := Id;
- end if;
-
- Subps := Subprograms_For_Type (Typ);
-
- if Present (Subps) then
- Subp_Elmt := First_Elmt (Subps);
- while Present (Subp_Elmt) loop
- Subp_Id := Node (Subp_Elmt);
-
- if Ekind (Subp_Id) = E_Function
- and then Is_Predicate_Function_M (Subp_Id)
- then
- return Subp_Id;
- end if;
-
- Next_Elmt (Subp_Elmt);
- end loop;
- end if;
-
- return Empty;
- end Predicate_Function_M;
-
- -------------------------
- -- Present_In_Rep_Item --
- -------------------------
-
- function Present_In_Rep_Item (E : Entity_Id; N : Node_Id) return Boolean is
- Ritem : Node_Id;
-
- begin
- Ritem := First_Rep_Item (E);
-
- while Present (Ritem) loop
- if Ritem = N then
- return True;
- end if;
-
- Next_Rep_Item (Ritem);
- end loop;
-
- return False;
- end Present_In_Rep_Item;
-
- --------------------------
- -- Primitive_Operations --
- --------------------------
-
- function Primitive_Operations (Id : E) return L is
- begin
- if Is_Concurrent_Type (Id) then
- if Present (Corresponding_Record_Type (Id)) then
- return Direct_Primitive_Operations
- (Corresponding_Record_Type (Id));
-
- -- If expansion is disabled the corresponding record type is absent,
- -- but if the type has ancestors it may have primitive operations.
-
- elsif Is_Tagged_Type (Id) then
- return Direct_Primitive_Operations (Id);
-
- else
- return No_Elist;
- end if;
- else
- return Direct_Primitive_Operations (Id);
- end if;
- end Primitive_Operations;
-
- ---------------------
- -- Record_Rep_Item --
- ---------------------
-
- procedure Record_Rep_Item (E : Entity_Id; N : Node_Id) is
- begin
- Set_Next_Rep_Item (N, First_Rep_Item (E));
- Set_First_Rep_Item (E, N);
- end Record_Rep_Item;
-
- -------------------
- -- Remove_Entity --
- -------------------
-
- procedure Remove_Entity (Id : Entity_Id) is
- Next : constant Entity_Id := Next_Entity (Id);
- Prev : constant Entity_Id := Prev_Entity (Id);
- Scop : constant Entity_Id := Scope (Id);
- First : constant Entity_Id := First_Entity (Scop);
- Last : constant Entity_Id := Last_Entity (Scop);
-
- begin
- -- Eliminate any existing linkages from the entity
-
- Set_Prev_Entity (Id, Empty); -- Empty <-- Id
- Set_Next_Entity (Id, Empty); -- Id --> Empty
-
- -- The eliminated entity was the only element in the entity chain
-
- if Id = First and then Id = Last then
- Set_First_Entity (Scop, Empty);
- Set_Last_Entity (Scop, Empty);
-
- -- The eliminated entity was the head of the entity chain
-
- elsif Id = First then
- Set_First_Entity (Scop, Next);
-
- -- The eliminated entity was the tail of the entity chain
-
- elsif Id = Last then
- Set_Last_Entity (Scop, Prev);
-
- -- Otherwise the eliminated entity comes from the middle of the entity
- -- chain.
-
- else
- Link_Entities (Prev, Next); -- Prev <-- Next, Prev --> Next
- end if;
- end Remove_Entity;
-
- ---------------
- -- Root_Type --
- ---------------
-
- function Root_Type (Id : E) return E is
- T, Etyp : Entity_Id;
-
- begin
- pragma Assert (Nkind (Id) in N_Entity);
-
- T := Base_Type (Id);
-
- if Ekind (T) = E_Class_Wide_Type then
- return Etype (T);
-
- -- Other cases
-
- else
- loop
- Etyp := Etype (T);
-
- if T = Etyp then
- return T;
-
- -- Following test catches some error cases resulting from
- -- previous errors.
-
- elsif No (Etyp) then
- Check_Error_Detected;
- return T;
-
- elsif Is_Private_Type (T) and then Etyp = Full_View (T) then
- return T;
-
- elsif Is_Private_Type (Etyp) and then Full_View (Etyp) = T then
- return T;
- end if;
-
- T := Etyp;
-
- -- Return if there is a circularity in the inheritance chain. This
- -- happens in some error situations and we do not want to get
- -- stuck in this loop.
-
- if T = Base_Type (Id) then
- return T;
- end if;
- end loop;
- end if;
- end Root_Type;
-
- ---------------------
- -- Safe_Emax_Value --
- ---------------------
-
- function Safe_Emax_Value (Id : E) return Uint is
- begin
- return Machine_Emax_Value (Id);
- end Safe_Emax_Value;
-
- ----------------------
- -- Safe_First_Value --
- ----------------------
-
- function Safe_First_Value (Id : E) return Ureal is
- begin
- return -Safe_Last_Value (Id);
- end Safe_First_Value;
-
- ---------------------
- -- Safe_Last_Value --
- ---------------------
-
- function Safe_Last_Value (Id : E) return Ureal is
- Radix : constant Uint := Machine_Radix_Value (Id);
- Mantissa : constant Uint := Machine_Mantissa_Value (Id);
- Emax : constant Uint := Safe_Emax_Value (Id);
- Significand : constant Uint := Radix ** Mantissa - 1;
- Exponent : constant Uint := Emax - Mantissa;
-
- begin
- if Radix = 2 then
- return
- UR_From_Components
- (Num => Significand * 2 ** (Exponent mod 4),
- Den => -Exponent / 4,
- Rbase => 16);
- else
- return
- UR_From_Components
- (Num => Significand,
- Den => -Exponent,
- Rbase => 16);
- end if;
- end Safe_Last_Value;
-
- -----------------
- -- Scope_Depth --
- -----------------
-
- function Scope_Depth (Id : E) return Uint is
- Scop : Entity_Id;
-
- begin
- Scop := Id;
- while Is_Record_Type (Scop) loop
- Scop := Scope (Scop);
- end loop;
-
- return Scope_Depth_Value (Scop);
- end Scope_Depth;
-
- ---------------------
- -- Scope_Depth_Set --
- ---------------------
-
- function Scope_Depth_Set (Id : E) return B is
- begin
- return not Is_Record_Type (Id)
- and then Field22 (Id) /= Union_Id (Empty);
- end Scope_Depth_Set;
-
- -----------------------------
- -- Set_Component_Alignment --
- -----------------------------
-
- -- Component Alignment is encoded using two flags, Flag128/129 as
- -- follows. Note that both flags False = Align_Default, so that the
- -- default initialization of flags to False initializes component
- -- alignment to the default value as required.
-
- -- Flag128 Flag129 Value
- -- ------- ------- -----
- -- False False Calign_Default
- -- False True Calign_Component_Size
- -- True False Calign_Component_Size_4
- -- True True Calign_Storage_Unit
-
- procedure Set_Component_Alignment (Id : E; V : C) is
- begin
- pragma Assert ((Is_Array_Type (Id) or else Is_Record_Type (Id))
- and then Is_Base_Type (Id));
-
- case V is
- when Calign_Default =>
- Set_Flag128 (Id, False);
- Set_Flag129 (Id, False);
-
- when Calign_Component_Size =>
- Set_Flag128 (Id, False);
- Set_Flag129 (Id, True);
-
- when Calign_Component_Size_4 =>
- Set_Flag128 (Id, True);
- Set_Flag129 (Id, False);
-
- when Calign_Storage_Unit =>
- Set_Flag128 (Id, True);
- Set_Flag129 (Id, True);
- end case;
- end Set_Component_Alignment;
-
- -----------------------
- -- Set_DIC_Procedure --
- -----------------------
-
- procedure Set_DIC_Procedure (Id : E; V : E) is
- Base_Typ : Entity_Id;
- Subps : Elist_Id;
-
- begin
- pragma Assert (Is_Type (Id));
-
- Base_Typ := Base_Type (Id);
- Subps := Subprograms_For_Type (Base_Typ);
-
- if No (Subps) then
- Subps := New_Elmt_List;
- Set_Subprograms_For_Type (Base_Typ, Subps);
- end if;
-
- Prepend_Elmt (V, Subps);
- end Set_DIC_Procedure;
-
- -------------------------------------
- -- Set_Partial_Invariant_Procedure --
- -------------------------------------
-
- procedure Set_Partial_DIC_Procedure (Id : E; V : E) is
- begin
- Set_DIC_Procedure (Id, V);
- end Set_Partial_DIC_Procedure;
-
- -----------------------------
- -- Set_Invariant_Procedure --
- -----------------------------
-
- procedure Set_Invariant_Procedure (Id : E; V : E) is
- Base_Typ : Entity_Id;
- Subp_Elmt : Elmt_Id;
- Subp_Id : Entity_Id;
- Subps : Elist_Id;
-
- begin
- pragma Assert (Is_Type (Id));
-
- Base_Typ := Base_Type (Id);
- Subps := Subprograms_For_Type (Base_Typ);
-
- if No (Subps) then
- Subps := New_Elmt_List;
- Set_Subprograms_For_Type (Base_Typ, Subps);
- end if;
-
- Subp_Elmt := First_Elmt (Subps);
- Prepend_Elmt (V, Subps);
-
- -- Check for a duplicate invariant procedure
-
- while Present (Subp_Elmt) loop
- Subp_Id := Node (Subp_Elmt);
-
- if Is_Invariant_Procedure (Subp_Id) then
- raise Program_Error;
- end if;
-
- Next_Elmt (Subp_Elmt);
- end loop;
- end Set_Invariant_Procedure;
-
- -------------------------------------
- -- Set_Partial_Invariant_Procedure --
- -------------------------------------
-
- procedure Set_Partial_Invariant_Procedure (Id : E; V : E) is
- Base_Typ : Entity_Id;
- Subp_Elmt : Elmt_Id;
- Subp_Id : Entity_Id;
- Subps : Elist_Id;
-
- begin
- pragma Assert (Is_Type (Id));
-
- Base_Typ := Base_Type (Id);
- Subps := Subprograms_For_Type (Base_Typ);
-
- if No (Subps) then
- Subps := New_Elmt_List;
- Set_Subprograms_For_Type (Base_Typ, Subps);
- end if;
-
- Subp_Elmt := First_Elmt (Subps);
- Prepend_Elmt (V, Subps);
-
- -- Check for a duplicate partial invariant procedure
-
- while Present (Subp_Elmt) loop
- Subp_Id := Node (Subp_Elmt);
-
- if Is_Partial_Invariant_Procedure (Subp_Id) then
- raise Program_Error;
- end if;
-
- Next_Elmt (Subp_Elmt);
- end loop;
- end Set_Partial_Invariant_Procedure;
-
- ----------------------------
- -- Set_Predicate_Function --
- ----------------------------
-
- procedure Set_Predicate_Function (Id : E; V : E) is
- Subp_Elmt : Elmt_Id;
- Subp_Id : Entity_Id;
- Subps : Elist_Id;
-
- begin
- pragma Assert (Is_Type (Id) and then Has_Predicates (Id));
-
- Subps := Subprograms_For_Type (Id);
-
- if No (Subps) then
- Subps := New_Elmt_List;
- Set_Subprograms_For_Type (Id, Subps);
- end if;
-
- Subp_Elmt := First_Elmt (Subps);
- Prepend_Elmt (V, Subps);
-
- -- Check for a duplicate predication function
-
- while Present (Subp_Elmt) loop
- Subp_Id := Node (Subp_Elmt);
-
- if Ekind (Subp_Id) = E_Function
- and then Is_Predicate_Function (Subp_Id)
- then
- raise Program_Error;
- end if;
-
- Next_Elmt (Subp_Elmt);
- end loop;
- end Set_Predicate_Function;
-
- ------------------------------
- -- Set_Predicate_Function_M --
- ------------------------------
-
- procedure Set_Predicate_Function_M (Id : E; V : E) is
- Subp_Elmt : Elmt_Id;
- Subp_Id : Entity_Id;
- Subps : Elist_Id;
-
- begin
- pragma Assert (Is_Type (Id) and then Has_Predicates (Id));
-
- Subps := Subprograms_For_Type (Id);
-
- if No (Subps) then
- Subps := New_Elmt_List;
- Set_Subprograms_For_Type (Id, Subps);
- end if;
-
- Subp_Elmt := First_Elmt (Subps);
- Prepend_Elmt (V, Subps);
-
- -- Check for a duplicate predication function
-
- while Present (Subp_Elmt) loop
- Subp_Id := Node (Subp_Elmt);
-
- if Ekind (Subp_Id) = E_Function
- and then Is_Predicate_Function_M (Subp_Id)
- then
- raise Program_Error;
- end if;
-
- Next_Elmt (Subp_Elmt);
- end loop;
- end Set_Predicate_Function_M;
-
- -----------------
- -- Size_Clause --
- -----------------
-
- function Size_Clause (Id : E) return N is
- begin
- return Get_Attribute_Definition_Clause (Id, Attribute_Size);
- end Size_Clause;
-
- ------------------------
- -- Stream_Size_Clause --
- ------------------------
-
- function Stream_Size_Clause (Id : E) return N is
- begin
- return Get_Attribute_Definition_Clause (Id, Attribute_Stream_Size);
- end Stream_Size_Clause;
-
- ------------------
- -- Subtype_Kind --
- ------------------
-
- function Subtype_Kind (K : Entity_Kind) return Entity_Kind is
- Kind : Entity_Kind;
-
- begin
- case K is
- when Access_Kind =>
- Kind := E_Access_Subtype;
-
- when E_Array_Subtype
- | E_Array_Type
- =>
- Kind := E_Array_Subtype;
-
- when E_Class_Wide_Subtype
- | E_Class_Wide_Type
- =>
- Kind := E_Class_Wide_Subtype;
-
- when E_Decimal_Fixed_Point_Subtype
- | E_Decimal_Fixed_Point_Type
- =>
- Kind := E_Decimal_Fixed_Point_Subtype;
-
- when E_Ordinary_Fixed_Point_Subtype
- | E_Ordinary_Fixed_Point_Type
- =>
- Kind := E_Ordinary_Fixed_Point_Subtype;
-
- when E_Private_Subtype
- | E_Private_Type
- =>
- Kind := E_Private_Subtype;
-
- when E_Limited_Private_Subtype
- | E_Limited_Private_Type
- =>
- Kind := E_Limited_Private_Subtype;
-
- when E_Record_Subtype_With_Private
- | E_Record_Type_With_Private
- =>
- Kind := E_Record_Subtype_With_Private;
-
- when E_Record_Subtype
- | E_Record_Type
- =>
- Kind := E_Record_Subtype;
-
- when Enumeration_Kind =>
- Kind := E_Enumeration_Subtype;
-
- when E_Incomplete_Type =>
- Kind := E_Incomplete_Subtype;
-
- when Float_Kind =>
- Kind := E_Floating_Point_Subtype;
-
- when Signed_Integer_Kind =>
- Kind := E_Signed_Integer_Subtype;
-
- when Modular_Integer_Kind =>
- Kind := E_Modular_Integer_Subtype;
-
- when Protected_Kind =>
- Kind := E_Protected_Subtype;
-
- when Task_Kind =>
- Kind := E_Task_Subtype;
-
- when others =>
- Kind := E_Void;
- raise Program_Error;
- end case;
-
- return Kind;
- end Subtype_Kind;
-
- ---------------------
- -- Type_High_Bound --
- ---------------------
-
- function Type_High_Bound (Id : E) return Node_Id is
- Rng : constant Node_Id := Scalar_Range (Id);
- begin
- if Nkind (Rng) = N_Subtype_Indication then
- return High_Bound (Range_Expression (Constraint (Rng)));
- else
- return High_Bound (Rng);
- end if;
- end Type_High_Bound;
-
- --------------------
- -- Type_Low_Bound --
- --------------------
-
- function Type_Low_Bound (Id : E) return Node_Id is
- Rng : constant Node_Id := Scalar_Range (Id);
- begin
- if Nkind (Rng) = N_Subtype_Indication then
- return Low_Bound (Range_Expression (Constraint (Rng)));
- else
- return Low_Bound (Rng);
- end if;
- end Type_Low_Bound;
-
- ---------------------
- -- Underlying_Type --
- ---------------------
-
- function Underlying_Type (Id : E) return E is
- begin
- -- For record_with_private the underlying type is always the direct full
- -- view. Never try to take the full view of the parent it does not make
- -- sense.
-
- if Ekind (Id) = E_Record_Type_With_Private then
- return Full_View (Id);
-
- -- If we have a class-wide type that comes from the limited view then we
- -- return the Underlying_Type of its nonlimited view.
-
- elsif Ekind (Id) = E_Class_Wide_Type
- and then From_Limited_With (Id)
- and then Present (Non_Limited_View (Id))
- then
- return Underlying_Type (Non_Limited_View (Id));
-
- elsif Ekind (Id) in Incomplete_Or_Private_Kind then
-
- -- If we have an incomplete or private type with a full view, then we
- -- return the Underlying_Type of this full view.
-
- if Present (Full_View (Id)) then
- if Id = Full_View (Id) then
-
- -- Previous error in declaration
-
- return Empty;
-
- else
- return Underlying_Type (Full_View (Id));
- end if;
-
- -- If we have a private type with an underlying full view, then we
- -- return the Underlying_Type of this underlying full view.
-
- elsif Ekind (Id) in Private_Kind
- and then Present (Underlying_Full_View (Id))
- then
- return Underlying_Type (Underlying_Full_View (Id));
-
- -- If we have an incomplete entity that comes from the limited view
- -- then we return the Underlying_Type of its nonlimited view.
-
- elsif From_Limited_With (Id)
- and then Present (Non_Limited_View (Id))
- then
- return Underlying_Type (Non_Limited_View (Id));
-
- -- Otherwise check for the case where we have a derived type or
- -- subtype, and if so get the Underlying_Type of the parent type.
-
- elsif Etype (Id) /= Id then
- return Underlying_Type (Etype (Id));
-
- -- Otherwise we have an incomplete or private type that has no full
- -- view, which means that we have not encountered the completion, so
- -- return Empty to indicate the underlying type is not yet known.
-
- else
- return Empty;
- end if;
-
- -- For non-incomplete, non-private types, return the type itself. Also
- -- for entities that are not types at all return the entity itself.
-
- else
- return Id;
- end if;
- end Underlying_Type;
-
- ------------------------
- -- Unlink_Next_Entity --
- ------------------------
-
- procedure Unlink_Next_Entity (Id : Entity_Id) is
- Next : constant Entity_Id := Next_Entity (Id);
-
- begin
- if Present (Next) then
- Set_Prev_Entity (Next, Empty); -- Empty <-- Next
- end if;
-
- Set_Next_Entity (Id, Empty); -- Id --> Empty
- end Unlink_Next_Entity;
-
- ------------------------
- -- Write_Entity_Flags --
- ------------------------
-
- procedure Write_Entity_Flags (Id : Entity_Id; Prefix : String) is
-
- procedure W (Flag_Name : String; Flag : Boolean);
- -- Write out given flag if it is set
-
- -------
- -- W --
- -------
-
- procedure W (Flag_Name : String; Flag : Boolean) is
- begin
- if Flag then
- Write_Str (Prefix);
- Write_Str (Flag_Name);
- Write_Str (" = True");
- Write_Eol;
- end if;
- end W;
-
- -- Start of processing for Write_Entity_Flags
-
- begin
- if (Is_Array_Type (Id) or else Is_Record_Type (Id))
- and then Is_Base_Type (Id)
- then
- Write_Str (Prefix);
- Write_Str ("Component_Alignment = ");
-
- case Component_Alignment (Id) is
- when Calign_Default =>
- Write_Str ("Calign_Default");
-
- when Calign_Component_Size =>
- Write_Str ("Calign_Component_Size");
-
- when Calign_Component_Size_4 =>
- Write_Str ("Calign_Component_Size_4");
-
- when Calign_Storage_Unit =>
- Write_Str ("Calign_Storage_Unit");
- end case;
-
- Write_Eol;
- end if;
-
- W ("Address_Taken", Flag104 (Id));
- W ("Body_Needed_For_Inlining", Flag299 (Id));
- W ("Body_Needed_For_SAL", Flag40 (Id));
- W ("C_Pass_By_Copy", Flag125 (Id));
- W ("Can_Never_Be_Null", Flag38 (Id));
- W ("Checks_May_Be_Suppressed", Flag31 (Id));
- W ("Contains_Ignored_Ghost_Code", Flag279 (Id));
- W ("Debug_Info_Off", Flag166 (Id));
- W ("Default_Expressions_Processed", Flag108 (Id));
- W ("Delay_Cleanups", Flag114 (Id));
- W ("Delay_Subprogram_Descriptors", Flag50 (Id));
- W ("Depends_On_Private", Flag14 (Id));
- W ("Discard_Names", Flag88 (Id));
- W ("Elaboration_Entity_Required", Flag174 (Id));
- W ("Elaborate_Body_Desirable", Flag210 (Id));
- W ("Entry_Accepted", Flag152 (Id));
- W ("Can_Use_Internal_Rep", Flag229 (Id));
- W ("Finalize_Storage_Only", Flag158 (Id));
- W ("From_Limited_With", Flag159 (Id));
- W ("Has_Aliased_Components", Flag135 (Id));
- W ("Has_Alignment_Clause", Flag46 (Id));
- W ("Has_All_Calls_Remote", Flag79 (Id));
- W ("Has_Atomic_Components", Flag86 (Id));
- W ("Has_Biased_Representation", Flag139 (Id));
- W ("Has_Completion", Flag26 (Id));
- W ("Has_Completion_In_Body", Flag71 (Id));
- W ("Has_Complex_Representation", Flag140 (Id));
- W ("Has_Component_Size_Clause", Flag68 (Id));
- W ("Has_Contiguous_Rep", Flag181 (Id));
- W ("Has_Controlled_Component", Flag43 (Id));
- W ("Has_Controlling_Result", Flag98 (Id));
- W ("Has_Convention_Pragma", Flag119 (Id));
- W ("Has_Default_Aspect", Flag39 (Id));
- W ("Has_Delayed_Aspects", Flag200 (Id));
- W ("Has_Delayed_Freeze", Flag18 (Id));
- W ("Has_Delayed_Rep_Aspects", Flag261 (Id));
- W ("Has_Discriminants", Flag5 (Id));
- W ("Has_Dispatch_Table", Flag220 (Id));
- W ("Has_Dynamic_Predicate_Aspect", Flag258 (Id));
- W ("Has_Enumeration_Rep_Clause", Flag66 (Id));
- W ("Has_Exit", Flag47 (Id));
- W ("Has_Expanded_Contract", Flag240 (Id));
- W ("Has_Forward_Instantiation", Flag175 (Id));
- W ("Has_Fully_Qualified_Name", Flag173 (Id));
- W ("Has_Gigi_Rep_Item", Flag82 (Id));
- W ("Has_Homonym", Flag56 (Id));
- W ("Has_Implicit_Dereference", Flag251 (Id));
- W ("Has_Independent_Components", Flag34 (Id));
- W ("Has_Inheritable_Invariants", Flag248 (Id));
- W ("Has_Inherited_DIC", Flag133 (Id));
- W ("Has_Inherited_Invariants", Flag291 (Id));
- W ("Has_Initial_Value", Flag219 (Id));
- W ("Has_Loop_Entry_Attributes", Flag260 (Id));
- W ("Has_Machine_Radix_Clause", Flag83 (Id));
- W ("Has_Master_Entity", Flag21 (Id));
- W ("Has_Missing_Return", Flag142 (Id));
- W ("Has_Nested_Block_With_Handler", Flag101 (Id));
- W ("Has_Nested_Subprogram", Flag282 (Id));
- W ("Has_Non_Standard_Rep", Flag75 (Id));
- W ("Has_Out_Or_In_Out_Parameter", Flag110 (Id));
- W ("Has_Object_Size_Clause", Flag172 (Id));
- W ("Has_Own_DIC", Flag3 (Id));
- W ("Has_Own_Invariants", Flag232 (Id));
- W ("Has_Per_Object_Constraint", Flag154 (Id));
- W ("Has_Pragma_Controlled", Flag27 (Id));
- W ("Has_Pragma_Elaborate_Body", Flag150 (Id));
- W ("Has_Pragma_Inline", Flag157 (Id));
- W ("Has_Pragma_Inline_Always", Flag230 (Id));
- W ("Has_Pragma_No_Inline", Flag201 (Id));
- W ("Has_Pragma_Ordered", Flag198 (Id));
- W ("Has_Pragma_Pack", Flag121 (Id));
- W ("Has_Pragma_Preelab_Init", Flag221 (Id));
- W ("Has_Pragma_Pure", Flag203 (Id));
- W ("Has_Pragma_Pure_Function", Flag179 (Id));
- W ("Has_Pragma_Thread_Local_Storage", Flag169 (Id));
- W ("Has_Pragma_Unmodified", Flag233 (Id));
- W ("Has_Pragma_Unreferenced", Flag180 (Id));
- W ("Has_Pragma_Unreferenced_Objects", Flag212 (Id));
- W ("Has_Pragma_Unused", Flag294 (Id));
- W ("Has_Predicates", Flag250 (Id));
- W ("Has_Primitive_Operations", Flag120 (Id));
- W ("Has_Private_Ancestor", Flag151 (Id));
- W ("Has_Private_Declaration", Flag155 (Id));
- W ("Has_Private_Extension", Flag300 (Id));
- W ("Has_Protected", Flag271 (Id));
- W ("Has_Qualified_Name", Flag161 (Id));
- W ("Has_RACW", Flag214 (Id));
- W ("Has_Record_Rep_Clause", Flag65 (Id));
- W ("Has_Recursive_Call", Flag143 (Id));
- W ("Has_Shift_Operator", Flag267 (Id));
- W ("Has_Size_Clause", Flag29 (Id));
- W ("Has_Small_Clause", Flag67 (Id));
- W ("Has_Specified_Layout", Flag100 (Id));
- W ("Has_Specified_Stream_Input", Flag190 (Id));
- W ("Has_Specified_Stream_Output", Flag191 (Id));
- W ("Has_Specified_Stream_Read", Flag192 (Id));
- W ("Has_Specified_Stream_Write", Flag193 (Id));
- W ("Has_Static_Discriminants", Flag211 (Id));
- W ("Has_Static_Predicate", Flag269 (Id));
- W ("Has_Static_Predicate_Aspect", Flag259 (Id));
- W ("Has_Storage_Size_Clause", Flag23 (Id));
- W ("Has_Stream_Size_Clause", Flag184 (Id));
- W ("Has_Task", Flag30 (Id));
- W ("Has_Timing_Event", Flag289 (Id));
- W ("Has_Thunks", Flag228 (Id));
- W ("Has_Unchecked_Union", Flag123 (Id));
- W ("Has_Unknown_Discriminants", Flag72 (Id));
- 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 ("Is_Abstract_Subprogram", Flag19 (Id));
- W ("Is_Abstract_Type", Flag146 (Id));
- W ("Is_Access_Constant", Flag69 (Id));
- W ("Is_Activation_Record", Flag305 (Id));
- W ("Is_Actual_Subtype", Flag293 (Id));
- W ("Is_Ada_2005_Only", Flag185 (Id));
- W ("Is_Ada_2012_Only", Flag199 (Id));
- W ("Is_Aliased", Flag15 (Id));
- W ("Is_Asynchronous", Flag81 (Id));
- 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));
- W ("Is_Child_Unit", Flag73 (Id));
- W ("Is_Class_Wide_Equivalent_Type", Flag35 (Id));
- W ("Is_Compilation_Unit", Flag149 (Id));
- W ("Is_Completely_Hidden", Flag103 (Id));
- W ("Is_Concurrent_Record_Type", Flag20 (Id));
- W ("Is_Constr_Subt_For_UN_Aliased", Flag141 (Id));
- W ("Is_Constr_Subt_For_U_Nominal", Flag80 (Id));
- W ("Is_Constrained", Flag12 (Id));
- W ("Is_Constructor", Flag76 (Id));
- W ("Is_Controlled_Active", Flag42 (Id));
- W ("Is_Controlling_Formal", Flag97 (Id));
- W ("Is_Descendant_Of_Address", Flag223 (Id));
- W ("Is_DIC_Procedure", Flag132 (Id));
- W ("Is_Discrim_SO_Function", Flag176 (Id));
- W ("Is_Discriminant_Check_Function", Flag264 (Id));
- W ("Is_Dispatch_Table_Entity", Flag234 (Id));
- W ("Is_Dispatching_Operation", Flag6 (Id));
- W ("Is_Elaboration_Checks_OK_Id", Flag148 (Id));
- W ("Is_Elaboration_Warnings_OK_Id", Flag304 (Id));
- W ("Is_Eliminated", Flag124 (Id));
- W ("Is_Entry_Formal", Flag52 (Id));
- W ("Is_Exception_Handler", Flag286 (Id));
- W ("Is_Exported", Flag99 (Id));
- W ("Is_Finalized_Transient", Flag252 (Id));
- W ("Is_First_Subtype", Flag70 (Id));
- W ("Is_Formal_Subprogram", Flag111 (Id));
- W ("Is_Frozen", Flag4 (Id));
- W ("Is_Generic_Actual_Subprogram", Flag274 (Id));
- W ("Is_Generic_Actual_Type", Flag94 (Id));
- W ("Is_Generic_Instance", Flag130 (Id));
- W ("Is_Generic_Type", Flag13 (Id));
- W ("Is_Hidden", Flag57 (Id));
- W ("Is_Hidden_Non_Overridden_Subpgm", Flag2 (Id));
- W ("Is_Hidden_Open_Scope", Flag171 (Id));
- W ("Is_Ignored_Ghost_Entity", Flag278 (Id));
- W ("Is_Ignored_Transient", Flag295 (Id));
- W ("Is_Immediately_Visible", Flag7 (Id));
- W ("Is_Implementation_Defined", Flag254 (Id));
- W ("Is_Imported", Flag24 (Id));
- W ("Is_Independent", Flag268 (Id));
- W ("Is_Initial_Condition_Procedure", Flag302 (Id));
- W ("Is_Inlined", Flag11 (Id));
- W ("Is_Inlined_Always", Flag1 (Id));
- W ("Is_Instantiated", Flag126 (Id));
- W ("Is_Interface", Flag186 (Id));
- W ("Is_Internal", Flag17 (Id));
- W ("Is_Interrupt_Handler", Flag89 (Id));
- W ("Is_Intrinsic_Subprogram", Flag64 (Id));
- W ("Is_Invariant_Procedure", Flag257 (Id));
- W ("Is_Itype", Flag91 (Id));
- W ("Is_Known_Non_Null", Flag37 (Id));
- W ("Is_Known_Null", Flag204 (Id));
- W ("Is_Known_Valid", Flag170 (Id));
- W ("Is_Limited_Composite", Flag106 (Id));
- W ("Is_Limited_Interface", Flag197 (Id));
- W ("Is_Limited_Record", Flag25 (Id));
- W ("Is_Local_Anonymous_Access", Flag194 (Id));
- W ("Is_Loop_Parameter", Flag307 (Id));
- W ("Is_Machine_Code_Subprogram", Flag137 (Id));
- W ("Is_Non_Static_Subtype", Flag109 (Id));
- W ("Is_Null_Init_Proc", Flag178 (Id));
- W ("Is_Obsolescent", Flag153 (Id));
- W ("Is_Only_Out_Parameter", Flag226 (Id));
- W ("Is_Package_Body_Entity", Flag160 (Id));
- W ("Is_Packed", Flag51 (Id));
- W ("Is_Packed_Array_Impl_Type", Flag138 (Id));
- W ("Is_Param_Block_Component_Type", Flag215 (Id));
- W ("Is_Partial_Invariant_Procedure", Flag292 (Id));
- W ("Is_Potentially_Use_Visible", Flag9 (Id));
- W ("Is_Predicate_Function", Flag255 (Id));
- W ("Is_Predicate_Function_M", Flag256 (Id));
- W ("Is_Preelaborated", Flag59 (Id));
- W ("Is_Primitive", Flag218 (Id));
- W ("Is_Primitive_Wrapper", Flag195 (Id));
- W ("Is_Private_Composite", Flag107 (Id));
- W ("Is_Private_Descendant", Flag53 (Id));
- W ("Is_Private_Primitive", Flag245 (Id));
- W ("Is_Public", Flag10 (Id));
- W ("Is_Pure", Flag44 (Id));
- W ("Is_Pure_Unit_Access_Type", Flag189 (Id));
- W ("Is_RACW_Stub_Type", Flag244 (Id));
- W ("Is_Raised", Flag224 (Id));
- W ("Is_Remote_Call_Interface", Flag62 (Id));
- W ("Is_Remote_Types", Flag61 (Id));
- W ("Is_Renaming_Of_Object", Flag112 (Id));
- W ("Is_Return_Object", Flag209 (Id));
- W ("Is_Safe_To_Reevaluate", Flag249 (Id));
- W ("Is_Shared_Passive", Flag60 (Id));
- W ("Is_Static_Type", Flag281 (Id));
- W ("Is_Statically_Allocated", Flag28 (Id));
- W ("Is_Tag", Flag78 (Id));
- W ("Is_Tagged_Type", Flag55 (Id));
- W ("Is_Thunk", Flag225 (Id));
- W ("Is_Trivial_Subprogram", Flag235 (Id));
- W ("Is_True_Constant", Flag163 (Id));
- W ("Is_Unchecked_Union", Flag117 (Id));
- W ("Is_Underlying_Full_View", Flag298 (Id));
- W ("Is_Underlying_Record_View", Flag246 (Id));
- W ("Is_Unimplemented", Flag284 (Id));
- W ("Is_Unsigned_Type", Flag144 (Id));
- W ("Is_Uplevel_Referenced_Entity", Flag283 (Id));
- W ("Is_Valued_Procedure", Flag127 (Id));
- W ("Is_Visible_Formal", Flag206 (Id));
- W ("Is_Visible_Lib_Unit", Flag116 (Id));
- W ("Is_Volatile", Flag16 (Id));
- W ("Is_Volatile_Full_Access", Flag285 (Id));
- W ("Itype_Printed", Flag202 (Id));
- W ("Kill_Elaboration_Checks", Flag32 (Id));
- W ("Kill_Range_Checks", Flag33 (Id));
- W ("Known_To_Have_Preelab_Init", Flag207 (Id));
- W ("Low_Bound_Tested", Flag205 (Id));
- W ("Machine_Radix_10", Flag84 (Id));
- W ("Materialize_Entity", Flag168 (Id));
- W ("May_Inherit_Delayed_Rep_Aspects", Flag262 (Id));
- W ("Must_Be_On_Byte_Boundary", Flag183 (Id));
- W ("Must_Have_Preelab_Init", Flag208 (Id));
- W ("Needs_Activation_Record", Flag306 (Id));
- W ("Needs_Debug_Info", Flag147 (Id));
- W ("Needs_No_Actuals", Flag22 (Id));
- W ("Never_Set_In_Source", Flag115 (Id));
- W ("No_Dynamic_Predicate_On_actual", Flag276 (Id));
- W ("No_Pool_Assigned", Flag131 (Id));
- W ("No_Predicate_On_actual", Flag275 (Id));
- W ("No_Reordering", Flag239 (Id));
- W ("No_Return", Flag113 (Id));
- W ("No_Strict_Aliasing", Flag136 (Id));
- W ("Non_Binary_Modulus", Flag58 (Id));
- W ("Nonzero_Is_True", Flag162 (Id));
- W ("OK_To_Rename", Flag247 (Id));
- W ("Optimize_Alignment_Space", Flag241 (Id));
- W ("Optimize_Alignment_Time", Flag242 (Id));
- W ("Overlays_Constant", Flag243 (Id));
- W ("Partial_View_Has_Unknown_Discr", Flag280 (Id));
- W ("Reachable", Flag49 (Id));
- W ("Referenced", Flag156 (Id));
- W ("Referenced_As_LHS", Flag36 (Id));
- W ("Referenced_As_Out_Parameter", Flag227 (Id));
- W ("Renamed_In_Spec", Flag231 (Id));
- W ("Requires_Overriding", Flag213 (Id));
- W ("Return_Present", Flag54 (Id));
- W ("Returns_By_Ref", Flag90 (Id));
- W ("Reverse_Bit_Order", Flag164 (Id));
- W ("Reverse_Storage_Order", Flag93 (Id));
- W ("Rewritten_For_C", Flag287 (Id));
- W ("Predicates_Ignored", Flag288 (Id));
- W ("Sec_Stack_Needed_For_Return", Flag167 (Id));
- W ("Size_Depends_On_Discriminant", Flag177 (Id));
- W ("Size_Known_At_Compile_Time", Flag92 (Id));
- W ("SPARK_Aux_Pragma_Inherited", Flag266 (Id));
- W ("SPARK_Pragma_Inherited", Flag265 (Id));
- W ("SSO_Set_High_By_Default", Flag273 (Id));
- W ("SSO_Set_Low_By_Default", Flag272 (Id));
- W ("Static_Elaboration_Desired", Flag77 (Id));
- W ("Stores_Attribute_Old_Prefix", Flag270 (Id));
- W ("Strict_Alignment", Flag145 (Id));
- W ("Suppress_Elaboration_Warnings", Flag303 (Id));
- W ("Suppress_Initialization", Flag105 (Id));
- W ("Suppress_Style_Checks", Flag165 (Id));
- W ("Suppress_Value_Tracking_On_Call", Flag217 (Id));
- W ("Treat_As_Volatile", Flag41 (Id));
- W ("Universal_Aliasing", Flag216 (Id));
- W ("Used_As_Generic_Actual", Flag222 (Id));
- W ("Uses_Sec_Stack", Flag95 (Id));
- W ("Warnings_Off", Flag96 (Id));
- W ("Warnings_Off_Used", Flag236 (Id));
- W ("Warnings_Off_Used_Unmodified", Flag237 (Id));
- W ("Warnings_Off_Used_Unreferenced", Flag238 (Id));
- W ("Was_Hidden", Flag196 (Id));
- end Write_Entity_Flags;
-
- -----------------------
- -- Write_Entity_Info --
- -----------------------
-
- procedure Write_Entity_Info (Id : Entity_Id; Prefix : String) is
-
- procedure Write_Attribute (Which : String; Nam : E);
- -- Write attribute value with given string name
-
- procedure Write_Kind (Id : Entity_Id);
- -- Write Ekind field of entity
-
- ---------------------
- -- Write_Attribute --
- ---------------------
-
- procedure Write_Attribute (Which : String; Nam : E) is
- begin
- Write_Str (Prefix);
- Write_Str (Which);
- Write_Int (Int (Nam));
- Write_Str (" ");
- Write_Name (Chars (Nam));
- Write_Str (" ");
- end Write_Attribute;
-
- ----------------
- -- Write_Kind --
- ----------------
-
- procedure Write_Kind (Id : Entity_Id) is
- K : constant String := Entity_Kind'Image (Ekind (Id));
-
- begin
- Write_Str (Prefix);
- Write_Str (" Kind ");
-
- if Is_Type (Id) and then Is_Tagged_Type (Id) then
- Write_Str ("TAGGED ");
- end if;
-
- Write_Str (K (3 .. K'Length));
- Write_Str (" ");
-
- if Is_Type (Id) and then Depends_On_Private (Id) then
- Write_Str ("Depends_On_Private ");
- end if;
- end Write_Kind;
-
- -- Start of processing for Write_Entity_Info
-
- begin
- Write_Eol;
- Write_Attribute ("Name ", Id);
- Write_Int (Int (Id));
- Write_Eol;
- Write_Kind (Id);
- Write_Eol;
- Write_Attribute (" Type ", Etype (Id));
- Write_Eol;
- if Id /= Standard_Standard then
- Write_Attribute (" Scope ", Scope (Id));
- end if;
- Write_Eol;
-
- case Ekind (Id) is
- when Discrete_Kind =>
- Write_Str ("Bounds: Id = ");
-
- if Present (Scalar_Range (Id)) then
- Write_Int (Int (Type_Low_Bound (Id)));
- Write_Str (" .. Id = ");
- Write_Int (Int (Type_High_Bound (Id)));
- else
- Write_Str ("Empty");
- end if;
-
- Write_Eol;
-
- when Array_Kind =>
- declare
- Index : Entity_Id;
-
- begin
- Write_Attribute
- (" Component Type ", Component_Type (Id));
- Write_Eol;
- Write_Str (Prefix);
- Write_Str (" Indexes ");
-
- Index := First_Index (Id);
- while Present (Index) loop
- Write_Attribute (" ", Etype (Index));
- Index := Next_Index (Index);
- end loop;
-
- Write_Eol;
- end;
-
- when Access_Kind =>
- Write_Attribute
- (" Directly Designated Type ",
- Directly_Designated_Type (Id));
- Write_Eol;
-
- when Overloadable_Kind =>
- if Present (Homonym (Id)) then
- Write_Str (" Homonym ");
- Write_Name (Chars (Homonym (Id)));
- Write_Str (" ");
- Write_Int (Int (Homonym (Id)));
- Write_Eol;
- end if;
-
- Write_Eol;
-
- when E_Component =>
- if Ekind (Scope (Id)) in Record_Kind then
- Write_Attribute (
- " Original_Record_Component ",
- Original_Record_Component (Id));
- Write_Int (Int (Original_Record_Component (Id)));
- Write_Eol;
- end if;
-
- when others =>
- null;
- end case;
- end Write_Entity_Info;
-
- -----------------------
- -- Write_Field6_Name --
- -----------------------
-
- procedure Write_Field6_Name (Id : Entity_Id) is
- pragma Unreferenced (Id);
- begin
- Write_Str ("First_Rep_Item");
- end Write_Field6_Name;
-
- -----------------------
- -- Write_Field7_Name --
- -----------------------
-
- procedure Write_Field7_Name (Id : Entity_Id) is
- pragma Unreferenced (Id);
- begin
- Write_Str ("Freeze_Node");
- end Write_Field7_Name;
-
- -----------------------
- -- Write_Field8_Name --
- -----------------------
-
- procedure Write_Field8_Name (Id : Entity_Id) is
- begin
- case Ekind (Id) is
- when Type_Kind =>
- Write_Str ("Associated_Node_For_Itype");
-
- when E_Package =>
- Write_Str ("Dependent_Instances");
-
- when E_Loop =>
- Write_Str ("First_Exit_Statement");
-
- when E_Variable =>
- Write_Str ("Hiding_Loop_Variable");
-
- when Formal_Kind
- | E_Function
- | E_Subprogram_Body
- =>
- Write_Str ("Mechanism");
-
- when E_Component
- | E_Discriminant
- =>
- Write_Str ("Normalized_First_Bit");
-
- when E_Abstract_State =>
- Write_Str ("Refinement_Constituents");
-
- when E_Block
- | E_Return_Statement
- =>
- Write_Str ("Return_Applies_To");
-
- when others =>
- Write_Str ("Field8??");
- end case;
- end Write_Field8_Name;
-
- -----------------------
- -- Write_Field9_Name --
- -----------------------
-
- procedure Write_Field9_Name (Id : Entity_Id) is
- begin
- case Ekind (Id) is
- when Type_Kind =>
- Write_Str ("Class_Wide_Type");
-
- when Object_Kind =>
- Write_Str ("Current_Value");
-
- when E_Function
- | E_Generic_Function
- | E_Generic_Package
- | E_Generic_Procedure
- | E_Package
- | E_Procedure
- =>
- Write_Str ("Renaming_Map");
-
- when others =>
- Write_Str ("Field9??");
- end case;
- end Write_Field9_Name;
-
- ------------------------
- -- Write_Field10_Name --
- ------------------------
-
- procedure Write_Field10_Name (Id : Entity_Id) is
- begin
- case Ekind (Id) is
- when Class_Wide_Kind
- | Incomplete_Kind
- | E_Record_Type
- | E_Record_Subtype
- | Private_Kind
- | Concurrent_Kind
- =>
- Write_Str ("Direct_Primitive_Operations");
-
- when E_Constant
- | E_In_Parameter
- =>
- Write_Str ("Discriminal_Link");
-
- when Float_Kind =>
- Write_Str ("Float_Rep");
-
- when E_Function
- | E_Package
- | E_Package_Body
- | E_Procedure
- =>
- Write_Str ("Handler_Records");
-
- when E_Component
- | E_Discriminant
- =>
- Write_Str ("Normalized_Position_Max");
-
- when E_Abstract_State
- | E_Variable
- =>
- Write_Str ("Part_Of_Constituents");
-
- when others =>
- Write_Str ("Field10??");
- end case;
- end Write_Field10_Name;
-
- ------------------------
- -- Write_Field11_Name --
- ------------------------
-
- procedure Write_Field11_Name (Id : Entity_Id) is
- begin
- case Ekind (Id) is
- when E_Block =>
- Write_Str ("Block_Node");
-
- when E_Component
- | E_Discriminant
- =>
- Write_Str ("Component_Bit_Offset");
-
- when Formal_Kind =>
- Write_Str ("Entry_Component");
-
- when E_Enumeration_Literal =>
- Write_Str ("Enumeration_Pos");
-
- when Type_Kind
- | E_Constant
- =>
- Write_Str ("Full_View");
-
- when E_Generic_Package =>
- Write_Str ("Generic_Homonym");
-
- when E_Variable =>
- Write_Str ("Part_Of_References");
-
- when E_Entry
- | E_Entry_Family
- | E_Function
- | E_Procedure
- =>
- Write_Str ("Protected_Body_Subprogram");
-
- when others =>
- Write_Str ("Field11??");
- end case;
- end Write_Field11_Name;
-
- ------------------------
- -- Write_Field12_Name --
- ------------------------
-
- procedure Write_Field12_Name (Id : Entity_Id) is
- begin
- case Ekind (Id) is
- when E_Package =>
- Write_Str ("Associated_Formal_Package");
-
- when Entry_Kind =>
- Write_Str ("Barrier_Function");
-
- when E_Enumeration_Literal =>
- Write_Str ("Enumeration_Rep");
-
- when Type_Kind
- | E_Component
- | E_Constant
- | E_Discriminant
- | E_Exception
- | E_In_Parameter
- | E_In_Out_Parameter
- | E_Out_Parameter
- | E_Loop_Parameter
- | E_Variable
- =>
- Write_Str ("Esize");
-
- when E_Function
- | E_Procedure
- =>
- Write_Str ("Next_Inlined_Subprogram");
-
- when others =>
- Write_Str ("Field12??");
- end case;
- end Write_Field12_Name;
-
- ------------------------
- -- Write_Field13_Name --
- ------------------------
-
- procedure Write_Field13_Name (Id : Entity_Id) is
- begin
- case Ekind (Id) is
- when E_Component
- | E_Discriminant
- =>
- Write_Str ("Component_Clause");
-
- when E_Entry
- | E_Entry_Family
- | E_Function
- | E_Procedure
- | E_Package
- | Generic_Unit_Kind
- =>
- Write_Str ("Elaboration_Entity");
-
- when Formal_Kind
- | E_Variable
- =>
- Write_Str ("Extra_Accessibility");
-
- when Type_Kind =>
- Write_Str ("RM_Size");
-
- when others =>
- Write_Str ("Field13??");
- end case;
- end Write_Field13_Name;
-
- -----------------------
- -- Write_Field14_Name --
- -----------------------
-
- procedure Write_Field14_Name (Id : Entity_Id) is
- begin
- case Ekind (Id) is
- when Type_Kind
- | Formal_Kind
- | E_Constant
- | E_Exception
- | E_Loop_Parameter
- | E_Variable
- =>
- Write_Str ("Alignment");
-
- when E_Component
- | E_Discriminant
- =>
- Write_Str ("Normalized_Position");
-
- when E_Entry
- | E_Entry_Family
- | E_Function
- | E_Procedure
- =>
- Write_Str ("Postconditions_Proc");
-
- when others =>
- Write_Str ("Field14??");
- end case;
- end Write_Field14_Name;
-
- ------------------------
- -- Write_Field15_Name --
- ------------------------
-
- procedure Write_Field15_Name (Id : Entity_Id) is
- begin
- case Ekind (Id) is
- when E_Discriminant =>
- Write_Str ("Discriminant_Number");
-
- when E_Component =>
- Write_Str ("DT_Entry_Count");
-
- when E_Function
- | E_Procedure
- =>
- Write_Str ("DT_Position");
-
- when Entry_Kind =>
- Write_Str ("Entry_Parameters_Type");
-
- when Formal_Kind =>
- Write_Str ("Extra_Formal");
-
- when Type_Kind =>
- Write_Str ("Pending_Access_Types");
-
- when E_Package
- | E_Package_Body
- =>
- Write_Str ("Related_Instance");
-
- when E_Constant
- | E_Loop_Parameter
- | E_Variable
- =>
- Write_Str ("Status_Flag_Or_Transient_Decl");
-
- when others =>
- Write_Str ("Field15??");
- end case;
- end Write_Field15_Name;
-
- ------------------------
- -- Write_Field16_Name --
- ------------------------
-
- procedure Write_Field16_Name (Id : Entity_Id) is
- begin
- case Ekind (Id) is
- when E_Record_Type
- | E_Record_Type_With_Private
- =>
- Write_Str ("Access_Disp_Table");
-
- when E_Abstract_State =>
- Write_Str ("Body_References");
-
- when E_Class_Wide_Subtype
- | E_Record_Subtype
- =>
- Write_Str ("Cloned_Subtype");
-
- when E_Function
- | E_Procedure
- =>
- Write_Str ("DTC_Entity");
-
- when E_Component =>
- Write_Str ("Entry_Formal");
-
- when Concurrent_Kind
- | E_Generic_Package
- | E_Package
- =>
- Write_Str ("First_Private_Entity");
-
- when Enumeration_Kind =>
- Write_Str ("Lit_Strings");
-
- when Decimal_Fixed_Point_Kind =>
- Write_Str ("Scale_Value");
-
- when E_String_Literal_Subtype =>
- Write_Str ("String_Literal_Length");
-
- when E_Out_Parameter
- | E_Variable
- =>
- Write_Str ("Unset_Reference");
-
- when others =>
- Write_Str ("Field16??");
- end case;
- end Write_Field16_Name;
-
- ------------------------
- -- Write_Field17_Name --
- ------------------------
-
- procedure Write_Field17_Name (Id : Entity_Id) is
- begin
- case Ekind (Id) is
- when Formal_Kind
- | E_Constant
- | E_Generic_In_Out_Parameter
- | E_Variable
- =>
- Write_Str ("Actual_Subtype");
-
- when Digits_Kind =>
- Write_Str ("Digits_Value");
-
- when E_Discriminant =>
- Write_Str ("Discriminal");
-
- when Class_Wide_Kind
- | Concurrent_Kind
- | Private_Kind
- | E_Block
- | E_Entry
- | E_Entry_Family
- | E_Function
- | E_Generic_Function
- | E_Generic_Package
- | E_Generic_Procedure
- | E_Loop
- | E_Operator
- | E_Package
- | E_Package_Body
- | E_Procedure
- | E_Record_Type
- | E_Record_Subtype
- | E_Return_Statement
- | E_Subprogram_Body
- | E_Subprogram_Type
- =>
- Write_Str ("First_Entity");
-
- when Array_Kind =>
- Write_Str ("First_Index");
-
- when Enumeration_Kind =>
- Write_Str ("First_Literal");
-
- when Access_Kind =>
- Write_Str ("Master_Id");
-
- when Modular_Integer_Kind =>
- Write_Str ("Modulus");
-
- when E_Component =>
- Write_Str ("Prival");
-
- when others =>
- Write_Str ("Field17??");
- end case;
- end Write_Field17_Name;
-
- ------------------------
- -- Write_Field18_Name --
- ------------------------
-
- procedure Write_Field18_Name (Id : Entity_Id) is
- begin
- case Ekind (Id) is
- when E_Enumeration_Literal
- | E_Function
- | E_Operator
- | E_Procedure
- =>
- Write_Str ("Alias");
-
- when E_Record_Type =>
- Write_Str ("Corresponding_Concurrent_Type");
-
- when E_Subprogram_Body =>
- Write_Str ("Corresponding_Protected_Entry");
-
- when Concurrent_Kind =>
- Write_Str ("Corresponding_Record_Type");
-
- when E_Block
- | E_Label
- | E_Loop
- =>
- Write_Str ("Enclosing_Scope");
-
- when E_Entry_Index_Parameter =>
- Write_Str ("Entry_Index_Constant");
-
- when E_Access_Protected_Subprogram_Type
- | E_Access_Subprogram_Type
- | E_Anonymous_Access_Protected_Subprogram_Type
- | E_Exception_Type
- | E_Class_Wide_Subtype
- =>
- Write_Str ("Equivalent_Type");
-
- when Fixed_Point_Kind =>
- Write_Str ("Delta_Value");
-
- when Enumeration_Kind =>
- Write_Str ("Lit_Indexes");
-
- when Incomplete_Or_Private_Kind
- | E_Record_Subtype
- =>
- Write_Str ("Private_Dependents");
-
- when E_Exception
- | E_Generic_Function
- | E_Generic_Package
- | E_Generic_Procedure
- | E_Package
- =>
- Write_Str ("Renamed_Entity");
-
- when Object_Kind =>
- Write_Str ("Renamed_Object");
-
- when E_String_Literal_Subtype =>
- Write_Str ("String_Literal_Low_Bound");
-
- when others =>
- Write_Str ("Field18??");
- end case;
- end Write_Field18_Name;
-
- -----------------------
- -- Write_Field19_Name --
- -----------------------
-
- procedure Write_Field19_Name (Id : Entity_Id) is
- begin
- case Ekind (Id) is
- when E_Generic_Package
- | E_Package
- =>
- Write_Str ("Body_Entity");
-
- when E_Discriminant =>
- Write_Str ("Corresponding_Discriminant");
-
- when Scalar_Kind =>
- Write_Str ("Default_Aspect_Value");
-
- when E_Array_Type =>
- Write_Str ("Default_Component_Value");
-
- when E_Protected_Type =>
- Write_Str ("Entry_Bodies_Array");
-
- when E_Function
- | E_Operator
- | E_Subprogram_Type
- =>
- Write_Str ("Extra_Accessibility_Of_Result");
-
- when E_Abstract_State
- | E_Class_Wide_Type
- | E_Incomplete_Type
- =>
- Write_Str ("Non_Limited_View");
-
- when E_Incomplete_Subtype =>
- if From_Limited_With (Id) then
- Write_Str ("Non_Limited_View");
- end if;
-
- when E_Record_Type =>
- Write_Str ("Parent_Subtype");
-
- when E_Procedure =>
- Write_Str ("Receiving_Entry");
-
- when E_Constant
- | E_Variable
- =>
- Write_Str ("Size_Check_Code");
-
- when Formal_Kind
- | E_Package_Body
- =>
- Write_Str ("Spec_Entity");
-
- when Private_Kind =>
- Write_Str ("Underlying_Full_View");
-
- when others =>
- Write_Str ("Field19??");
- end case;
- end Write_Field19_Name;
-
- -----------------------
- -- Write_Field20_Name --
- -----------------------
-
- procedure Write_Field20_Name (Id : Entity_Id) is
- begin
- case Ekind (Id) is
- when Array_Kind =>
- Write_Str ("Component_Type");
-
- when E_Generic_In_Parameter
- | E_In_Parameter
- =>
- Write_Str ("Default_Value");
-
- when Access_Kind =>
- Write_Str ("Directly_Designated_Type");
-
- when E_Component =>
- Write_Str ("Discriminant_Checking_Func");
-
- when E_Discriminant =>
- Write_Str ("Discriminant_Default_Value");
-
- when Class_Wide_Kind
- | Concurrent_Kind
- | Private_Kind
- | E_Block
- | E_Entry
- | E_Entry_Family
- | E_Function
- | E_Generic_Function
- | E_Generic_Package
- | E_Generic_Procedure
- | E_Loop
- | E_Operator
- | E_Package
- | E_Package_Body
- | E_Procedure
- | E_Record_Type
- | E_Record_Subtype
- | E_Return_Statement
- | E_Subprogram_Body
- | E_Subprogram_Type
- =>
- Write_Str ("Last_Entity");
-
- when E_Constant
- | E_Variable
- =>
- Write_Str ("Prival_Link");
-
- when E_Exception =>
- Write_Str ("Register_Exception_Call");
-
- when Scalar_Kind =>
- Write_Str ("Scalar_Range");
-
- when others =>
- Write_Str ("Field20??");
- end case;
- end Write_Field20_Name;
-
- -----------------------
- -- Write_Field21_Name --
- -----------------------
-
- procedure Write_Field21_Name (Id : Entity_Id) is
- begin
- case Ekind (Id) is
- when Entry_Kind =>
- Write_Str ("Accept_Address");
-
- when E_Component
- | E_Discriminant
- =>
- Write_Str ("Corresponding_Record_Component");
-
- when E_In_Parameter =>
- Write_Str ("Default_Expr_Function");
-
- when Concurrent_Kind
- | Incomplete_Or_Private_Kind
- | Class_Wide_Kind
- | E_Record_Type
- | E_Record_Subtype
- =>
- Write_Str ("Discriminant_Constraint");
-
- when E_Constant
- | E_Exception
- | E_Function
- | E_Generic_Function
- | E_Generic_Procedure
- | E_Procedure
- | E_Variable
- =>
- Write_Str ("Interface_Name");
-
- when Array_Kind
- | Modular_Integer_Kind
- =>
- Write_Str ("Original_Array_Type");
-
- when Fixed_Point_Kind =>
- Write_Str ("Small_Value");
-
- when others =>
- Write_Str ("Field21??");
- end case;
- end Write_Field21_Name;
-
- -----------------------
- -- Write_Field22_Name --
- -----------------------
-
- procedure Write_Field22_Name (Id : Entity_Id) is
- begin
- case Ekind (Id) is
- when Access_Kind =>
- Write_Str ("Associated_Storage_Pool");
-
- when Array_Kind =>
- Write_Str ("Component_Size");
-
- when E_Record_Type =>
- Write_Str ("Corresponding_Remote_Type");
-
- when E_Component
- | E_Discriminant
- =>
- Write_Str ("Original_Record_Component");
-
- when E_Enumeration_Literal =>
- Write_Str ("Enumeration_Rep_Expr");
-
- when Formal_Kind =>
- Write_Str ("Protected_Formal");
-
- when Concurrent_Kind
- | Entry_Kind
- | Generic_Unit_Kind
- | E_Package
- | E_Package_Body
- | Subprogram_Kind
- | E_Block
- | E_Subprogram_Body
- | E_Private_Type .. E_Limited_Private_Subtype
- | E_Void
- | E_Loop
- | E_Return_Statement
- =>
- Write_Str ("Scope_Depth_Value");
-
- when E_Variable =>
- Write_Str ("Shared_Var_Procs_Instance");
-
- when others =>
- Write_Str ("Field22??");
- end case;
- end Write_Field22_Name;
-
- ------------------------
- -- Write_Field23_Name --
- ------------------------
-
- procedure Write_Field23_Name (Id : Entity_Id) is
- begin
- case Ekind (Id) is
- when E_Discriminant =>
- Write_Str ("CR_Discriminant");
-
- when E_Block =>
- Write_Str ("Entry_Cancel_Parameter");
-
- when E_Enumeration_Type =>
- Write_Str ("Enum_Pos_To_Rep");
-
- when Formal_Kind
- | E_Variable
- =>
- Write_Str ("Extra_Constrained");
-
- when Access_Kind =>
- Write_Str ("Finalization_Master");
-
- when E_Generic_Function
- | E_Generic_Package
- | E_Generic_Procedure
- =>
- Write_Str ("Inner_Instances");
-
- when Array_Kind =>
- Write_Str ("Packed_Array_Impl_Type");
-
- when Entry_Kind =>
- Write_Str ("Protection_Object");
-
- when Class_Wide_Kind
- | Concurrent_Kind
- | Incomplete_Or_Private_Kind
- | E_Record_Type
- | E_Record_Subtype
- =>
- Write_Str ("Stored_Constraint");
-
- when E_Function
- | E_Procedure
- =>
- if Present (Scope (Id))
- and then Is_Protected_Type (Scope (Id))
- then
- Write_Str ("Protection_Object");
- else
- Write_Str ("Generic_Renamings");
- end if;
-
- when E_Package =>
- if Is_Generic_Instance (Id) then
- Write_Str ("Generic_Renamings");
- else
- Write_Str ("Limited_View");
- end if;
-
- when others =>
- Write_Str ("Field23??");
- end case;
- end Write_Field23_Name;
-
- ------------------------
- -- Write_Field24_Name --
- ------------------------
-
- procedure Write_Field24_Name (Id : Entity_Id) is
- begin
- case Ekind (Id) is
- when E_Package =>
- Write_Str ("Incomplete_Actuals");
-
- when Type_Kind
- | E_Constant
- | E_Loop_Parameter
- | E_Variable
- =>
- Write_Str ("Related_Expression");
-
- when Formal_Kind =>
- Write_Str ("Minimum_Accessibility");
-
- when E_Function
- | E_Operator
- | E_Procedure
- =>
- Write_Str ("Subps_Index");
-
- when others =>
- Write_Str ("Field24???");
- end case;
- end Write_Field24_Name;
-
- ------------------------
- -- Write_Field25_Name --
- ------------------------
-
- procedure Write_Field25_Name (Id : Entity_Id) is
- begin
- case Ekind (Id) is
- when E_Generic_Package
- | E_Package
- =>
- Write_Str ("Abstract_States");
-
- when E_Entry
- | E_Entry_Family
- =>
- Write_Str ("Contract_Wrapper");
-
- when E_Variable =>
- Write_Str ("Debug_Renaming_Link");
-
- when E_Component =>
- Write_Str ("DT_Offset_To_Top_Func");
-
- when E_Function
- | E_Procedure
- =>
- Write_Str ("Interface_Alias");
-
- when E_Record_Subtype
- | E_Record_Subtype_With_Private
- | E_Record_Type
- | E_Record_Type_With_Private
- =>
- Write_Str ("Interfaces");
-
- when E_Array_Subtype
- | E_Array_Type
- =>
- Write_Str ("Related_Array_Object");
-
- when Discrete_Kind =>
- Write_Str ("Static_Discrete_Predicate");
-
- when Real_Kind =>
- Write_Str ("Static_Real_Or_String_Predicate");
-
- when Task_Kind =>
- Write_Str ("Task_Body_Procedure");
-
- when others =>
- Write_Str ("Field25??");
- end case;
- end Write_Field25_Name;
-
- ------------------------
- -- Write_Field26_Name --
- ------------------------
-
- procedure Write_Field26_Name (Id : Entity_Id) is
- begin
- case Ekind (Id) is
- when E_Record_Type
- | E_Record_Type_With_Private
- =>
- Write_Str ("Dispatch_Table_Wrappers");
-
- when E_In_Out_Parameter
- | E_Out_Parameter
- | E_Variable
- =>
- Write_Str ("Last_Assignment");
-
- when E_Function
- | E_Procedure
- =>
- Write_Str ("Overridden_Operation");
-
- when E_Generic_Package
- | E_Package
- =>
- Write_Str ("Package_Instantiation");
-
- when E_Component
- | E_Constant
- =>
- Write_Str ("Related_Type");
-
- when Access_Kind
- | Task_Kind
- =>
- Write_Str ("Storage_Size_Variable");
-
- when others =>
- Write_Str ("Field26??");
- end case;
- end Write_Field26_Name;
-
- ------------------------
- -- Write_Field27_Name --
- ------------------------
-
- procedure Write_Field27_Name (Id : Entity_Id) is
- begin
- case Ekind (Id) is
- when Type_Kind
- | E_Package
- =>
- Write_Str ("Current_Use_Clause");
-
- when E_Component
- | E_Constant
- | E_Variable
- =>
- Write_Str ("Related_Type");
-
- when E_Function
- | E_Procedure
- =>
- Write_Str ("Wrapped_Entity");
-
- when others =>
- Write_Str ("Field27??");
- end case;
- end Write_Field27_Name;
-
- ------------------------
- -- Write_Field28_Name --
- ------------------------
-
- procedure Write_Field28_Name (Id : Entity_Id) is
- begin
- case Ekind (Id) is
- when E_Entry
- | E_Entry_Family
- | E_Function
- | E_Procedure
- | E_Subprogram_Body
- | E_Subprogram_Type
- =>
- Write_Str ("Extra_Formals");
-
- when E_Package
- | E_Package_Body
- =>
- Write_Str ("Finalizer");
-
- when E_Constant
- | E_Variable
- =>
- Write_Str ("Initialization_Statements");
-
- when E_Access_Subprogram_Type =>
- Write_Str ("Original_Access_Type");
-
- when Task_Kind =>
- Write_Str ("Relative_Deadline_Variable");
-
- when E_Record_Type =>
- Write_Str ("Underlying_Record_View");
-
- when others =>
- Write_Str ("Field28??");
- end case;
- end Write_Field28_Name;
-
- ------------------------
- -- Write_Field29_Name --
- ------------------------
-
- procedure Write_Field29_Name (Id : Entity_Id) is
- begin
- case Ekind (Id) is
- when E_Function
- | E_Package
- | E_Procedure
- | E_Subprogram_Body
- =>
- Write_Str ("Anonymous_Masters");
-
- when E_Constant
- | E_Variable
- =>
- Write_Str ("BIP_Initialization_Call");
-
- when Type_Kind =>
- Write_Str ("Subprograms_For_Type");
-
- when others =>
- Write_Str ("Field29??");
- end case;
- end Write_Field29_Name;
-
- ------------------------
- -- Write_Field30_Name --
- ------------------------
-
- procedure Write_Field30_Name (Id : Entity_Id) is
- begin
- case Ekind (Id) is
- when E_Record_Type
- | E_Record_Type_With_Private
- =>
- Write_Str ("Access_Disp_Table_Elab_Flag");
-
- when E_Protected_Type
- | E_Task_Type
- =>
- Write_Str ("Anonymous_Object");
-
- when E_Function =>
- Write_Str ("Corresponding_Equality");
-
- when E_Constant
- | E_Variable
- =>
- Write_Str ("Last_Aggregate_Assignment");
-
- when E_Procedure =>
- Write_Str ("Static_Initialization");
-
- when others =>
- Write_Str ("Field30??");
- end case;
- end Write_Field30_Name;
-
- ------------------------
- -- Write_Field31_Name --
- ------------------------
-
- procedure Write_Field31_Name (Id : Entity_Id) is
- begin
- case Ekind (Id) is
- when E_Constant
- | E_In_Parameter
- | E_In_Out_Parameter
- | E_Loop_Parameter
- | E_Out_Parameter
- | E_Variable
- =>
- Write_Str ("Activation_Record_Component");
-
- when Type_Kind =>
- Write_Str ("Derived_Type_Link");
-
- when E_Function
- | E_Procedure
- =>
- Write_Str ("Thunk_Entity");
-
- when others =>
- Write_Str ("Field31??");
- end case;
- end Write_Field31_Name;
-
- ------------------------
- -- Write_Field32_Name --
- ------------------------
-
- procedure Write_Field32_Name (Id : Entity_Id) is
- begin
- case Ekind (Id) is
- when E_Procedure =>
- Write_Str ("Corresponding_Function");
-
- when E_Function =>
- Write_Str ("Corresponding_Procedure");
-
- when E_Abstract_State
- | E_Constant
- | E_Variable
- =>
- Write_Str ("Encapsulating_State");
-
- when Type_Kind =>
- Write_Str ("No_Tagged_Streams_Pragma");
-
- when others =>
- Write_Str ("Field32??");
- end case;
- end Write_Field32_Name;
-
- ------------------------
- -- Write_Field33_Name --
- ------------------------
-
- procedure Write_Field33_Name (Id : Entity_Id) is
- begin
- case Ekind (Id) is
- when Subprogram_Kind
- | Type_Kind
- | E_Constant
- | E_Variable
- =>
- Write_Str ("Linker_Section_Pragma");
-
- when others =>
- Write_Str ("Field33??");
- end case;
- end Write_Field33_Name;
-
- ------------------------
- -- Write_Field34_Name --
- ------------------------
-
- procedure Write_Field34_Name (Id : Entity_Id) is
- begin
- case Ekind (Id) is
- when E_Constant
- | E_Entry
- | E_Entry_Family
- | E_Function
- | E_Generic_Function
- | E_Generic_Package
- | E_Generic_Procedure
- | E_Operator
- | E_Package
- | E_Package_Body
- | E_Procedure
- | E_Subprogram_Body
- | E_Task_Body
- | E_Variable
- | Type_Kind
- | E_Void
- =>
- Write_Str ("Contract");
-
- when others =>
- Write_Str ("Field34??");
- end case;
- end Write_Field34_Name;
-
- ------------------------
- -- Write_Field35_Name --
- ------------------------
-
- procedure Write_Field35_Name (Id : Entity_Id) is
- begin
- case Ekind (Id) is
- when E_Variable =>
- Write_Str ("Anonymous_Designated_Type");
-
- when E_Entry
- | E_Entry_Family
- =>
- Write_Str ("Entry_Max_Queue_Lenghts_Array");
-
- when Subprogram_Kind =>
- Write_Str ("Import_Pragma");
-
- when others =>
- Write_Str ("Field35??");
- end case;
- end Write_Field35_Name;
-
- ------------------------
- -- Write_Field36_Name --
- ------------------------
-
- procedure Write_Field36_Name (Id : Entity_Id) is
- pragma Unreferenced (Id);
- begin
- Write_Str ("Prev_Entity");
- end Write_Field36_Name;
-
- ------------------------
- -- Write_Field37_Name --
- ------------------------
-
- procedure Write_Field37_Name (Id : Entity_Id) is
- pragma Unreferenced (Id);
- begin
- Write_Str ("Associated_Entity");
- end Write_Field37_Name;
-
- ------------------------
- -- Write_Field38_Name --
- ------------------------
-
- procedure Write_Field38_Name (Id : Entity_Id) is
- begin
- case Ekind (Id) is
- when E_Function
- | E_Procedure
- =>
- Write_Str ("Class_Wide_Clone");
-
- when E_Array_Subtype
- | E_Record_Subtype
- | E_Record_Subtype_With_Private
- =>
- Write_Str ("Predicated_Parent");
-
- when E_Variable =>
- Write_Str ("Validated_Object");
-
- when others =>
- Write_Str ("Field38??");
- end case;
- end Write_Field38_Name;
-
- ------------------------
- -- Write_Field39_Name --
- ------------------------
-
- procedure Write_Field39_Name (Id : Entity_Id) is
- begin
- case Ekind (Id) is
- when E_Function
- | E_Procedure
- =>
- Write_Str ("Protected_Subprogram");
-
- when others =>
- Write_Str ("Field39??");
- end case;
- end Write_Field39_Name;
-
- ------------------------
- -- Write_Field40_Name --
- ------------------------
-
- procedure Write_Field40_Name (Id : Entity_Id) is
- begin
- case Ekind (Id) is
- when E_Abstract_State
- | E_Constant
- | E_Entry
- | E_Entry_Family
- | E_Function
- | E_Generic_Function
- | E_Generic_Package
- | E_Generic_Procedure
- | E_Operator
- | E_Package
- | E_Package_Body
- | E_Procedure
- | E_Protected_Body
- | E_Subprogram_Body
- | E_Task_Body
- | E_Variable
- | E_Void
- | Type_Kind
- =>
- Write_Str ("SPARK_Pragma");
-
- when others =>
- Write_Str ("Field40??");
- end case;
- end Write_Field40_Name;
-
- ------------------------
- -- Write_Field41_Name --
- ------------------------
-
- procedure Write_Field41_Name (Id : Entity_Id) is
- begin
- case Ekind (Id) is
- when E_Function
- | E_Procedure
- =>
- Write_Str ("Original_Protected_Subprogram");
-
- when E_Generic_Package
- | E_Package
- | E_Package_Body
- | E_Protected_Type
- | E_Task_Type
- =>
- Write_Str ("SPARK_Aux_Pragma");
-
- when E_Subprogram_Type =>
- Write_Str ("Access_Subprogram_Wrapper");
-
- when others =>
- Write_Str ("Field41??");
- end case;
- end Write_Field41_Name;
-
- -------------------------
- -- Iterator Procedures --
- -------------------------
-
- procedure Proc_Next_Component (N : in out Node_Id) is
- begin
- N := Next_Component (N);
- end Proc_Next_Component;
-
- procedure Proc_Next_Component_Or_Discriminant (N : in out Node_Id) is
- begin
- N := Next_Entity (N);
- while Present (N) loop
- exit when Ekind (N) in E_Component | E_Discriminant;
- N := Next_Entity (N);
- end loop;
- end Proc_Next_Component_Or_Discriminant;
-
- procedure Proc_Next_Discriminant (N : in out Node_Id) is
- begin
- N := Next_Discriminant (N);
- end Proc_Next_Discriminant;
-
- procedure Proc_Next_Formal (N : in out Node_Id) is
- begin
- N := Next_Formal (N);
- end Proc_Next_Formal;
-
- procedure Proc_Next_Formal_With_Extras (N : in out Node_Id) is
- begin
- N := Next_Formal_With_Extras (N);
- end Proc_Next_Formal_With_Extras;
-
- procedure Proc_Next_Index (N : in out Node_Id) is
- begin
- N := Next_Index (N);
- end Proc_Next_Index;
-
- procedure Proc_Next_Inlined_Subprogram (N : in out Node_Id) is
- begin
- N := Next_Inlined_Subprogram (N);
- end Proc_Next_Inlined_Subprogram;
-
- procedure Proc_Next_Literal (N : in out Node_Id) is
- begin
- N := Next_Literal (N);
- end Proc_Next_Literal;
-
- procedure Proc_Next_Stored_Discriminant (N : in out Node_Id) is
- begin
- N := Next_Stored_Discriminant (N);
- end Proc_Next_Stored_Discriminant;
-
-end Einfo;
+pragma No_Body;
diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads
index cc0c815..e87ce4c 100644
--- a/gcc/ada/einfo.ads
+++ b/gcc/ada/einfo.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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,28 +23,31 @@
-- --
------------------------------------------------------------------------------
+pragma Warnings (Off); -- with/use clauses for children
+with Namet; use Namet;
with Snames; use Snames;
+with Stand; use Stand;
with Types; use Types;
with Uintp; use Uintp;
with Urealp; use Urealp;
+pragma Warnings (On);
package Einfo is
--- This package defines the annotations to the abstract syntax tree that
--- are needed to support semantic processing of an Ada compilation.
+-- This package documents the annotations to the abstract syntax tree that are
+-- needed to support semantic processing of an Ada compilation.
--- Note that after editing this spec and the corresponding body it is
--- required to run ceinfo to check the consistentcy of spec and body.
--- See ceinfo.adb for more information about the checks made.
+-- See the spec of Gen_IL.Gen for instructions on making changes to this file.
+-- Note that the official definition of what entities have what fields is in
+-- Gen_IL.Gen.Gen_Entities; if there is a discrepancy between that and the
+-- comments here, Gen_IL.Gen.Gen_Entities wins.
-- These annotations are for the most part attributes of declared entities,
-- and they correspond to conventional symbol table information. Other
-- attributes include sets of meanings for overloaded names, possible
-- types for overloaded expressions, flags to indicate deferred constants,
--- incomplete types, etc. These attributes are stored in available fields in
--- tree nodes (i.e. fields not used by the parser, as defined by the Sinfo
--- package specification), and accessed by means of a set of subprograms
--- which define an abstract interface.
+-- incomplete types, etc. These attributes are stored in fields in
+-- tree nodes.
-- There are two kinds of semantic information
@@ -63,61 +66,13 @@ package Einfo is
-- Second, in some cases semantic information is stored directly in other
-- kinds of nodes, e.g. the Etype field, used to indicate the type of an
--- expression. The access functions to these fields are defined in the
--- Sinfo package, but their full documentation is to be found in
--- the Einfo package specification.
+-- expression. These fields are defined in the Sinfo package, but their
+-- full documentation is in the Einfo package specification.
-- Declaration processing places information in the nodes of their defining
-- identifiers. Name resolution places in all other occurrences of an
-- identifier a pointer to the corresponding defining occurrence.
---------------------------------
--- The XEINFO Utility Program --
---------------------------------
-
--- XEINFO is a utility program which automatically produces a C header file,
--- einfo.h from the spec and body of package Einfo. It reads the input files
--- einfo.ads and einfo.adb and produces the output file einfo.h. XEINFO is run
--- automatically by the build scripts when you do a full bootstrap.
-
--- In order for this utility program to operate correctly, the form of the
--- einfo.ads and einfo.adb files must meet certain requirements and be laid
--- out in a specific manner.
-
--- The general form of einfo.ads is as follows:
-
--- type declaration for type Entity_Kind
--- subtype declarations declaring subranges of Entity_Kind
--- subtype declarations declaring synonyms for some standard types
--- function specs for attributes
--- procedure specs
--- pragma Inline declarations
-
--- This order must be observed. There are no restrictions on the procedures,
--- since the C header file only includes functions (The back end is not
--- allowed to modify the generated tree). However, functions are required to
--- have headers that fit on a single line.
-
--- XEINFO reads and processes the function specs and the pragma Inlines. For
--- functions that are declared as inlined, XEINFO reads the corresponding body
--- from einfo.adb, and processes it into C code. This results in some strict
--- restrictions on which functions can be inlined:
-
--- The function spec must be on a single line
-
--- There can only be a single return statement, not counting any pragma
--- Assert statements, possibly followed by a comment.
-
--- 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
--- the C code in the backend to directly call the corresponding Ada body.
-
----------------------------------
-- Handling of Type'Size Values --
----------------------------------
@@ -128,10 +83,10 @@ package Einfo is
-- default size of objects, creates chaos, and major incompatibilities in
-- existing code.
--- The Ada 2020 RM acknowledges it and adopts GNAT's Object_Size attribute
+-- The Ada 2022 RM acknowledges it and adopts GNAT's Object_Size attribute
-- for determining the default size of objects, but stops short of applying
-- it universally like GNAT. Indeed the notable exceptions are nonaliased
--- stand-alone objects, which are not covered by Object_Size in Ada 2020.
+-- stand-alone objects, which are not covered by Object_Size in Ada 2022.
-- We proceed as follows, for discrete and fixed-point subtypes, we have
-- two separate sizes for each subtype:
@@ -158,7 +113,7 @@ package Einfo is
-- base type, and the Object_Size of a derived first subtype is copied
-- from the parent first subtype.
--- The Ada 2020 RM defined attribute Object_Size uses this implementation.
+-- The Ada 2022 RM defined attribute Object_Size uses this implementation.
-- The Value_Size, which is the number of bits required to store a value
-- of the type. This size can be referred to using the Value_Size
@@ -197,7 +152,7 @@ package Einfo is
-- Value_Size and Object_Size may be explicitly set for any subtype using
-- an attribute definition clause. Note that the use of such a clause can
--- cause the RM 13.1(14) rule to be violated, in Ada 95 and 2020 for the
+-- cause the RM 13.1(14) rule to be violated, in Ada 95 and 2022 for the
-- Value_Size attribute, but only in Ada 95 for the Object_Size attribute.
-- If access types reference aliased objects whose subtypes have differing
-- Object_Size values as a result of explicit attribute definition clauses,
@@ -329,14 +284,22 @@ package Einfo is
-- type. The attribute can be referenced on a subtype (and automatically
-- retrieves the value from the implementation base type). However, it is an
-- error to try to set the attribute on other than the implementation base
--- type, and if assertions are enabled, an attempt to set the attribute on a
--- subtype will raise an assert error.
+-- type.
+
+-- Other attributes are noted as applying to the [root type only]. The
+-- attribute can be referenced on a subtype (and automatically retrieves the
+-- value from the root type). However, it is an error to try to set the
+-- attribute on other than the root type.
+
+-- The definitive definition of what is [... type only] is in Gen_Entities.
+-- See calls to Sm passing Base_Type_Only, Impl_Base_Type_Only, or
+-- Root_Type_Only.
--- Abstract_States (Elist25)
+-- Abstract_States
-- Defined for E_Package entities. Contains a list of all the abstract
-- states declared by the related package.
--- Accept_Address (Elist21)
+-- Accept_Address
-- Defined in entries. If an accept has a statement sequence, then an
-- address variable is created, which is used to hold the address of the
-- parameters, as passed by the runtime. Accept_Address holds an element
@@ -345,7 +308,7 @@ package Einfo is
-- on the list. A stack is required to handle the case of nested select
-- statements referencing the same entry.
--- Access_Disp_Table (Elist16) [implementation base type only]
+-- Access_Disp_Table [implementation base type only]
-- Defined in E_Record_Type and E_Record_Subtype entities. Set in tagged
-- types to point to their dispatch tables. The first two entities are
-- associated with the primary dispatch table: 1) primary dispatch table
@@ -359,7 +322,7 @@ package Einfo is
-- used to expand dispatching calls through the primary dispatch table.
-- For an untagged record, contains No_Elist.
--- Access_Disp_Table_Elab_Flag (Node30) [implementation base type only]
+-- Access_Disp_Table_Elab_Flag [implementation base type only]
-- Defined in E_Record_Type and E_Record_Subtype entities. Set in tagged
-- types whose dispatch table elaboration must be completed at run time
-- by the IP routine to point to its pending elaboration flag entity.
@@ -367,7 +330,7 @@ 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)
+-- Access_Subprogram_Wrapper
-- 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
@@ -376,13 +339,13 @@ package Einfo is
-- 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)
+-- Activation_Record_Component
-- Defined for E_Variable, E_Constant, E_Loop_Parameter, and formal
-- parameter entities. Used in Opt.Unnest_Subprogram_Mode, in which case
-- a reference to an uplevel entity produces a corresponding component
-- in the generated ARECnT activation record (Exp_Unst for details).
--- Actual_Subtype (Node17)
+-- Actual_Subtype
-- Defined in variables, constants, and formal parameters. This is the
-- subtype imposed by the value of the object, as opposed to its nominal
-- subtype, which is imposed by the declaration. The actual subtype
@@ -408,7 +371,7 @@ package Einfo is
-- defined before the entity to which the address clause applies.
-- Note: The backend references this field in E_Task_Type entities???
--- Address_Taken (Flag104)
+-- Address_Taken
-- Defined in all entities. Set if the Address or Unrestricted_Access
-- attribute is applied directly to the entity, i.e. the entity is the
-- entity of the prefix of the attribute reference. Also set if the
@@ -425,7 +388,7 @@ package Einfo is
-- needed after the decimal point to accommodate the delta of the type,
-- unless the delta is greater than 0.1, in which case it is 1.
--- Alias (Node18)
+-- Alias
-- Defined in overloadable entities (literals, subprograms, entries) and
-- subprograms that cover a primitive operation of an abstract interface
-- (that is, subprograms with the Interface_Alias attribute). In case of
@@ -439,7 +402,7 @@ package Einfo is
-- non-dispatching, and a call from inside calls the overriding operation
-- because it hides the implicit one. Alias is always empty for entries.
--- Alignment (Uint14)
+-- Alignment
-- Defined in entities for types and also in constants, variables
-- (including exceptions where it refers to the static data allocated for
-- an exception), loop parameters, and formal parameters. This indicates
@@ -462,32 +425,32 @@ package Einfo is
-- definition clause with an (obsolescent) mod clause is converted
-- into an attribute definition clause for this purpose.
--- Anonymous_Designated_Type (Node35)
+-- Anonymous_Designated_Type
-- Defined in variables which represent anonymous finalization masters.
-- Contains the designated type which is being serviced by the master.
--- Anonymous_Masters (Elist29)
+-- Anonymous_Masters
-- Defined in packages, subprograms, and subprogram bodies. Contains a
-- list of anonymous finalization masters declared within the related
-- unit. The list acts as a mapping between a master and a designated
-- type.
--- Anonymous_Object (Node30)
+-- Anonymous_Object
-- Present in protected and task type entities. Contains the entity of
-- the anonymous object created for a single protected or task type.
--- Associated_Entity (Node37)
+-- Associated_Entity
-- Defined in all entities. This field is similar to Associated_Node, but
-- applied to entities. The attribute links an entity from the generic
-- template with its corresponding entity in the analyzed generic copy.
-- The global references mechanism relies on the Associated_Entity to
-- infer the context.
--- Associated_Formal_Package (Node12)
+-- Associated_Formal_Package
-- Defined in packages that are the actuals of formal_packages. Points
-- to the entity in the declaration for the formal package.
--- Associated_Node_For_Itype (Node8)
+-- Associated_Node_For_Itype
-- Defined in all type and subtype entities. Set non-Empty only for
-- Itypes. Set to point to the associated node for the Itype, i.e.
-- the node whose elaboration generated the Itype. This is used for
@@ -509,14 +472,14 @@ package Einfo is
-- Itype is the only way to determine the construct that leads to the
-- creation of a given itype entity.
--- Associated_Storage_Pool (Node22) [root type only]
+-- Associated_Storage_Pool [root type only]
-- Defined in simple and general access type entities. References the
-- storage pool to be used for the corresponding collection. A value of
-- Empty means that the default pool is to be used. This is defined
-- only in the root type, since derived types must have the same pool
-- as the parent type.
--- Barrier_Function (Node12)
+-- Barrier_Function
-- Defined in protected entries and entry families. This is the
-- subprogram declaration for the body of the function that returns
-- the value of the entry barrier.
@@ -532,7 +495,7 @@ package Einfo is
-- apply Base_Type to other than a type, in which case it simply returns
-- the entity unchanged.
--- Block_Node (Node11)
+-- Block_Node
-- 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
@@ -542,16 +505,16 @@ package Einfo is
-- and not to the block_statement itself, because the statement may
-- be rewritten, e.g. in the process of removing dead code.
--- Body_Entity (Node19)
+-- Body_Entity
-- Defined in package and generic package entities, points to the
-- corresponding package body entity if one is present.
--- Body_Needed_For_SAL (Flag40)
+-- Body_Needed_For_SAL
-- Defined in package and subprogram entities that are compilation
-- units. Indicates that the source for the body must be included
-- when the unit is part of a standalone library.
--- Body_Needed_For_Inlining (Flag299)
+-- Body_Needed_For_Inlining
-- Defined in package entities that are compilation units. Used to
-- determine whether the body unit needs to be compiled when the
-- package declaration appears in the list of units to inline. A body
@@ -559,13 +522,13 @@ package Einfo is
-- functions that carry pragma Inline or Inline_Always, or if it
-- contains a generic unit that requires a body.
--
--- Body_References (Elist16)
+-- Body_References
-- Defined in abstract state entities. Contains an element list of
-- references (identifiers) that appear in a package body whose spec
-- defines the related state. If the body refines the said state, all
-- references on this list are illegal due to the visible refinement.
--- BIP_Initialization_Call (Node29)
+-- BIP_Initialization_Call
-- Defined in constants and variables whose corresponding declaration
-- is wrapped in a transient block and the inital value is provided by
-- a build-in-place function call. Contains the relocated build-in-place
@@ -573,7 +536,7 @@ package Einfo is
-- attribute is used by the finalization machinery to insert cleanup code
-- for all additional transient objects found in the transient block.
--- C_Pass_By_Copy (Flag125) [implementation base type only]
+-- C_Pass_By_Copy [implementation base type only]
-- Defined in record types. Set if a pragma Convention for the record
-- type specifies convention C_Pass_By_Copy. This convention name is
-- treated as identical in all respects to convention C, except that
@@ -583,7 +546,7 @@ package Einfo is
-- set to By_Copy (unless specifically overridden by an Import or
-- Export pragma).
--- Can_Never_Be_Null (Flag38)
+-- Can_Never_Be_Null
-- This flag is defined in all entities. It is set in an object which can
-- 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
@@ -598,7 +561,7 @@ package Einfo is
-- This is also set on some access types, e.g. the Etype of the anonymous
-- access type of a controlling formal.
--- Can_Use_Internal_Rep (Flag229) [base type only]
+-- Can_Use_Internal_Rep [base type only]
-- Defined in Access_Subprogram_Kind nodes. This flag is set by the
-- front end and used by the backend. False means that the backend
-- must represent the type in the same way as Convention-C types (and
@@ -629,7 +592,7 @@ package Einfo is
-- to have Can_Use_Internal_Rep False for an access type, but allow P to
-- have convention Ada.
--- Chars (Name1)
+-- Chars
-- Defined in all entities. This field contains an entry into the names
-- table that has the character string of the identifier, character
-- literal or operator symbol. See Namet for further details. Note that
@@ -640,26 +603,26 @@ package Einfo is
-- point (including post backend steps, e.g. cross-reference generation),
-- the entities will contain the encoded qualified names.
--- Checks_May_Be_Suppressed (Flag31)
+-- Checks_May_Be_Suppressed
-- Defined in all entities. Set if a pragma Suppress or Unsuppress
-- mentions the entity specifically in the second argument. If this
-- flag is set the Global_Entity_Suppress and Local_Entity_Suppress
-- tables must be consulted to determine if there actually is an active
-- Suppress or Unsuppress pragma that applies to the entity.
--- Class_Wide_Clone (Node38)
+-- Class_Wide_Clone
-- Defined on subprogram entities. Set if the subprogram has a class-wide
--- ore- or postcondition, and the expression contains calls to other
+-- pre- or postcondition, and the expression contains calls to other
-- primitive funtions of the type. Used to implement properly the
-- semantics of inherited operations whose class-wide condition may
-- be different from that of the ancestor (See AI012-0195).
--- Class_Wide_Type (Node9)
+-- Class_Wide_Type
-- Defined in all type entities. For a tagged type or subtype, returns
-- the corresponding implicitly declared class-wide type. For a
-- class-wide type, returns itself. Set to Empty for untagged types.
--- Cloned_Subtype (Node16)
+-- Cloned_Subtype
-- Defined in E_Record_Subtype and E_Class_Wide_Subtype entities.
-- Each such entity can either have a Discriminant_Constraint, in
-- which case it represents a distinct type from the base type (and
@@ -695,7 +658,7 @@ package Einfo is
-- the Component_Alignment pragma. Note: this field is currently
-- stored in a non-standard way, see body for details.
--- Component_Bit_Offset (Uint11)
+-- Component_Bit_Offset
-- Defined in record components (E_Component, E_Discriminant). First
-- bit position of given component, computed from the first bit and
-- position values given in the component clause. A value of No_Uint
@@ -706,14 +669,14 @@ package Einfo is
-- this field is always set. A negative value is used to represent
-- a value which is not known at compile time, and must be computed
-- at run-time (this happens if fields of a record have variable
--- lengths). See package Layout for details of these values.
+-- lengths). See package Repinfo for details of these values.
--
-- Note: Component_Bit_Offset is redundant with respect to the fields
-- Normalized_First_Bit and Normalized_Position, and could in principle
-- be eliminated, but it is convenient in several situations, including
-- use in the backend, to have this redundant field.
--- Component_Clause (Node13)
+-- Component_Clause
-- Defined in record components and discriminants. If a record
-- representation clause is present for the corresponding record type a
-- that specifies a position for the component, then the Component_Clause
@@ -721,70 +684,67 @@ package Einfo is
-- Set to Empty if no record representation clause was present, or if
-- there was no specification for this component.
--- Component_Size (Uint22) [implementation base type only]
+-- Component_Size [implementation base type only]
-- Defined in array types. It contains the component size value for
-- the array. A value of No_Uint means that the value is not yet set.
-- The value can be set by the use of a component size clause, or
-- by the front end in package Layout, or by the backend. A negative
-- value is used to represent a value which is not known at compile
-- time, and must be computed at run-time (this happens if the type
--- of the component has a variable length size). See package Layout
--- for details of these values.
+-- of the component has a variable length size). See package Repinfo
+-- for details of these values. Component_Size can also be negative in
+-- an illegal program that says e.g. "for T'Component_Size use -8;".
--- Component_Type (Node20) [implementation base type only]
+-- Component_Type [implementation base type only]
-- Defined in array types and string types. References component type.
--- Contains_Ignored_Ghost_Code (Flag279)
+-- Contains_Ignored_Ghost_Code
-- Defined in blocks, packages and their bodies, subprograms and their
-- bodies. Set if the entity contains any ignored Ghost code in the form
-- of declaration, procedure call, assignment statement or pragma.
--- Contract (Node34)
+-- Contract
-- Defined in constant, entry, entry family, operator, [generic] package,
-- 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)
+-- Contract_Wrapper
-- Defined in entry and entry family entities. Set only when the entry
-- [family] has contract cases, preconditions, and/or postconditions.
-- Contains the entity of a wrapper procedure which encapsulates the
-- original entry and implements precondition/postcondition semantics.
--- Corresponding_Concurrent_Type (Node18)
+-- Corresponding_Concurrent_Type
-- Defined in record types that are constructed by the expander to
-- represent task and protected types (Is_Concurrent_Record_Type flag
-- set). Points to the entity for the corresponding task type or the
-- protected type.
--- Corresponding_Discriminant (Node19)
+-- Corresponding_Discriminant
-- Defined in discriminants of a derived type, when the discriminant is
-- used to constrain a discriminant of the parent type. Points to the
-- corresponding discriminant in the parent type. Otherwise it is Empty.
--- Corresponding_Equality (Node30)
+-- Corresponding_Equality
-- Defined in function entities for implicit inequality operators.
-- Denotes the explicit or derived equality operation that creates
-- the implicit inequality. Note that this field is not present in
-- other function entities, only in implicit inequality routines,
-- where Comes_From_Source is always False.
--- Corresponding_Function (Node32)
+-- Corresponding_Function
-- Defined on procedures internally built with an extra out parameter
-- to return a constrained array type, when Modify_Tree_For_C is set.
-- Denotes the function that returns the constrained array type for
-- which this procedure was built.
--- Corresponding_Procedure (Node32)
+-- Corresponding_Procedure
-- Defined on functions that return a constrained array type, when
-- Modify_Tree_For_C is set. Denotes the internally built procedure
-- with an extra out parameter created for it.
--- Corresponding_Protected_Entry (Node18)
--- Defined in subprogram bodies. Set for subprogram bodies that implement
--- a protected type entry to point to the entity for the entry.
-
--- Corresponding_Record_Component (Node21)
+-- Corresponding_Record_Component
-- Defined in components of a derived untagged record type, including
-- discriminants. For a regular component or a girder discriminant,
-- points to the corresponding component in the parent type. Set to
@@ -792,30 +752,30 @@ package Einfo is
-- ensure the layout of the derived type matches that of the parent
-- type when there is no representation clause on the derived type.
--- Corresponding_Record_Type (Node18)
+-- Corresponding_Record_Type
-- Defined in protected and task types and subtypes. References the
-- entity for the corresponding record type constructed by the expander
-- (see Exp_Ch9). This type is used to represent values of the task type.
--- Corresponding_Remote_Type (Node22)
+-- Corresponding_Remote_Type
-- Defined in record types that describe the fat pointer structure for
-- Remote_Access_To_Subprogram types. References the original access
-- to subprogram type.
--- CR_Discriminant (Node23)
+-- CR_Discriminant
-- Defined in discriminants of concurrent types. Denotes the homologous
-- discriminant of the corresponding record type. The CR_Discriminant is
-- created at the same time as the discriminal, and used to replace
-- occurrences of the discriminant within the type declaration.
--- Current_Use_Clause (Node27)
+-- Current_Use_Clause
-- Defined in packages and in types. For packages, denotes the use
-- package clause currently in scope that makes the package use_visible.
-- For types, it denotes the use_type clause that makes the operators of
-- the type visible. Used for more precise warning messages on redundant
-- use clauses.
--- Current_Value (Node9)
+-- Current_Value
-- 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
@@ -836,7 +796,7 @@ package Einfo is
-- consulted to give information about the value of OBJ. For more details
-- on this usage, see the procedure Exp_Util.Get_Current_Value_Condition.
--- Debug_Info_Off (Flag166)
+-- Debug_Info_Off
-- Defined in all entities. Set if a pragma Suppress_Debug_Info applies
-- to the entity, or if internal processing in the compiler determines
-- that suppression of debug information is desirable. Note that this
@@ -844,7 +804,7 @@ package Einfo is
-- determining if Needs_Debug_Info should be set. The backend should
-- always test Needs_Debug_Info, it should never test Debug_Info_Off.
--- Debug_Renaming_Link (Node25)
+-- Debug_Renaming_Link
-- Used to link the variable associated with a debug renaming declaration
-- to the renamed entity. See Exp_Dbug.Debug_Renaming_Declaration for
-- details of the use of this field.
@@ -860,36 +820,36 @@ package Einfo is
-- subprograms, this returns the {function,procedure}_specification, not
-- the subprogram_declaration.
--- Default_Aspect_Component_Value (Node19) [base type only]
+-- Default_Aspect_Component_Value [base type only]
-- Defined in array types. Holds the static value specified in a
-- Default_Component_Value aspect specification for the array type,
-- or inherited on derivation.
--- Default_Aspect_Value (Node19) [base type only]
+-- Default_Aspect_Value [base type only]
-- Defined in scalar types. Holds the static value specified in a
-- Default_Value aspect specification for the type, or inherited
-- on derivation.
--- Default_Expr_Function (Node21)
+-- Default_Expr_Function
-- Defined in parameters. It holds the entity of the parameterless
-- function that is built to evaluate the default expression if it is
-- more complex than a simple identifier or literal. For the latter
-- simple cases or if there is no default value, this field is Empty.
--- Default_Expressions_Processed (Flag108)
+-- Default_Expressions_Processed
-- A flag in subprograms (functions, operators, procedures) and in
-- entries and entry families used to indicate that default expressions
-- have been processed and to avoid multiple calls to process the
-- default expressions (see Freeze.Process_Default_Expressions), which
-- would not only waste time, but also generate false error messages.
--- Default_Value (Node20)
+-- Default_Value
-- Defined in formal parameters. Points to the node representing the
-- expression for the default value for the parameter. Empty if the
-- parameter has no default value (which is always the case for OUT
-- and IN OUT parameters in the absence of errors).
--- Delay_Cleanups (Flag114)
+-- Delay_Cleanups
-- Defined in entities that have finalization lists (subprograms
-- blocks, and tasks). Set if there are pending generic body
-- instantiations for the corresponding entity. If this flag is
@@ -897,7 +857,7 @@ package Einfo is
-- entity must be delayed, since the insertion of the generic body
-- may affect cleanup generation (see Inline for further details).
--- Delay_Subprogram_Descriptors (Flag50)
+-- Delay_Subprogram_Descriptors
-- Defined in entities for which exception subprogram descriptors
-- are generated (subprograms, package declarations and package
-- bodies). Defined if there are pending generic body instantiations
@@ -914,22 +874,22 @@ package Einfo is
-- delayed instantiations (in this case the descriptor refers to the
-- enclosing elaboration procedure).
--- Delta_Value (Ureal18)
+-- Delta_Value
-- Defined in fixed and decimal types. Points to a universal real
-- that holds value of delta for the type, as given in the declaration
-- or as inherited by a subtype or derived type.
--- Dependent_Instances (Elist8)
+-- Dependent_Instances
-- Defined in packages that are instances. Holds list of instances
-- of inner generics. Used to place freeze nodes for those instances
-- after that of the current one, i.e. after the corresponding generic
-- bodies.
--- Depends_On_Private (Flag14)
+-- Depends_On_Private
-- Defined in all type entities. Set if the type is private or if it
-- depends on a private type.
--- Derived_Type_Link (Node31)
+-- Derived_Type_Link
-- Defined in all type and subtype entities. Set in a base type if
-- a derived type declaration is encountered which derives from
-- this base type or one of its subtypes, and there are already
@@ -967,23 +927,24 @@ package Einfo is
-- Note: the reason this is marked as a synthesized attribute is that the
-- way this is stored is as an element of the Subprograms_For_Type field.
--- Digits_Value (Uint17)
+-- Digits_Value
-- Defined in floating point types and subtypes and decimal types and
-- subtypes. Contains the Digits value specified in the declaration.
--- Direct_Primitive_Operations (Elist10)
+-- Direct_Primitive_Operations
-- Defined in tagged types and subtypes (including synchronized types),
--- in tagged private types and in tagged incomplete types. Element list
--- of entities for primitive operations of the tagged type. Not defined
--- in untagged types. In order to follow the C++ ABI, entities of
--- primitives that come from source must be stored in this list in the
--- order of their occurrence in the sources. For incomplete types the
--- list is always empty.
--- When expansion is disabled the corresponding record type of a
--- synchronized type is not constructed. In that case, such types
+-- in tagged private types, and in tagged incomplete types. However, when
+-- Extensions_Allowed is True (-gnatX), also defined for untagged types
+-- (for support of the extension feature of prefixed calls for untagged
+-- types). This field is an element list of entities for primitive
+-- operations of the type. For incomplete types the list is always empty.
+-- In order to follow the C++ ABI, entities of primitives that come from
+-- source must be stored in this list in the order of their occurrence in
+-- the sources. When expansion is disabled, the corresponding record type
+-- of a synchronized type is not constructed. In that case, such types
-- carry this attribute directly.
--- Directly_Designated_Type (Node20)
+-- Directly_Designated_Type
-- Defined in access types. This field points to the type that is
-- directly designated by the access type. In the case of an access
-- type to an incomplete type, this field references the incomplete
@@ -993,12 +954,12 @@ package Einfo is
-- Designated_Type obtains this full type in the case of access to an
-- incomplete type.
--- Disable_Controlled (Flag253)
+-- Disable_Controlled [base type only]
-- Present in all entities. Set for a controlled type subject to aspect
-- Disable_Controlled which evaluates to True. This flag is taken into
-- account in synthesized attribute Is_Controlled.
--- Discard_Names (Flag88)
+-- Discard_Names
-- Defined in types and exception entities. Set if pragma Discard_Names
-- applies to the entity. It is also set for declarative regions and
-- package specs for which a Discard_Names pragma with zero arguments
@@ -1007,24 +968,24 @@ package Einfo is
-- after the pragma within the same declarative region. This flag is
-- set to False if a Keep_Names pragma appears for an enumeration type.
--- Discriminal (Node17)
+-- Discriminal
-- Defined in discriminants (Discriminant formal: GNAT's first
-- coinage). The entity used as a formal parameter that corresponds
-- to a discriminant. See section "Handling of Discriminants" for
-- full details of the use of discriminals.
--- Discriminal_Link (Node10)
+-- Discriminal_Link
-- Defined in E_In_Parameter or E_Constant entities. For discriminals,
-- points back to corresponding discriminant. For other entities, must
-- remain Empty.
--- Discriminant_Checking_Func (Node20)
+-- Discriminant_Checking_Func
-- Defined in components. Points to the defining identifier of the
-- function built by the expander returns a Boolean indicating whether
-- the given record component exists for the current discriminant
-- values.
--- Discriminant_Constraint (Elist21)
+-- Discriminant_Constraint
-- Defined in entities whose Has_Discriminants flag is set (concurrent
-- types, subtypes, record types and subtypes, private types and
-- subtypes, limited private types and subtypes and incomplete types).
@@ -1051,24 +1012,24 @@ package Einfo is
-- In all other cases Discriminant_Constraint contains the empty
-- Elist (i.e. it is initialized with a call to New_Elmt_List).
--- Discriminant_Default_Value (Node20)
+-- Discriminant_Default_Value
-- Defined in discriminants. Points to the node representing the
-- expression for the default value of the discriminant. Set to
-- Empty if the discriminant has no default value.
--- Discriminant_Number (Uint15)
+-- Discriminant_Number
-- Defined in discriminants. Gives the ranking of a discriminant in
-- the list of discriminants of the type, i.e. a sequential integer
-- index starting at 1 and ranging up to number of discriminants.
--- Dispatch_Table_Wrappers (Elist26) [implementation base type only]
+-- Dispatch_Table_Wrappers [implementation base type only]
-- Defined in E_Record_Type and E_Record_Subtype entities. Set in library
-- level tagged type entities if we are generating statically allocated
-- dispatch tables. Points to the list of dispatch table wrappers
-- associated with the tagged type. For an untagged record, contains
-- No_Elist.
--- DTC_Entity (Node16)
+-- DTC_Entity
-- Defined in function and procedure entities. Set to Empty unless
-- the subprogram is dispatching in which case it references the
-- Dispatch Table pointer Component. For regular Ada tagged this, this
@@ -1077,16 +1038,16 @@ package Einfo is
-- Vtable pointer for the Vtable containing the entry referencing the
-- subprogram.
--- DT_Entry_Count (Uint15)
+-- DT_Entry_Count
-- Defined in E_Component entities. Only used for component marked
-- Is_Tag. Store the number of entries in the Vtable (or Dispatch Table)
--- DT_Offset_To_Top_Func (Node25)
+-- DT_Offset_To_Top_Func
-- Defined in E_Component entities. Only used for component marked
-- Is_Tag. If present it stores the Offset_To_Top function used to
-- provide this value in tagged types whose ancestor has discriminants.
--- DT_Position (Uint15)
+-- DT_Position
-- Defined in function and procedure entities which are dispatching
-- (should not be referenced without first checking that flag
-- Is_Dispatching_Operation is True). Contains the offset into
@@ -1096,7 +1057,7 @@ package Einfo is
-- Defined in all entities. Contains a value of the enumeration type
-- Entity_Kind declared in a subsequent section in this spec.
--- Elaborate_Body_Desirable (Flag210)
+-- Elaborate_Body_Desirable
-- Defined in package entities. Set if the elaboration circuitry detects
-- a case where there is a package body that modifies one or more visible
-- entities in the package spec and there is no explicit Elaborate_Body
@@ -1104,7 +1065,7 @@ package Einfo is
-- which attempts, but does not promise, to elaborate the body as close
-- to the spec as possible.
--- Elaboration_Entity (Node13)
+-- Elaboration_Entity
-- Defined in entry, entry family, [generic] package, and subprogram
-- entities. This is a counter associated with the unit that is initially
-- set to zero, is incremented when an elaboration request for the unit
@@ -1124,7 +1085,7 @@ package Einfo is
-- allocated (since we don't know early enough whether or not there
-- is elaboration code), but is simply not used for any purpose.
--- Elaboration_Entity_Required (Flag174)
+-- Elaboration_Entity_Required
-- Defined in entry, entry family, [generic] package, and subprogram
-- entities. Set only if Elaboration_Entity is non-Empty to indicate that
-- the counter is required to be non-zero even if there is no other
@@ -1134,30 +1095,30 @@ package Einfo is
-- then if there is no other elaboration code, obviously there is no
-- need to set the flag.
--- Encapsulating_State (Node32)
+-- Encapsulating_State
-- Defined in abstract state, constant and variable entities. Contains
-- the entity of an ancestor state or a single concurrent type whose
-- refinement utilizes this item as a constituent.
--- Enclosing_Scope (Node18)
+-- Enclosing_Scope
-- Defined in labels. Denotes the innermost enclosing construct that
-- contains the label. Identical to the scope of the label, except for
-- labels declared in the body of an accept statement, in which case the
-- entry_name is the Enclosing_Scope. Used to validate goto's within
-- accept statements.
--- Entry_Accepted (Flag152)
+-- Entry_Accepted
-- Defined in E_Entry and E_Entry_Family entities. Set if there is
-- at least one accept for this entry in the task body. Used to
-- generate warnings for missing accepts.
--- Entry_Bodies_Array (Node19)
+-- Entry_Bodies_Array
-- Defined in protected types for which Has_Entries is true.
-- This is the defining identifier for the array of entry body
-- action procedures and barrier functions used by the runtime to
-- execute the user code associated with each entry.
--- Entry_Cancel_Parameter (Node23)
+-- Entry_Cancel_Parameter
-- Defined in blocks. This only applies to a block statement for
-- which the Is_Asynchronous_Call_Block flag is set. It
-- contains the defining identifier of an object that must be
@@ -1168,17 +1129,17 @@ package Einfo is
-- in the case of protected entry calls. In both cases the objects
-- are declared in outer scopes to this block.
--- Entry_Component (Node11)
+-- Entry_Component
-- Defined in formal parameters (in, in out and out parameters). Used
-- only for formals of entries. References the corresponding component
-- of the entry parameter record for the entry.
--- Entry_Formal (Node16)
+-- Entry_Formal
-- Defined in components of the record built to correspond to entry
-- parameters. This field points from the component to the formal. It
-- is the back pointer corresponding to Entry_Component.
--- Entry_Index_Constant (Node18)
+-- Entry_Index_Constant
-- Defined in an entry index parameter. This is an identifier that
-- eventually becomes the name of a constant representing the index
-- of the entry family member whose entry body is being executed. Used
@@ -1190,12 +1151,12 @@ package Einfo is
-- accept statement for a member of the family, and in the prefix of
-- 'COUNT when it applies to a family member.
--- Entry_Max_Queue_Lengths_Array (Node35)
+-- Entry_Max_Queue_Lengths_Array
-- Defined in protected types for which Has_Entries is true. Contains the
-- defining identifier for the array of naturals used by the runtime to
-- limit the queue size of each entry individually.
--- Entry_Parameters_Type (Node15)
+-- Entry_Parameters_Type
-- Defined in entries. Points to the access-to-record type that is
-- constructed by the expander to hold a reference to the parameter
-- values. This reference is manipulated (as an address) by the
@@ -1204,11 +1165,11 @@ package Einfo is
-- for further details). Entry_Parameters_Type is Empty if the entry
-- has no parameters.
--- Enumeration_Pos (Uint11)
+-- Enumeration_Pos
-- Defined in enumeration literals. Contains the position number
-- corresponding to the value of the enumeration literal.
--- Enumeration_Rep (Uint12)
+-- Enumeration_Rep
-- Defined in enumeration literals. Contains the representation that
-- corresponds to the value of the enumeration literal. Note that
-- this is normally the same as Enumeration_Pos except in the presence
@@ -1216,7 +1177,7 @@ package Einfo is
-- position of the literal within the type and Rep will have be the
-- value given in the representation clause.
--- Enumeration_Rep_Expr (Node22)
+-- Enumeration_Rep_Expr
-- Defined in enumeration literals. Points to the expression in an
-- associated enumeration rep clause that provides the representation
-- value for this literal. Empty if no enumeration rep clause for this
@@ -1224,7 +1185,7 @@ package Einfo is
-- an error situation). This is also used to catch duplicate entries
-- for the same literal.
--- Enum_Pos_To_Rep (Node23)
+-- Enum_Pos_To_Rep
-- 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
@@ -1236,7 +1197,7 @@ package Einfo is
-- the representation is contiguous, then Enum_Pos_To_Rep is the entity
-- of the index type defined above.
--- Equivalent_Type (Node18)
+-- Equivalent_Type
-- Defined in class wide types and subtypes, access to protected
-- subprogram types, and in exception types. For a classwide type, it
-- is always Empty. For a class wide subtype, it points to an entity
@@ -1250,7 +1211,7 @@ package Einfo is
-- protected object. For remote Access_To_Subprogram types, it denotes
-- the record that is the fat pointer representation of an RAST.
--- Esize (Uint12)
+-- Esize
-- Defined in all types and subtypes, and also for components, constants,
-- and variables, including exceptions where it refers to the static data
-- allocated for an exception. Contains the Object_Size of the type or of
@@ -1266,7 +1227,7 @@ package Einfo is
-- During backend processing, the value is back annotated for all zero
-- values, so that after the call to the backend, the value is set.
--- Etype (Node5)
+-- Etype
-- Defined in all entities. Represents the type of the entity, which
-- is itself another entity. For a type entity, points to the parent
-- type for a derived type, or if the type is not derived, points to
@@ -1279,7 +1240,7 @@ package Einfo is
-- Note one obscure case: for pragma Default_Storage_Pool (null), the
-- Etype of the N_Null node is Empty.
--- Extra_Accessibility (Node13)
+-- Extra_Accessibility
-- Defined in formal parameters in the non-generic case. Normally Empty,
-- but if expansion is active, and a parameter is one for which a
-- dynamic accessibility check is required, then an extra formal of type
@@ -1291,7 +1252,7 @@ package Einfo is
-- must be retrieved through the entity designed by this field instead of
-- being computed.
--- Extra_Accessibility_Of_Result (Node19)
+-- Extra_Accessibility_Of_Result
-- Defined in (non-generic) Function, Operator, and Subprogram_Type
-- entities. Normally Empty, but if expansion is active, and a function
-- is one for which "the accessibility level of the result ... determined
@@ -1300,7 +1261,7 @@ package Einfo is
-- and the Extra_Accessibility_Of_Result field of the function points to
-- the entity for this extra formal.
--- Extra_Constrained (Node23)
+-- Extra_Constrained
-- Defined in formal parameters in the non-generic case. Normally Empty,
-- but if expansion is active and a parameter is one for which a dynamic
-- indication of its constrained status is required, then an extra formal
@@ -1312,7 +1273,7 @@ package Einfo is
-- must be retrieved through the entity designed by this field instead of
-- being computed.
--- Extra_Formal (Node15)
+-- Extra_Formal
-- Defined in formal parameters in the non-generic case. Certain
-- parameters require extra implicit information to be passed (e.g. the
-- flag indicating if an unconstrained variant record argument is
@@ -1327,19 +1288,19 @@ package Einfo is
-- in connection with unnesting of subprograms, where the ARECnF formal
-- that represents an activation record pointer is an extra formal.
--- Extra_Formals (Node28)
+-- Extra_Formals
-- Applies to subprograms, subprogram types, entries, and entry
-- families. Returns first extra formal of the subprogram or entry.
-- Returns Empty if there are no extra formals.
--- Finalization_Master (Node23) [root type only]
+-- Finalization_Master [root type only]
-- Defined in access-to-controlled or access-to-class-wide types. The
-- field contains the entity of the finalization master which handles
-- dynamically allocated controlled objects referenced by the access
-- type. Empty for access-to-subprogram types. Empty for access types
-- whose designated type does not need finalization actions.
--- Finalize_Storage_Only (Flag158) [base type only]
+-- Finalize_Storage_Only [base type only]
-- Defined in all types. Set on direct controlled types to which a
-- valid Finalize_Storage_Only pragma applies. This flag is also set on
-- composite types when they have at least one controlled component and
@@ -1348,7 +1309,7 @@ package Einfo is
-- the Finalize_Storage_Only pragma is required at each level of
-- derivation.
--- Finalizer (Node28)
+-- Finalizer
-- Applies to package declarations and bodies. Contains the entity of the
-- library-level program which finalizes all package-level controlled
-- objects.
@@ -1364,7 +1325,7 @@ package Einfo is
-- Similar to First_Component, but discriminants are not skipped, so will
-- find the first discriminant if discriminants are present.
--- First_Entity (Node17)
+-- First_Entity
-- Defined in all entities which act as scopes to which a list of
-- associated entities is attached (blocks, class subtypes and types,
-- entries, functions, loops, packages, procedures, protected objects,
@@ -1372,7 +1333,7 @@ package Einfo is
-- Points to a list of associated entities using the Next_Entity field
-- as a chain pointer with Empty marking the end of the list.
--- First_Exit_Statement (Node8)
+-- First_Exit_Statement
-- Defined in E_Loop entity. The exit statements for a loop are chained
-- (in reverse order of appearance) using this field to point to the
-- first entry in the chain (last exit statement in the loop). The
@@ -1392,7 +1353,7 @@ package Einfo is
-- Returns Empty if there are no formals. The list returned includes
-- all the extra formals (see description of Extra_Formals field).
--- First_Index (Node17)
+-- First_Index
-- Defined in array types and subtypes. By introducing implicit subtypes
-- for the index constraints, we have the same structure for constrained
-- and unconstrained arrays, subtype marks and discrete ranges are
@@ -1402,7 +1363,7 @@ package Einfo is
-- this field is defined for the case of string literal subtypes, but is
-- always Empty.
--- First_Literal (Node17)
+-- First_Literal
-- Defined in all enumeration types, including character and boolean
-- types. This field points to the first enumeration literal entity
-- for the type (i.e. it is set to First (Literals (N)) where N is
@@ -1412,7 +1373,7 @@ package Einfo is
-- Note that this field is set in enumeration subtypes, but it still
-- points to the first literal of the base type in this case.
--- First_Private_Entity (Node16)
+-- First_Private_Entity
-- Defined in all entities containing private parts (packages, protected
-- types and subtypes, task types and subtypes). The entities on the
-- entity chain are in order of declaration, so the entries for private
@@ -1420,7 +1381,7 @@ package Einfo is
-- entity for the private part. It is Empty if there are no entities
-- declared in the private part or if there is no private part.
--- First_Rep_Item (Node6)
+-- First_Rep_Item
-- Defined in all entities. If non-empty, points to a linked list of
-- representation pragmas nodes and representation clause nodes that
-- apply to the entity, linked using Next_Rep_Item, with Empty marking
@@ -1457,25 +1418,25 @@ package Einfo is
-- Note in particular that size clauses are defined only for this
-- purpose, and should only be accessed if Has_Size_Clause is set.
--- Float_Rep (Uint10)
+-- Float_Rep [base type only]
-- Defined in floating-point entities. Contains a value of type
-- Float_Rep_Kind. Together with the Digits_Value uniquely defines
-- the floating-point representation to be used.
--- Freeze_Node (Node7)
+-- Freeze_Node
-- Defined in all entities. If there is an associated freeze node for the
-- entity, this field references this freeze node. If no freeze node is
-- associated with the entity, then this field is Empty. See package
-- Freeze for further details.
--- From_Limited_With (Flag159)
+-- From_Limited_With
-- Defined in abtract states, package and type entities. Set to True when
-- the related entity is generated by the expansion of a limited with
-- clause. Such an entity is said to be a "shadow" - it acts as the
-- abstract view of a state or variable or as the incomplete view of a
-- type by inheriting relevant attributes from the said entity.
--- Full_View (Node11)
+-- Full_View
-- Defined in all type and subtype entities and in deferred constants.
-- References the entity for the corresponding full type or constant
-- declaration. For all types other than private and incomplete types,
@@ -1484,29 +1445,29 @@ package Einfo is
-- E3 then the full view of E1 is E2, and the full view of E2 is E3. See
-- also Underlying_Type.
--- Generic_Homonym (Node11)
+-- Generic_Homonym
-- Defined in generic packages. The generic homonym is the entity of
-- a renaming declaration inserted in every generic unit. It is used
-- to resolve the name of a local entity that is given by a qualified
-- name, when the generic entity itself is hidden by a local name.
--- Generic_Renamings (Elist23)
+-- Generic_Renamings
-- Defined in package and subprogram instances. Holds mapping that
-- associates generic parameters with the corresponding instances, in
-- those cases where the instance is an entity.
--- Handler_Records (List10)
+-- Handler_Records
-- Defined in subprogram and package entities. Points to a list of
-- identifiers referencing the handler record entities for the
-- corresponding unit.
--- Has_Aliased_Components (Flag135) [implementation base type only]
+-- Has_Aliased_Components [implementation base type only]
-- Defined in array type entities. Indicates that the component type
-- of the array is aliased. Should this also be set for records to
-- indicate that at least one component is aliased (see processing in
-- Sem_Prag.Process_Atomic_Independent_Shared_Volatile???)
--- Has_Alignment_Clause (Flag46)
+-- Has_Alignment_Clause
-- Defined in all type entities and objects. Indicates if an alignment
-- clause has been given for the entity. If set, then Alignment_Clause
-- returns the N_Attribute_Definition node for the alignment attribute
@@ -1514,13 +1475,13 @@ package Einfo is
-- even when Alignment_Clause returns non_Empty (this happens in the case
-- of derived type declarations).
--- Has_All_Calls_Remote (Flag79)
+-- Has_All_Calls_Remote
-- Defined in all library unit entities. Set if the library unit has an
-- All_Calls_Remote pragma. Note that such entities must also be RCI
-- entities, so the flag Is_Remote_Call_Interface will always be set if
-- this flag is set.
--- Has_Atomic_Components (Flag86) [implementation base type only]
+-- Has_Atomic_Components [implementation base type only]
-- Defined in all types and objects. Set only for an array type or
-- an array object if a valid pragma Atomic_Components applies to the
-- type or object. Note that in the case of an object, this flag is
@@ -1536,7 +1497,7 @@ package Einfo is
-- represent protected types. Returns True if there is at least one
-- Attach_Handler pragma in the corresponding specification.
--- Has_Biased_Representation (Flag139)
+-- Has_Biased_Representation
-- Defined in discrete types (where it applies to the type'size value),
-- and to objects (both stand-alone and components), where it applies to
-- the size of the object from a size or record component clause. In
@@ -1552,27 +1513,27 @@ package Einfo is
-- size of the type, forcing biased representation for the object, but
-- the subtype is still an unbiased type.
--- Has_Completion (Flag26)
+-- Has_Completion
-- Defined in all entities that require a completion (functions,
-- procedures, private types, limited private types, incomplete types,
-- constants and packages that require a body). The flag is set if the
-- completion has been encountered and analyzed.
--- Has_Completion_In_Body (Flag71)
+-- Has_Completion_In_Body
-- Defined in all entities for types and subtypes. Set only in "Taft
-- amendment types" (incomplete types whose full declaration appears in
-- the package body).
--- Has_Complex_Representation (Flag140) [implementation base type only]
+-- Has_Complex_Representation [implementation base type only]
-- Defined in record types. Set only for a base type to which a valid
-- pragma Complex_Representation applies.
--- Has_Component_Size_Clause (Flag68) [implementation base type only]
+-- Has_Component_Size_Clause [implementation base type only]
-- Defined in all type entities. Set if a component size clause is
-- Defined for the given type. Note that this flag can be False even
-- if Component_Size is non-zero (happens in the case of derived types).
--- Has_Constrained_Partial_View (Flag187) [base type only]
+-- Has_Constrained_Partial_View [base type only]
-- Defined in private type and their completions, when the private
-- type has no discriminants and the full view has discriminants with
-- defaults. In Ada 2005 heap-allocated objects of such types are not
@@ -1584,26 +1545,26 @@ package Einfo is
-- partial view. The predicate Object_Type_Has_Constrained_Partial_View
-- in sem_aux is used to test for this case.
--- Has_Contiguous_Rep (Flag181)
+-- Has_Contiguous_Rep
-- Defined in enumeration types. Set if the type has a representation
-- clause whose entries are successive integers.
--- Has_Controlled_Component (Flag43) [base type only]
+-- Has_Controlled_Component [base type only]
-- Defined in all type and subtype entities. Set only for composite type
-- entities which contain a component that either is a controlled type,
-- or itself contains controlled component (i.e. either Is_Controlled or
-- Has_Controlled_Component is set for at least one component).
--- Has_Controlling_Result (Flag98)
+-- Has_Controlling_Result
-- Defined in E_Function entities. Set if the function is a primitive
-- function of a tagged type which can dispatch on result.
--- Has_Convention_Pragma (Flag119)
+-- Has_Convention_Pragma
-- Defined in all entities. Set for an entity for which a valid pragma
-- Convention, Import, or Export has been given. Used to prevent more
-- than one such pragma appearing for a given entity (RM B.1(45)).
--- Has_Default_Aspect (Flag39) [base type only]
+-- Has_Default_Aspect [base type only]
-- Defined in entities for types and subtypes, set for scalar types with
-- a Default_Value aspect and array types with a Default_Component_Value
-- aspect. If this flag is set, then a corresponding aspect specification
@@ -1612,19 +1573,19 @@ package Einfo is
-- value is set, but it may be overridden by an aspect declaration on
-- type derivation.
--- Has_Delayed_Aspects (Flag200)
+-- Has_Delayed_Aspects
-- Defined in all entities. Set if the Rep_Item chain for the entity has
-- one or more N_Aspect_Definition nodes chained which are not to be
-- evaluated till the freeze point. The aspect definition expression
-- clause has been preanalyzed to get visibility at the point of use,
-- but no other action has been taken.
--- Has_Delayed_Freeze (Flag18)
+-- Has_Delayed_Freeze
-- Defined in all entities. Set to indicate that an explicit freeze
-- node must be generated for the entity at its freezing point. See
-- separate section ("Delayed Freezing and Elaboration") for details.
--- Has_Delayed_Rep_Aspects (Flag261)
+-- Has_Delayed_Rep_Aspects
-- Defined in all types and subtypes. This flag is set if there is at
-- least one aspect for a representation characteristic that has to be
-- delayed and is one of the characteristics that may be inherited by
@@ -1638,14 +1599,14 @@ package Einfo is
-- when the type is subject to pragma Default_Initial_Condition (DIC), or
-- when the type inherits a DIC pragma from a parent type.
--- Has_Discriminants (Flag5)
+-- Has_Discriminants
-- Defined in all types and subtypes. For types that are allowed to have
-- discriminants (record types and subtypes, task types and subtypes,
-- protected types and subtypes, private types, limited private types,
-- and incomplete types), indicates if the corresponding type or subtype
-- has a known discriminant part. Always false for all other types.
--- Has_Dispatch_Table (Flag220)
+-- Has_Dispatch_Table
-- Defined in E_Record_Types that are tagged. Set to indicate that the
-- corresponding dispatch table is already built. This flag is used to
-- avoid duplicate construction of library level dispatch tables (because
@@ -1653,7 +1614,7 @@ package Einfo is
-- of the table); otherwise the code that builds the table is added at
-- the end of the list of declarations of the package.
--- Has_Dynamic_Predicate_Aspect (Flag258)
+-- Has_Dynamic_Predicate_Aspect
-- Defined in all types and subtypes. Set if a Dynamic_Predicate aspect
-- was explicitly applied to the type. Generally we treat predicates as
-- static if possible, regardless of whether they are specified using
@@ -1672,17 +1633,17 @@ package Einfo is
-- Applies to concurrent types. True if any entries are declared
-- within the task or protected definition for the type.
--- Has_Enumeration_Rep_Clause (Flag66)
+-- Has_Enumeration_Rep_Clause
-- Defined in enumeration types. Set if an enumeration representation
-- clause has been given for this enumeration type. Used to prevent more
-- than one enumeration representation clause for a given type. Note
-- that this does not imply a representation with holes, since the rep
-- clause may merely confirm the default 0..N representation.
--- Has_Exit (Flag47)
+-- Has_Exit
-- Defined in loop entities. Set if the loop contains an exit statement.
--- Has_Expanded_Contract (Flag240)
+-- Has_Expanded_Contract
-- Defined in functions, procedures, entries, and entry families. Set
-- when a subprogram has a N_Contract node that has been expanded. The
-- flag prevents double expansion of a contract when a construct is
@@ -1694,7 +1655,7 @@ package Einfo is
-- Convention_Intrinsic, Convention_Entry, Convention_Protected,
-- Convention_Stubbed and Convention_Ada_Pass_By_(Copy,Reference).
--- Has_Forward_Instantiation (Flag175)
+-- Has_Forward_Instantiation
-- Defined in package entities. Set for packages that instantiate local
-- generic entities before the corresponding generic body has been seen.
-- If a package has a forward instantiation, we cannot inline subprograms
@@ -1702,13 +1663,13 @@ package Einfo is
-- the instance will conflict with the linear elaboration of front-end
-- inlining.
--- Has_Fully_Qualified_Name (Flag173)
+-- Has_Fully_Qualified_Name
-- Defined in all entities. Set if the name in the Chars field has been
-- replaced by the fully qualified name, as used for debug output. See
-- Exp_Dbug for a full description of the use of this flag and also the
-- related flag Has_Qualified_Name.
--- Has_Gigi_Rep_Item (Flag82)
+-- Has_Gigi_Rep_Item
-- Defined in all entities. Set if the rep item chain (referenced by
-- First_Rep_Item and linked through the Next_Rep_Item chain) contains a
-- representation item that needs to be specially processed by the back
@@ -1725,16 +1686,16 @@ package Einfo is
-- to process any of these items that appear. At least one such item will
-- be present.
--
--- Has_Homonym (Flag56)
+-- Has_Homonym
-- Defined in all entities. Set if an entity has a homonym in the same
-- scope. Used by the backend to generate unique names for all entities.
--- Has_Implicit_Dereference (Flag251)
+-- Has_Implicit_Dereference
-- Defined in types and discriminants. Set if the type has an aspect
-- Implicit_Dereference. Set also on the discriminant named in the aspect
-- clause, to simplify type resolution.
--- Has_Independent_Components (Flag34) [implementation base type only]
+-- Has_Independent_Components [implementation base type only]
-- Defined in all types and objects. Set only for a record type or an
-- array type or array object if a valid pragma Independent_Components
-- applies to the type or object. Note that in the case of an object,
@@ -1746,23 +1707,23 @@ package Einfo is
-- usual manner. Also set if a pragma Has_Atomic_Components or pragma
-- Has_Aliased_Components applies to the type or object.
--- Has_Inheritable_Invariants (Flag248) [base type only]
+-- Has_Inheritable_Invariants [base type only]
-- Defined in all type entities. Set on private types and interface types
-- which define at least one class-wide invariant. Such invariants must
-- be inherited by derived types. The flag is also set on the full view
-- of a private type for completeness.
--- Has_Inherited_DIC (Flag133) [base type only]
+-- Has_Inherited_DIC [base type only]
-- Defined in all type entities. Set for a derived type which inherits
-- pragma Default_Initial_Condition from a parent type.
--- Has_Inherited_Invariants (Flag291) [base type only]
+-- Has_Inherited_Invariants [base type only]
-- Defined in all type entities. Set on private extensions and derived
-- types which inherit at least one class-wide invariant from a parent or
-- an interface type. The flag is also set on the full view of a private
-- extension for completeness.
--- Has_Initial_Value (Flag219)
+-- Has_Initial_Value
-- Defined in entities for variables and out parameters. Set if there
-- is an explicit initial value expression in the declaration of the
-- variable. Note that this is set only if this initial value is
@@ -1785,35 +1746,35 @@ package Einfo is
-- Defined in all entities. True for non-generic package entities that
-- are non-instances and their Limited_View attribute is present.
--- Has_Loop_Entry_Attributes (Flag260)
+-- Has_Loop_Entry_Attributes
-- Defined in E_Loop entities. Set when the loop is subject to at least
-- one attribute 'Loop_Entry. The flag also implies that the loop has
-- already been transformed. See Expand_Loop_Entry_Attribute for details.
--- Has_Machine_Radix_Clause (Flag83)
+-- Has_Machine_Radix_Clause
-- Defined in decimal types and subtypes, set if a Machine_Radix
-- representation clause is present. This flag is used to detect
-- the error of multiple machine radix clauses for a single type.
--- Has_Master_Entity (Flag21)
+-- Has_Master_Entity
-- Defined in entities that can appear in the scope stack (see spec
-- of Sem). It is set if a task master entity (_master) has been
-- declared and initialized in the corresponding scope.
--- Has_Missing_Return (Flag142)
+-- Has_Missing_Return
-- Defined in functions and generic functions. Set if there is one or
-- more missing return statements in the function. This is used to
-- control wrapping of the body in Exp_Ch6 to ensure that the program
-- error exception is correctly raised in this case at run time.
--- Has_Nested_Block_With_Handler (Flag101)
+-- Has_Nested_Block_With_Handler
-- Defined in scope entities. Set if there is a nested block within the
-- scope that has an exception handler and the two scopes are in the
-- same procedure. This is used by the backend for controlling certain
-- optimizations to ensure that they are consistent with exceptions.
-- See documentation in backend for further details.
--- Has_Nested_Subprogram (Flag282)
+-- Has_Nested_Subprogram
-- Defined in subprogram entities. Set for a subprogram which contains at
-- least one nested subprogram.
@@ -1831,7 +1792,7 @@ package Einfo is
-- refinement of at least one variable or state constituent as expressed
-- in aspect/pragma Refined_State.
--- Has_Non_Standard_Rep (Flag75) [implementation base type only]
+-- Has_Non_Standard_Rep [implementation base type only]
-- Defined in all type entities. Set when some representation clause
-- or pragma causes the representation of the item to be significantly
-- modified. In this category are changes of small or radix for a
@@ -1849,22 +1810,22 @@ package Einfo is
-- Defined in E_Abstract_State entities. True if the state has a visible
-- null refinement as expressed in aspect/pragma Refined_State.
--- Has_Object_Size_Clause (Flag172)
+-- Has_Object_Size_Clause
-- Defined in entities for types and subtypes. Set if an Object_Size
-- clause has been processed for the type. Used to prevent multiple
-- Object_Size clauses for a given entity.
--- Has_Out_Or_In_Out_Parameter (Flag110)
+-- Has_Out_Or_In_Out_Parameter
-- Present in subprograms, generic subprograms, entries, and entry
-- families. Set if they have at least one OUT or IN OUT parameter
-- (allowed for functions only in Ada 2012).
--- Has_Own_DIC (Flag3) [base type only]
+-- Has_Own_DIC [base type only]
-- Defined in all type entities. Set for a private type and its full view
-- (and its underlying full view, if the full view is itself private)
-- when the type is subject to pragma Default_Initial_Condition.
--- Has_Own_Invariants (Flag232) [base type only]
+-- Has_Own_Invariants [base type only]
-- Defined in all type entities. Set on any type that defines at least
-- one invariant of its own.
@@ -1872,7 +1833,7 @@ package Einfo is
-- an Invariant pragma or aspect applies, and on the underlying full view
-- if the full view is private.
--- Has_Partial_Visible_Refinement (Flag296)
+-- Has_Partial_Visible_Refinement
-- Defined in E_Abstract_State entities. Set when a state has at least
-- one refinement constituent subject to indicator Part_Of, and analysis
-- is in the region between the declaration of the first constituent for
@@ -1880,7 +1841,7 @@ package Einfo is
-- of the package spec or body with visibility over this private part
-- (which includes the package itself and its child packages).
--- Has_Per_Object_Constraint (Flag154)
+-- Has_Per_Object_Constraint
-- Defined in E_Component entities. Set if the subtype of the component
-- has a per object constraint. Per object constraints result from the
-- following situations :
@@ -1896,15 +1857,15 @@ package Einfo is
-- 5. N_Range_Constraint - when the range expression uses the
-- discriminant of the enclosing type.
--- Has_Pragma_Controlled (Flag27) [implementation base type only]
+-- Has_Pragma_Controlled [implementation base type only]
-- Defined in access type entities. It is set if a pragma Controlled
-- applies to the access type.
--- Has_Pragma_Elaborate_Body (Flag150)
+-- Has_Pragma_Elaborate_Body
-- Defined in all entities. Set in compilation unit entities if a
-- pragma Elaborate_Body applies to the compilation unit.
--- Has_Pragma_Inline (Flag157)
+-- Has_Pragma_Inline
-- Defined in all entities. Set for functions and procedures for which a
-- pragma Inline or Inline_Always applies to the subprogram. Note that
-- this flag can be set even if Is_Inlined is not set. This happens for
@@ -1913,55 +1874,55 @@ package Einfo is
-- for checking semantic correctness. The flag Is_Inlined indicates
-- whether inlining is actually active for the entity.
--- Has_Pragma_Inline_Always (Flag230)
+-- Has_Pragma_Inline_Always
-- Defined in all entities. Set for functions and procedures for which a
-- pragma Inline_Always applies. Note that if this flag is set, the flag
-- Has_Pragma_Inline is also set.
--- Has_Pragma_No_Inline (Flag201)
+-- Has_Pragma_No_Inline
-- Defined in all entities. Set for functions and procedures for which a
-- pragma No_Inline applies. Note that if this flag is set, the flag
-- Has_Pragma_Inline_Always cannot be set.
--- Has_Pragma_Ordered (Flag198) [implementation base type only]
+-- Has_Pragma_Ordered [implementation base type only]
-- Defined in entities for enumeration types. If set indicates that a
-- valid pragma Ordered was given for the type. This flag is inherited
-- by derived enumeration types. We don't need to distinguish the derived
-- case since we allow multiple occurrences of this pragma anyway.
--- Has_Pragma_Pack (Flag121) [implementation base type only]
+-- Has_Pragma_Pack [implementation base type only]
-- Defined in array and record type entities. If set, indicates that a
-- valid pragma Pack was given for the type. Note that this flag is not
-- inherited by derived type. See also the Is_Packed flag.
--- Has_Pragma_Preelab_Init (Flag221)
+-- Has_Pragma_Preelab_Init
-- Defined in type and subtype entities. If set indicates that a valid
-- pragma Preelaborable_Initialization applies to the type.
--- Has_Pragma_Pure (Flag203)
+-- Has_Pragma_Pure
-- Defined in all entities. If set, indicates that a valid pragma Pure
-- was given for the entity. In some cases, we need to test whether
-- Is_Pure was explicitly set using this pragma.
--- Has_Pragma_Pure_Function (Flag179)
+-- Has_Pragma_Pure_Function
-- Defined in all entities. If set, indicates that a valid pragma
-- Pure_Function was given for the entity. In some cases, we need to test
-- whether Is_Pure was explicitly set using this pragma. We also set
-- this flag for some internal entities that we know should be treated
-- as pure for optimization purposes.
--- Has_Pragma_Thread_Local_Storage (Flag169)
+-- Has_Pragma_Thread_Local_Storage
-- Defined in all entities. If set, indicates that a valid pragma
-- Thread_Local_Storage was given for the entity.
--- Has_Pragma_Unmodified (Flag233)
+-- Has_Pragma_Unmodified
-- Defined in all entities. Can only be set for variables (E_Variable,
-- E_Out_Parameter, E_In_Out_Parameter). Set if a valid pragma Unmodified
-- applies to the variable, indicating that no warning should be given
-- if the entity is never modified. Note that clients should generally
-- not test this flag directly, but instead use function Has_Unmodified.
--- Has_Pragma_Unreferenced (Flag180)
+-- Has_Pragma_Unreferenced
-- Defined in all entities. Set if a valid pragma Unreferenced applies
-- to the entity, indicating that no warning should be given if the
-- entity has no references, but a warning should be given if it is
@@ -1970,21 +1931,19 @@ package Einfo is
-- that clients should generally not test this flag directly, but instead
-- use function Has_Unreferenced.
--- ??? this real description was clobbered
-
--- Has_Pragma_Unreferenced_Objects (Flag212)
+-- Has_Pragma_Unreferenced_Objects
-- Defined in all entities. Set if a valid pragma Unused applies to an
-- entity, indicating that warnings should be given if the entity is
-- modified or referenced. This pragma is equivalent to a pair of
-- Unmodified and Unreferenced pragmas.
--- Has_Pragma_Unused (Flag294)
+-- Has_Pragma_Unused
-- Defined in all entities. Set if a valid pragma Unused applies to a
-- variable or entity, indicating that warnings should not be given if
-- it is never modified or referenced. Note: This pragma is exactly
-- equivalent Unmodified and Unreference combined.
--- Has_Predicates (Flag250)
+-- Has_Predicates
-- Defined in type and subtype entities. Set if a pragma Predicate or
-- Predicate aspect applies to the type or subtype, or if it inherits a
-- Predicate aspect from its parent or progenitor types.
@@ -1993,11 +1952,11 @@ package Einfo is
-- 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]
+-- Has_Primitive_Operations [base type only]
-- Defined in all type entities. Set if at least one primitive operation
-- is defined for the type.
--- Has_Private_Ancestor (Flag151)
+-- Has_Private_Ancestor
-- Applies to type extensions. True if some ancestor is derived from a
-- private type, making some components invisible and aggregates illegal.
-- This flag is set at the point of derivation. The legality of the
@@ -2005,19 +1964,19 @@ package Einfo is
-- at the point the aggregate is resolved. See sem_aggr.adb. This is part
-- of AI05-0115.
--- Has_Private_Declaration (Flag155)
+-- Has_Private_Declaration
-- Defined in all entities. Set if it is the defining entity of a private
-- type declaration or its corresponding full declaration. This flag is
-- thus preserved when the full and the partial views are exchanged, to
-- indicate if a full type declaration is a completion. Used for semantic
-- checks in E.4(18) and elsewhere.
--- Has_Private_Extension (Flag300)
+-- Has_Private_Extension
-- Defined in tagged types. Set to indicate that the tagged type has some
-- private extension. Used to report a warning on public primitives added
-- after defining its private extensions.
--- Has_Protected (Flag271) [base type only]
+-- Has_Protected [base type only]
-- Defined in all type entities. Set on protected types themselves, and
-- also (recursively) on any composite type which has a component for
-- which Has_Protected is set, unless the protected type is declared in
@@ -2025,7 +1984,7 @@ package Einfo is
-- for protected types apply to this type. Note: the flag is not set on
-- access types, even if they designate an object that Has_Protected.
--- Has_Qualified_Name (Flag161)
+-- Has_Qualified_Name
-- Defined in all entities. Set if the name in the Chars field has
-- been replaced by its qualified name, as used for debug output. See
-- Exp_Dbug for a full description of qualification requirements. For
@@ -2035,41 +1994,41 @@ package Einfo is
-- flag Has_Fully_Qualified_Name, which is set if the name does indeed
-- include the fully qualified name.
--- Has_RACW (Flag214)
+-- Has_RACW
-- Defined in package spec entities. Set if the spec contains the
-- declaration of a remote access-to-classwide type.
--- Has_Record_Rep_Clause (Flag65) [implementation base type only]
+-- Has_Record_Rep_Clause [implementation base type only]
-- Defined in record types. Set if a record representation clause has
-- been given for this record type. Used to prevent more than one such
-- clause for a given record type. Note that this is initially cleared
-- for a derived type, even though the representation is inherited. See
-- also the flag Has_Specified_Layout.
--- Has_Recursive_Call (Flag143)
+-- Has_Recursive_Call
-- Defined in procedures. Set if a direct parameterless recursive call
-- is detected while analyzing the body. Used to activate some error
-- checks for infinite recursion.
--- Has_Shift_Operator (Flag267) [base type only]
+-- Has_Shift_Operator [base type only]
-- Defined in integer types. Set in the base type of an integer type for
-- which at least one of the shift operators is defined.
--- Has_Size_Clause (Flag29)
--- Defined in entities for types and objects. Set if a size clause is
--- defined for the entity. Used to prevent multiple Size clauses for a
--- given entity. Note that it is always initially cleared for a derived
--- type, even though the Size for such a type is inherited from a Size
--- clause given for the parent type.
+-- Has_Size_Clause
+-- Defined in entities for types and objects. Set if a size or value size
+-- clause is defined for the entity. Used to prevent multiple clauses
+-- for a given entity. Note that it is always initially cleared for a
+-- derived type, even though the Size or Value_Size clause for such a
+-- type might be inherited from an ancestor type.
--- Has_Small_Clause (Flag67)
+-- Has_Small_Clause
-- Defined in ordinary fixed point types (but not subtypes). Indicates
-- that a small clause has been given for the entity. Used to prevent
-- multiple Small clauses for a given entity. Note that it is always
-- initially cleared for a derived type, even though the Small for such
-- a type is inherited from a Small clause given for the parent type.
--- Has_Specified_Layout (Flag100) [implementation base type only]
+-- Has_Specified_Layout [implementation base type only]
-- Defined in all type entities. Set for a record type or subtype if
-- the record layout has been specified by a record representation
-- clause. Note that this differs from the flag Has_Record_Rep_Clause
@@ -2078,23 +2037,23 @@ package Einfo is
-- representation clause, and thus is not inherited by a derived type.
-- This flag is always False for non-record types.
--- Has_Specified_Stream_Input (Flag190)
--- Has_Specified_Stream_Output (Flag191)
--- Has_Specified_Stream_Read (Flag192)
--- Has_Specified_Stream_Write (Flag193)
+-- Has_Specified_Stream_Input
+-- Has_Specified_Stream_Output
+-- Has_Specified_Stream_Read
+-- Has_Specified_Stream_Write
-- Defined in all type and subtype entities. Set for a given view if the
-- corresponding stream-oriented attribute has been defined by an
-- attribute definition clause. When such a clause occurs, a TSS is set
-- on the underlying full view; the flags are used to track visibility of
-- the attribute definition clause for partial or incomplete views.
--- Has_Static_Discriminants (Flag211)
+-- Has_Static_Discriminants
-- Defined in record subtypes constrained by discriminant values. Set if
-- all the discriminant values have static values, meaning that in the
-- case of a variant record, the component list can be trimmed down to
-- include only the components corresponding to these discriminants.
--- Has_Static_Predicate (Flag269)
+-- Has_Static_Predicate
-- Defined in all types and subtypes. Set if the type (which must be a
-- scalar type) has a predicate whose expression is predicate-static.
-- This can result from the use of any Predicate, Static_Predicate, or
@@ -2103,7 +2062,7 @@ package Einfo is
-- description of the latter flag for further information on dynamic
-- predicates which are also static.
--- Has_Static_Predicate_Aspect (Flag259)
+-- Has_Static_Predicate_Aspect
-- Defined in all types and subtypes. Set if a Static_Predicate aspect
-- applies to the type. Note that we can tell if a static predicate is
-- present by looking at Has_Static_Predicate, but this could have come
@@ -2112,7 +2071,7 @@ package Einfo is
-- check policies apply, use this flag and Has_Dynamic_Predicate_Aspect
-- to determine which case we have).
--- Has_Storage_Size_Clause (Flag23) [implementation base type only]
+-- Has_Storage_Size_Clause [implementation base type only]
-- Defined in task types and access types. It is set if a Storage_Size
-- clause is present for the type. Used to prevent multiple clauses for
-- one type. Note that this flag is initially cleared for a derived type
@@ -2121,30 +2080,30 @@ package Einfo is
-- of access types, this flag is defined only in the root type, since a
-- storage size clause cannot be given to a derived type.
--- Has_Stream_Size_Clause (Flag184)
+-- Has_Stream_Size_Clause
-- Defined in all entities. It is set for types which have a Stream_Size
-- clause attribute. Used to prevent multiple Stream_Size clauses for a
-- given entity, and also whether it is necessary to check for a stream
-- size clause.
--- Has_Task (Flag30) [base type only]
+-- Has_Task [base type only]
-- Defined in all type entities. Set on task types themselves, and also
-- (recursively) on any composite type which has a component for which
-- Has_Task is set. The meaning is that an allocator or declaration of
-- such an object must create the required tasks. Note: the flag is not
-- set on access types, even if they designate an object that Has_Task.
--- Has_Timing_Event (Flag289) [base type only]
+-- Has_Timing_Event [base type only]
-- Defined in all type entities. Set on language defined type
-- Ada.Real_Time.Timing_Events.Timing_Event, and also (recursively) on
-- any composite type which has a component for which Has_Timing_Event
-- is set. Used for the No_Local_Timing_Event restriction.
--- Has_Thunks (Flag228)
+-- Has_Thunks
-- Applies to E_Constant entities marked Is_Tag. True for secondary tag
-- referencing a dispatch table whose contents are pointers to thunks.
--- Has_Unchecked_Union (Flag123) [base type only]
+-- Has_Unchecked_Union [base type only]
-- Defined in all type entities. Set on unchecked unions themselves
-- and (recursively) on any composite type which has a component for
-- which Has_Unchecked_Union is set. The meaning is that a comparison
@@ -2152,7 +2111,7 @@ package Einfo is
-- Note that the flag is not set on access types, even if they designate
-- an object that has the flag Has_Unchecked_Union set.
--- Has_Unknown_Discriminants (Flag72)
+-- Has_Unknown_Discriminants
-- Defined in all entities. Set for types with unknown discriminants.
-- Types can have unknown discriminants either from their declaration or
-- through type derivation. The use of this flag exactly meets the spec
@@ -2165,12 +2124,12 @@ package Einfo is
-- on the partial view, to ensure that discriminants are properly
-- inherited in certain contexts.
--- Has_Visible_Refinement (Flag263)
+-- Has_Visible_Refinement
-- Defined in E_Abstract_State entities. Set when a state has at least
-- one refinement constituent and analysis is in the region between
-- pragma Refined_State and the end of the package body declarations.
--- Has_Volatile_Components (Flag87) [implementation base type only]
+-- Has_Volatile_Components [implementation base type only]
-- Defined in all types and objects. Set only for an array type or array
-- object if a valid pragma Volatile_Components or a valid pragma
-- Atomic_Components applies to the type or object. Note that in the case
@@ -2181,7 +2140,7 @@ package Einfo is
-- type the pragma will be chained to the rep item chain of the first
-- subtype in the usual manner.
--- Has_Xref_Entry (Flag182)
+-- Has_Xref_Entry
-- Defined in all entities. Set if an entity has an entry in the Xref
-- information generated in ali files. This is true for all source
-- entities in the extended main source file. It is also true of entities
@@ -2190,11 +2149,11 @@ package Einfo is
-- references an entity with a type reference. See package Lib.Xref for
-- further details).
--- Has_Yield_Aspect (Flag308)
+-- Has_Yield_Aspect
-- Defined in subprograms, generic subprograms, entries, entry families.
-- Set if the entity has aspect Yield.
--- Hiding_Loop_Variable (Node8)
+-- Hiding_Loop_Variable
-- 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
-- the Hiding_Loop_Variable field of the hidden variable points to
@@ -2202,7 +2161,7 @@ package Einfo is
-- warning messages if the hidden variable turns out to be unused
-- or is referenced without being set.
--- Hidden_In_Formal_Instance (Elist30)
+-- Hidden_In_Formal_Instance
-- Defined on actuals for formal packages. Entities on the list are
-- formals that are hidden outside of the formal package when this
-- package is not declared with a box, or the formal itself is not
@@ -2210,13 +2169,13 @@ package Einfo is
-- from the current generic, because the actual for the formal package
-- may be used subsequently in the current unit.
--- Homonym (Node4)
+-- Homonym
-- Defined in all entities. Link for list of entities that have the
-- same source name and that are declared in the same or enclosing
-- scopes. Homonyms in the same scope are overloaded. Used for name
-- resolution and for the generation of debugging information.
--- Ignore_SPARK_Mode_Pragmas (Flag301)
+-- Ignore_SPARK_Mode_Pragmas
-- Present in concurrent type, entry, operator, [generic] package,
-- package body, [generic] subprogram, and subprogram body entities.
-- Set when the entity appears in an instance subject to SPARK_Mode
@@ -2230,52 +2189,52 @@ package Einfo is
-- that we still have a concrete type. For entities other than types,
-- returns the entity unchanged.
--- Import_Pragma (Node35)
+-- Import_Pragma
-- Defined in subprogram entities. Set if a valid pragma Import or pragma
-- Import_Function or pragma Import_Procedure applies to the subprogram,
-- in which case this field points to the pragma (we can't use the normal
-- Rep_Item chain mechanism, because a single pragma Import can apply
-- to multiple subprogram entities).
--- In_Package_Body (Flag48)
+-- In_Package_Body
-- Defined in package entities. Set on the entity that denotes the
-- package (the defining occurrence of the package declaration) while
-- analyzing and expanding the package body. Reset on completion of
-- analysis/expansion.
--- In_Private_Part (Flag45)
+-- In_Private_Part
-- Defined in all entities. Can be set only in package entities and
-- objects. For package entities, this flag is set to indicate that the
-- private part of the package is being analyzed. The flag is reset at
-- the end of the package declaration. For objects it indicates that the
-- declaration of the object occurs in the private part of a package.
--- Incomplete_Actuals (Elist24)
+-- Incomplete_Actuals
-- Defined on package entities that are instances. Indicates the actuals
-- types in the instantiation that are limited views. If this list is
-- not empty, the instantiation, which appears in a package declaration,
-- is relocated to the corresponding package body, which must have a
-- corresponding nonlimited with_clause.
--- Initialization_Statements (Node28)
+-- Initialization_Statements
-- Defined in constants and variables. For a composite object initialized
--- initialized with an aggregate that has been converted to a sequence
--- of assignments, points to a block statement containing the
+-- with an aggregate that has been converted to a sequence of
+-- assignments, points to a compound statement containing the
-- assignments.
--- Inner_Instances (Elist23)
+-- Inner_Instances
-- Defined in generic units. Contains element list of units that are
-- instantiated within the given generic. Used to diagnose circular
-- instantiations.
--- Interface_Alias (Node25)
+-- Interface_Alias
-- Defined in subprograms that cover a primitive operation of an abstract
-- interface type. Can be set only if the Is_Hidden flag is also set,
-- since such entities are always hidden. Points to its associated
-- interface subprogram. It is used to register the subprogram in
-- secondary dispatch table of the interface (Ada 2005: AI-251).
--- Interface_Name (Node21)
+-- Interface_Name
-- Defined in constants, variables, exceptions, functions, procedures,
-- and packages. Set to Empty unless an export, import, or interface name
-- pragma has explicitly specified an external name, in which case it
@@ -2286,7 +2245,7 @@ package Einfo is
-- Interface_Name is ignored if an address clause is present (since it
-- is meaningless in this case).
--- Interfaces (Elist25)
+-- Interfaces
-- Defined in record types and subtypes. List of abstract interfaces
-- implemented by a tagged type that are not already implemented by the
-- ancestors (Ada 2005: AI-251).
@@ -2307,21 +2266,21 @@ package Einfo is
-- Note: the reason this is marked as a synthesized attribute is that the
-- way this is stored is as an element of the Subprograms_For_Type field.
--- In_Use (Flag8)
+-- In_Use
-- Defined in packages and types. Set when analyzing a use clause for
-- the corresponding entity. Reset at end of corresponding declarative
-- part. The flag on a type is also used to determine the visibility of
-- the primitive operators of the type.
--- Is_Abstract_Subprogram (Flag19)
+-- Is_Abstract_Subprogram
-- Defined in all subprograms and entries. Set for abstract subprograms.
-- Always False for enumeration literals and entries. See also
-- Requires_Overriding.
--- Is_Abstract_Type (Flag146)
+-- Is_Abstract_Type
-- Defined in all types. Set for abstract types.
--- Is_Access_Constant (Flag69)
+-- Is_Access_Constant
-- Defined in access types and subtypes. Indicates that the keyword
-- constant was present in the access type definition.
@@ -2335,30 +2294,37 @@ package Einfo is
-- Is_Access_Object_Type (synthesized)
-- Applies to all entities, true for access-to-object types and subtypes
--- Is_Activation_Record (Flag305)
+-- Is_Activation_Record
-- Applies to E_In_Parameters generated in Exp_Unst for nested
-- subprograms, to mark the added formal that carries the activation
-- record created in the enclosing subprogram.
--- Is_Actual_Subtype (Flag293)
+-- Is_Actual_Subtype
-- Defined on all types, true for the generated constrained subtypes
-- that are built for unconstrained composite actuals.
--- Is_Ada_2005_Only (Flag185)
+-- Is_Ada_2005_Only
-- Defined in all entities, true if a valid pragma Ada_05 or Ada_2005
-- applies to the entity which specifically names the entity, indicating
-- that the entity is Ada 2005 only. Note that this flag is not set if
-- the entity is part of a unit compiled with the normal no-argument form
-- of pragma Ada_05 or Ada_2005.
--- Is_Ada_2012_Only (Flag199)
+-- Is_Ada_2012_Only
-- Defined in all entities, true if a valid pragma Ada_12 or Ada_2012
-- applies to the entity which specifically names the entity, indicating
-- that the entity is Ada 2012 only. Note that this flag is not set if
-- the entity is part of a unit compiled with the normal no-argument form
-- of pragma Ada_12 or Ada_2012.
--- Is_Aliased (Flag15)
+-- Is_Ada_2022_Only
+-- Defined in all entities, true if a valid pragma Ada_2022 applies to
+-- the entity which specifically names the entity, indicating that the
+-- entity is Ada 2022 only. Note that this flag is not set if the entity
+-- is part of a unit compiled with the normal no-argument form of pragma
+-- Ada_2022.
+
+-- Is_Aliased
-- Defined in all entities. Set for objects and types whose declarations
-- carry the keyword aliased, and on record components that have the
-- keyword. For Ada 2012, also applies to formal parameters.
@@ -2366,11 +2332,11 @@ package Einfo is
-- Is_Array_Type (synthesized)
-- Applies to all entities, true for array types and subtypes
--- Is_Asynchronous (Flag81)
+-- Is_Asynchronous
-- Defined in all type entities and in procedure entities. Set
-- if a pragma Asynchronous applies to the entity.
--- Is_Atomic (Flag85)
+-- Is_Atomic
-- Defined in all type entities, and also in constants, components, and
-- variables. Set if a pragma Atomic or Shared applies to the entity.
-- In the case of private and incomplete types, this flag is set in
@@ -2379,14 +2345,14 @@ package Einfo is
-- Is_Full_Access (synth)
-- Defined in all type entities, and also in constants, components and
-- variables. Set if an aspect/pragma Atomic/Shared, or an aspect/pragma
--- Volatile_Full_Access or an Ada 2020 aspect Full_Access_Only applies
+-- Volatile_Full_Access or an Ada 2022 aspect Full_Access_Only applies
-- to the entity. In the case of private and incomplete types, the flag
-- applies to both the partial view and the full view.
-- Is_Base_Type (synthesized)
-- Applies to type and subtype entities. True if entity is a base type.
--- Is_Bit_Packed_Array (Flag122) [implementation base type only]
+-- Is_Bit_Packed_Array [implementation base type only]
-- Defined in all entities. This flag is set for a packed array type that
-- is bit-packed (i.e. the component size is known by the front end and
-- is in the range 1-63 but not a multiple of 8). Is_Packed is always set
@@ -2399,33 +2365,27 @@ package Einfo is
-- Applies to all entities, true for boolean types and subtypes,
-- i.e. Standard.Boolean and all types ultimately derived from it.
--- Is_Called (Flag102)
+-- Is_Called
-- Defined in subprograms and packages. Set if a subprogram is called
-- from the unit being compiled or a unit in the closure. Also set for
-- a package that contains called subprograms. Used only for inlining.
--- Is_Character_Type (Flag63)
+-- Is_Character_Type
-- Defined in all entities. Set for character types and subtypes,
-- i.e. enumeration types that have at least one character literal.
--- Is_Checked_Ghost_Entity (Flag277)
+-- Is_Checked_Ghost_Entity
-- Applies to all entities. Set for abstract states, [generic] packages,
-- [generic] subprograms, components, discriminants, formal parameters,
-- objects, package bodies, subprogram bodies, and [sub]types subject to
-- pragma Ghost or inherit "ghostness" from an enclosing construct, and
-- subject to Assertion_Policy Ghost => Check.
--- Is_Child_Unit (Flag73)
+-- Is_Child_Unit
-- Defined in all entities. Set only for defining entities of program
-- units that are child units (but False for subunits).
--- Is_Class_Wide_Clone (Flag290)
--- Defined on subprogram entities. Set for subprograms built in order
--- to implement properly the inheritance of class-wide pre- or post-
--- conditions when the condition contains calls to other primitives
--- of the ancestor type. Used to implement AI12-0195.
-
--- Is_Class_Wide_Equivalent_Type (Flag35)
+-- Is_Class_Wide_Equivalent_Type
-- Defined in record types and subtypes. Set to True, if the type acts
-- as a class-wide equivalent type, i.e. the Equivalent_Type field of
-- some class-wide subtype entity references this record type.
@@ -2433,13 +2393,13 @@ package Einfo is
-- Is_Class_Wide_Type (synthesized)
-- Applies to all entities, true for class wide types and subtypes
--- Is_Compilation_Unit (Flag149)
+-- Is_Compilation_Unit
-- Defined in all entities. Set if the entity is a package or subprogram
-- entity for a compilation unit other than a subunit (since we treat
-- subunits as part of the same compilation operation as the ultimate
-- parent, we do not consider them to be separate units for this flag).
--- Is_Completely_Hidden (Flag103)
+-- Is_Completely_Hidden
-- Defined on discriminants. Only set on girder discriminants of
-- untagged types. When set, the entity is a girder discriminant of a
-- derived untagged type which is not directly visible in the derived
@@ -2452,7 +2412,7 @@ package Einfo is
-- Either Is_Composite_Type or Is_Elementary_Type (but not both) is true
-- of any type.
--- Is_Concurrent_Record_Type (Flag20)
+-- Is_Concurrent_Record_Type
-- Defined in record types and subtypes. Set if the type was created
-- by the expander to represent a task or protected type. For every
-- concurrent type, such as record type is constructed, and task and
@@ -2469,28 +2429,28 @@ package Einfo is
-- Applies to all entities, true for E_Constant, E_Loop_Parameter, and
-- E_In_Parameter entities.
--- Is_Constrained (Flag12)
+-- Is_Constrained
-- Defined in types or subtypes which may have index, discriminant
-- or range constraint (i.e. array types and subtypes, record types
-- and subtypes, string types and subtypes, and all numeric types).
-- Set if the type or subtype is constrained.
--- Is_Constr_Subt_For_U_Nominal (Flag80)
+-- Is_Constr_Subt_For_U_Nominal
-- Defined in all types and subtypes. Set only for the constructed
-- subtype of an object whose nominal subtype is unconstrained. Note
-- that the constructed subtype itself will be constrained.
--- Is_Constr_Subt_For_UN_Aliased (Flag141)
+-- Is_Constr_Subt_For_UN_Aliased
-- Defined in all types and subtypes. This flag can be set only if
-- Is_Constr_Subt_For_U_Nominal is also set. It indicates that in
-- addition the object concerned is aliased. This flag is used by
-- the backend to determine whether a template must be constructed.
--- Is_Constructor (Flag76)
+-- Is_Constructor
-- Defined in function and procedure entities. Set if a pragma
-- CPP_Constructor applies to the subprogram.
--- Is_Controlled_Active (Flag42) [base type only]
+-- Is_Controlled_Active [base type only]
-- Defined in all type entities. Indicates that the type is controlled,
-- i.e. is either a descendant of Ada.Finalization.Controlled or of
-- Ada.Finalization.Limited_Controlled.
@@ -2499,15 +2459,15 @@ package Einfo is
-- Defined in all type entities. Set if Is_Controlled_Active is set for
-- the type, and Disable_Controlled is not set.
--- Is_Controlling_Formal (Flag97)
+-- Is_Controlling_Formal
-- Defined in all Formal_Kind entities. Marks the controlling parameters
-- of dispatching operations.
--- Is_CPP_Class (Flag74)
+-- Is_CPP_Class
-- 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)
+-- Is_CUDA_Kernel
-- Defined in function and procedure entities. Set if the subprogram is a
-- CUDA kernel.
@@ -2515,11 +2475,11 @@ package Einfo is
-- Applies to all type entities, true for decimal fixed point
-- types and subtypes.
--- Is_Descendant_Of_Address (Flag223)
+-- Is_Descendant_Of_Address
-- Defined in all entities. True if the entity is type System.Address,
-- or (recursively) a subtype or derived type of System.Address.
--- Is_DIC_Procedure (Flag132)
+-- Is_DIC_Procedure
-- Defined in functions and procedures. Set for a generated procedure
-- which verifies the assumption of pragma Default_Initial_Condition at
-- run time.
@@ -2531,11 +2491,11 @@ package Einfo is
-- Is_Discrete_Type (synthesized)
-- Applies to all entities, true for all discrete types and subtypes
--- Is_Discrim_SO_Function (Flag176)
+-- Is_Discrim_SO_Function
-- Defined in all entities. Set only in E_Function entities that Layout
-- creates to compute discriminant-dependent dynamic size/offset values.
--- Is_Discriminant_Check_Function (Flag264)
+-- Is_Discriminant_Check_Function
-- Defined in all entities. Set only in E_Function entities for functions
-- created to do discriminant checks.
@@ -2543,11 +2503,11 @@ package Einfo is
-- Applies to all entities, true for renamings of discriminants. Such
-- entities appear as constants or IN parameters.
--- Is_Dispatch_Table_Entity (Flag234)
+-- Is_Dispatch_Table_Entity
-- Applies to all entities. Set to indicate to the backend that this
-- entity is associated with a dispatch table.
--- Is_Dispatching_Operation (Flag6)
+-- Is_Dispatching_Operation
-- Defined in all entities. Set for procedures, functions, generic
-- procedures, and generic functions if the corresponding operation
-- is dispatching.
@@ -2557,7 +2517,7 @@ package Einfo is
-- scope (i.e. a block, subprogram, task_type, entry or extended return
-- statement).
--- Is_Elaboration_Checks_OK_Id (Flag148)
+-- Is_Elaboration_Checks_OK_Id
-- Defined in elaboration targets (see terminology in Sem_Elab). Set when
-- the target appears in a region which is subject to elabled elaboration
-- checks. Such targets are allowed to generate run-time conditional ABE
@@ -2567,7 +2527,7 @@ package Einfo is
-- Applies to all entities, True only for elaboration targets (see the
-- terminology in Sem_Elab).
--- Is_Elaboration_Warnings_OK_Id (Flag304)
+-- Is_Elaboration_Warnings_OK_Id
-- Defined in elaboration targets (see terminology in Sem_Elab). Set when
-- the target appears in a region with elaboration warnings enabled.
@@ -2576,7 +2536,7 @@ package Einfo is
-- Either Is_Composite_Type or Is_Elementary_Type (but not both) is true
-- of any type.
--- Is_Eliminated (Flag124)
+-- Is_Eliminated
-- Defined in type entities, subprogram entities, and object entities.
-- Indicates that the corresponding entity has been eliminated by use
-- of pragma Eliminate. Also used to mark subprogram entities whose
@@ -2586,23 +2546,23 @@ package Einfo is
-- Applies to all entities, True only for entry and entry family
-- entities and False for all other entity kinds.
--- Is_Entry_Formal (Flag52)
+-- Is_Entry_Formal
-- Defined in all entities. Set only for entry formals (which can only
-- be in, in-out or out parameters). This flag is used to speed up the
-- test for the need to replace references in Exp_Ch2.
--- Is_Entry_Wrapper (Flag297)
+-- Is_Entry_Wrapper
-- Defined on wrappers created for entries that have precondition aspects
-- Is_Enumeration_Type (synthesized)
-- Defined in all entities, true for enumeration types and subtypes
--- Is_Exception_Handler (Flag286)
+-- Is_Exception_Handler
-- Defined in blocks. Set if the block serves only as a scope of an
-- exception handler with a choice parameter. Such a block does not
-- physically appear in the tree.
--- Is_Exported (Flag99)
+-- Is_Exported
-- Defined in all entities. Set if the entity is exported. For now we
-- only allow the export of constants, exceptions, functions, procedures
-- and variables, but that may well change later on. Exceptions can only
@@ -2612,7 +2572,7 @@ package Einfo is
-- Applies to all entities, true for abstract states that are subject to
-- option External or Synchronous.
--- Is_Finalized_Transient (Flag252)
+-- Is_Finalized_Transient
-- Defined in constants, loop parameters of generalized iterators, and
-- variables. Set when a transient object has been finalized by one of
-- the transient finalization mechanisms. The flag prevents the double
@@ -2622,7 +2582,7 @@ package Einfo is
-- Applies to all entities, true for procedures containing finalization
-- code to process local or library level objects.
--- Is_First_Subtype (Flag70)
+-- Is_First_Subtype
-- Defined in all entities. True for first subtypes (RM 3.2.1(6)),
-- i.e. the entity in the type declaration that introduced the type.
-- This may be the base type itself (e.g. for record declarations and
@@ -2630,6 +2590,16 @@ package Einfo is
-- an anonymous base type (e.g. for integer type declarations or
-- constrained array declarations).
+-- Is_Fixed_Lower_Bound_Array_Subtype
+-- Defined in type entities. True for unconstrained array types and
+-- subtypes where at least one index has a range specified with a fixed
+-- lower bound (range syntax is "<expression> .. <>").
+
+-- Is_Fixed_Lower_Bound_Index_Subtype
+-- Defined in type entities. True for an index of an unconstrained array
+-- type or subtype whose range is specified with a fixed lower bound
+-- (range syntax is "<expression> .. <>").
+
-- Is_Fixed_Point_Type (synthesized)
-- Applies to all entities, true for decimal and ordinary fixed
-- point types and subtypes.
@@ -2643,21 +2613,21 @@ package Einfo is
-- Is_Formal_Object (synthesized)
-- Applies to all entities, true for generic IN and IN OUT parameters
--- Is_Formal_Subprogram (Flag111)
+-- Is_Formal_Subprogram
-- Defined in all entities. Set for generic formal subprograms.
--- Is_Frozen (Flag4)
+-- Is_Frozen
-- Defined in all type and subtype entities. Set if type or subtype has
-- been frozen.
--- Is_Generic_Actual_Subprogram (Flag274)
+-- Is_Generic_Actual_Subprogram
-- Defined on functions and procedures. Set on the entity of the renaming
-- declaration created within an instance for an actual subprogram.
-- Used to generate constraint checks on calls to these subprograms, even
-- within an instance of a predefined run-time unit, in which checks
-- are otherwise suppressed.
--- Is_Generic_Actual_Type (Flag94)
+-- Is_Generic_Actual_Type
-- Defined in all type and subtype entities. Set in the subtype
-- declaration that renames the generic formal as a subtype of the
-- actual. Guarantees that the subtype is not static within the instance.
@@ -2665,7 +2635,7 @@ package Einfo is
-- accidental overloading that occurs when different formal types get the
-- same actual.
--- Is_Generic_Instance (Flag130)
+-- Is_Generic_Instance
-- Defined in all entities. Set to indicate that the entity is an
-- instance of a generic unit, or a formal package (which is an instance
-- of the template).
@@ -2674,7 +2644,7 @@ package Einfo is
-- Applies to all entities. Yields True for a generic subprogram
-- (generic function, generic subprogram), False for all other entities.
--- Is_Generic_Type (Flag13)
+-- Is_Generic_Type
-- Defined in all entities. Set for types which are generic formal types.
-- Such types have an Ekind that corresponds to their classification, so
-- the Ekind cannot be used to identify generic formal types.
@@ -2691,7 +2661,7 @@ package Einfo is
-- subject to pragma Ghost or those that inherit the Ghost property from
-- an enclosing construct.
--- Is_Hidden (Flag57)
+-- Is_Hidden
-- Defined in all entities. Set for all entities declared in the
-- private part or body of a package. Also marks generic formals of a
-- formal package declared without a box. For library level entities,
@@ -2701,42 +2671,42 @@ package Einfo is
-- child unit, and when compiling a private child unit (see Install_
-- Private_Declaration in sem_ch7).
--- Is_Hidden_Non_Overridden_Subpgm (Flag2)
+-- Is_Hidden_Non_Overridden_Subpgm
-- Defined in all entities. Set for implicitly declared subprograms
-- that require overriding or are null procedures, and are hidden by
-- a non-fully conformant homograph with the same characteristics
-- (Ada RM 8.3 12.3/2).
--- Is_Hidden_Open_Scope (Flag171)
+-- Is_Hidden_Open_Scope
-- Defined in all entities. Set for a scope that contains the
-- instantiation of a child unit, and whose entities are not visible
-- during analysis of the instance.
--- Is_Ignored_Ghost_Entity (Flag278)
+-- Is_Ignored_Ghost_Entity
-- Applies to all entities. Set for abstract states, [generic] packages,
-- [generic] subprograms, components, discriminants, formal parameters,
-- objects, package bodies, subprogram bodies, and [sub]types subject to
-- pragma Ghost or inherit "ghostness" from an enclosing construct, and
-- subject to Assertion_Policy Ghost => Ignore.
--- Is_Ignored_Transient (Flag295)
+-- Is_Ignored_Transient
-- Defined in constants, loop parameters of generalized iterators, and
-- variables. Set when a transient object must be processed by one of
-- the transient finalization mechanisms. Once marked, a transient is
-- intentionally ignored by the general finalization mechanism because
-- its clean up actions are context specific.
--- Is_Immediately_Visible (Flag7)
+-- Is_Immediately_Visible
-- Defined in all entities. Set if entity is immediately visible, i.e.
-- is defined in some currently open scope (RM 8.3(4)).
--- Is_Implementation_Defined (Flag254)
+-- Is_Implementation_Defined
-- Defined in all entities. Set if a pragma Implementation_Defined is
-- applied to the pragma. Used to mark all implementation defined
-- identifiers in standard library packages, and to implement the
-- restriction No_Implementation_Identifiers.
--- Is_Imported (Flag24)
+-- Is_Imported
-- Defined in all entities. Set if the entity is imported. For now we
-- only allow the import of exceptions, functions, procedures, packages,
-- constants, and variables. Exceptions, packages, and types can only be
@@ -2748,7 +2718,7 @@ package Einfo is
-- Is_Incomplete_Type (synthesized)
-- Applies to all entities, true for incomplete types and subtypes
--- Is_Independent (Flag268)
+-- Is_Independent
-- Defined in all types and objects. Set if a valid pragma or aspect
-- Independent applies to the entity, or for a component if a valid
-- pragma or aspect Independent_Components applies to the enclosing
@@ -2758,11 +2728,11 @@ package Einfo is
-- case of private and incomplete types, this flag is set in both the
-- partial view and the full view.
--- Is_Initial_Condition_Procedure (Flag302)
+-- Is_Initial_Condition_Procedure
-- Defined in functions and procedures. Set for a generated procedure
-- which verifies the assumption of pragma Initial_Condition at run time.
--- Is_Inlined (Flag11)
+-- Is_Inlined
-- Defined in all entities. Set for functions and procedures which are
-- to be inlined. For subprograms created during expansion, this flag
-- may be set directly by the expander to request inlining. Also set
@@ -2771,13 +2741,13 @@ package Einfo is
-- inherited by their instances. It is also set on the body entities
-- of inlined subprograms. See also Has_Pragma_Inline.
--- Is_Inlined_Always (Flag1)
+-- Is_Inlined_Always
-- Defined in subprograms. Set for functions and procedures which are
-- always inlined in GNATprove mode. GNATprove uses this flag to know
-- when a body does not need to be analyzed. The value of this flag is
-- only meaningful if Body_To_Inline is not Empty for the subprogram.
--- Is_Instantiated (Flag126)
+-- Is_Instantiated
-- Defined in generic packages and generic subprograms. Set if the unit
-- is instantiated from somewhere in the extended main source unit. This
-- flag is used to control warnings about the unit being uninstantiated.
@@ -2788,7 +2758,7 @@ package Einfo is
-- Is_Integer_Type (synthesized)
-- Applies to all entities, true for integer types and subtypes
--- Is_Interface (Flag186)
+-- Is_Interface
-- Defined in record types and subtypes. Set to indicate that the current
-- entity corresponds to an abstract interface. Because abstract
-- interfaces are conceptually a special kind of abstract tagged type
@@ -2797,7 +2767,7 @@ package Einfo is
-- compiler support for abstract tagged types to implement interfaces
-- (Ada 2005: AI-251).
--- Is_Internal (Flag17)
+-- Is_Internal
-- Defined in all entities. Set to indicate an entity created during
-- semantic processing (e.g. an implicit type, or a temporary). The
-- current uses of this flag are:
@@ -2821,12 +2791,12 @@ package Einfo is
-- are used to handle secondary dispatch tables. These entities have
-- also the attribute Interface_Alias.
--- Is_Interrupt_Handler (Flag89)
+-- Is_Interrupt_Handler
-- Defined in procedures. Set if a pragma Interrupt_Handler applies
--- to the procedure. The procedure must be parameterless, and on all
--- targets except AAMP it must be a protected procedure.
+-- to the procedure. The procedure must be a parameterless protected
+-- procedure.
--- Is_Intrinsic_Subprogram (Flag64)
+-- Is_Intrinsic_Subprogram
-- Defined in functions and procedures. It is set if a valid pragma
-- Interface or Import is present for this subprogram specifying
-- convention Intrinsic. Valid means that the name and profile of the
@@ -2837,13 +2807,13 @@ package Einfo is
-- convention set to intrinsic, which causes intrinsic code to be
-- generated.
--- Is_Invariant_Procedure (Flag257)
+-- Is_Invariant_Procedure
-- Defined in functions and procedures. Set for a generated invariant
-- procedure which verifies the invariants of both the partial and full
-- views of a private type or private extension as well as any inherited
-- class-wide invariants from parent types or interfaces.
--- Is_Itype (Flag91)
+-- Is_Itype
-- Defined in all entities. Set to indicate that a type is an Itype,
-- which means that the declaration for the type does not appear
-- explicitly in the tree. Instead the backend will elaborate the type
@@ -2853,7 +2823,7 @@ package Einfo is
-- on Itypes is that the first use of such a type (the one that causes it
-- to be defined) must be in the same scope as the type.
--- Is_Known_Non_Null (Flag37)
+-- Is_Known_Non_Null
-- Defined in all entities. Relevant (and can be set) only for
-- objects of an access type. It is set if the object is currently
-- known to have a non-null value (meaning that no access checks
@@ -2874,7 +2844,7 @@ package Einfo is
-- fully constructed, since it simply indicates the last state.
-- Thus this flag has no meaning to the backend.
--- Is_Known_Null (Flag204)
+-- Is_Known_Null
-- Defined in all entities. Relevant (and can be set ) only for
-- objects of an access type. It is set if the object is currently known
-- to have a null value (meaning that a dereference will surely raise
@@ -2884,7 +2854,7 @@ package Einfo is
-- The comments above about sequential flow and aliased and volatile for
-- the Is_Known_Non_Null flag apply equally to the Is_Known_Null flag.
--- Is_Known_Valid (Flag170)
+-- Is_Known_Valid
-- Defined in all entities. Relevant for types (and subtype) and
-- for objects (and enumeration literals) of a discrete type.
--
@@ -2918,24 +2888,24 @@ package Einfo is
-- fully constructed, since it simply indicates the last state.
-- Thus this flag has no meaning to the backend.
--- Is_Limited_Composite (Flag106)
+-- Is_Limited_Composite
-- Defined in all entities. Set for composite types that have a limited
-- component. Used to enforce the rule that operations on the composite
-- type that depend on the full view of the component do not become
-- visible until the immediate scope of the composite type itself
-- (RM 7.3.1 (5)).
--- Is_Limited_Interface (Flag197)
+-- Is_Limited_Interface
-- Defined in record types and subtypes. True for interface types, if
-- interface is declared limited, task, protected, or synchronized, or
-- is derived from a limited interface.
--- Is_Limited_Record (Flag25)
+-- Is_Limited_Record
-- Defined in all entities. Set to true for record (sub)types if the
-- record is declared to be limited. Note that this flag is not set
-- simply because some components of the record are limited.
--- Is_Local_Anonymous_Access (Flag194)
+-- Is_Local_Anonymous_Access
-- Defined in access types. Set for an anonymous access type to indicate
-- that the type is created for a record component with an access
-- definition, an array component, or (pre-Ada 2012) a standalone object.
@@ -2944,13 +2914,13 @@ package Einfo is
-- that are created for access parameters, access discriminants, and
-- (as of Ada 2012) stand-alone objects.
--- Is_Loop_Parameter (Flag307)
+-- Is_Loop_Parameter
-- Applies to all entities. Certain loops, in particular "for ... of"
-- loops, get transformed so that the loop parameter is declared by a
-- variable declaration, so the entity is an E_Variable. This is True for
-- such E_Variables; False otherwise.
--- Is_Machine_Code_Subprogram (Flag137)
+-- Is_Machine_Code_Subprogram
-- Defined in subprogram entities. Set to indicate that the subprogram
-- is a machine code subprogram (i.e. its body includes at least one
-- code statement). Also indicates that all necessary semantic checks
@@ -2959,7 +2929,7 @@ package Einfo is
-- Is_Modular_Integer_Type (synthesized)
-- Applies to all entities. True if entity is a modular integer type
--- Is_Non_Static_Subtype (Flag109)
+-- Is_Non_Static_Subtype
-- Defined in all type and subtype entities. It is set in some (but not
-- all) cases in which a subtype is known to be non-static. Before this
-- flag was added, the computation of whether a subtype was static was
@@ -2975,7 +2945,7 @@ package Einfo is
-- set right, at which point, these comments can be removed, and the
-- tests for static subtypes greatly simplified.
--- Is_Null_Init_Proc (Flag178)
+-- Is_Null_Init_Proc
-- Defined in procedure entities. Set for generated init proc procedures
-- (used to initialize composite types), if the code for the procedure
-- is null (i.e. is a return and nothing else). Such null initialization
@@ -2996,11 +2966,11 @@ package Einfo is
-- Applies to all entities, true for entities representing objects,
-- including generic formal parameters.
--- Is_Obsolescent (Flag153)
+-- Is_Obsolescent
-- Defined in all entities. Set for any entity to which a valid pragma
-- or aspect Obsolescent applies.
--- Is_Only_Out_Parameter (Flag226)
+-- Is_Only_Out_Parameter
-- Defined in formal parameter entities. Set if this parameter is the
-- only OUT parameter for this formal part. If there is more than one
-- out parameter, or if there is some other IN OUT parameter then this
@@ -3010,7 +2980,7 @@ package Einfo is
-- Applies to all entities, true for ordinary fixed point types and
-- subtypes.
--- Is_Package_Body_Entity (Flag160)
+-- Is_Package_Body_Entity
-- Defined in all entities. Set for entities defined at the top level
-- of a package body. Used to control externally generated names.
@@ -3018,7 +2988,7 @@ package Einfo is
-- Applies to all entities. True for packages and generic packages.
-- False for all other entities.
--- Is_Packed (Flag51) [implementation base type only]
+-- Is_Packed [implementation base type only]
-- Defined in all type entities. This flag is set only for record and
-- array types which have a packed representation. There are four cases
-- which cause packing:
@@ -3056,7 +3026,7 @@ package Einfo is
-- Is_Packed_Array (synth)
-- Applies to all entities, true if entity is for a packed array.
--- Is_Packed_Array_Impl_Type (Flag138)
+-- Is_Packed_Array_Impl_Type
-- Defined in all entities. This flag is set on the entity for the type
-- used to implement a packed array (either a modular type or a subtype
-- of Packed_Bytes{1,2,4} in the bit-packed array case, a regular array
@@ -3068,45 +3038,45 @@ package Einfo is
-- set in an entity, then the Original_Array_Type field of this entity
-- points to the array type for which this is the Packed_Array_Impl_Type.
--- Is_Param_Block_Component_Type (Flag215) [base type only]
+-- Is_Param_Block_Component_Type [base type only]
-- Defined in access types. Set to indicate that a type is the type of a
-- component of the parameter block record type generated by the compiler
-- for an entry or a select statement. Read by CodePeer.
--- Is_Partial_Invariant_Procedure (Flag292)
+-- Is_Partial_Invariant_Procedure
-- Defined in functions and procedures. Set for a generated invariant
-- procedure which verifies the invariants of the partial view of a
-- private type or private extension.
--- Is_Potentially_Use_Visible (Flag9)
+-- Is_Potentially_Use_Visible
-- Defined in all entities. Set if entity is potentially use visible,
-- i.e. it is defined in a package that appears in a currently active
-- use clause (RM 8.4(8)). Note that potentially use visible entities
-- are not necessarily use visible (RM 8.4(9-11)).
--- Is_Predicate_Function (Flag255)
+-- Is_Predicate_Function
-- Present in functions and procedures. Set for generated predicate
-- functions.
--- Is_Predicate_Function_M (Flag256)
+-- Is_Predicate_Function_M
-- Present in functions and procedures. Set for special version of
-- predicate function generated for use in membership tests, where
-- raise expressions are transformed to return False.
--- Is_Preelaborated (Flag59)
+-- Is_Preelaborated
-- Defined in all entities, set in E_Package and E_Generic_Package
-- entities to which a pragma Preelaborate is applied, and also in
-- all entities within such packages. Note that the fact that this
-- flag is set does not necesarily mean that no elaboration code is
-- generated for the package.
--- Is_Primitive (Flag218)
+-- Is_Primitive
-- Defined in overloadable entities and in generic subprograms. Set to
-- indicate that this is a primitive operation of some type, which may
-- be a tagged type or an untagged type. Used to verify overriding
-- indicators in bodies.
--- Is_Primitive_Wrapper (Flag195)
+-- Is_Primitive_Wrapper
-- Defined in functions and procedures created by the expander to serve
-- as an indirection mechanism to overriding primitives of concurrent
-- types, entries and protected procedures.
@@ -3115,19 +3085,19 @@ package Einfo is
-- Applies to all entities, true for renamings of private protected
-- components. Such entities appear as constants or variables.
--- Is_Private_Composite (Flag107)
+-- Is_Private_Composite
-- Defined in composite types that have a private component. Used to
-- enforce the rule that operations on the composite type that depend
-- on the full view of the component, do not become visible until the
-- immediate scope of the composite type itself (7.3.1 (5)). Both this
-- flag and Is_Limited_Composite are needed.
--- Is_Private_Descendant (Flag53)
+-- Is_Private_Descendant
-- Defined in entities that can represent library units (packages,
-- functions, procedures). Set if the library unit is itself a private
-- child unit, or if it is the descendant of a private child unit.
--- Is_Private_Primitive (Flag245)
+-- Is_Private_Primitive
-- Defined in subprograms. Set if the operation is a primitive of a
-- tagged type (procedure or function dispatching on result) whose
-- full view has not been seen. Used in particular for primitive
@@ -3154,14 +3124,14 @@ package Einfo is
-- Is_Protected_Type (synthesized)
-- Applies to all entities, true for protected types and subtypes
--- Is_Public (Flag10)
+-- Is_Public
-- Defined in all entities. Set to indicate that an entity defined in
-- one compilation unit can be referenced from other compilation units.
-- If this reference causes a reference in the generated code, for
-- example in the case of a variable name, then the backend will generate
-- an appropriate external name for use by the linker.
--- Is_Pure (Flag44)
+-- Is_Pure
-- Defined in all entities. Set in all entities of a unit to which a
-- pragma Pure is applied except for non-intrinsic imported subprograms,
-- and also set for the entity of the unit itself. In addition, this
@@ -3171,16 +3141,16 @@ package Einfo is
-- from side effects (other than those resulting from assignment to Out
-- or In Out parameters, or to objects designated by access parameters).
--- Is_Pure_Unit_Access_Type (Flag189)
+-- Is_Pure_Unit_Access_Type
-- Defined in access type and subtype entities. Set if the type or
-- subtype appears in a pure unit. Used to give an error message at
-- freeze time if the access type has a storage pool.
--- Is_RACW_Stub_Type (Flag244)
+-- Is_RACW_Stub_Type
-- Defined in all types, true for the stub types generated for remote
-- access-to-class-wide types.
--- Is_Raised (Flag224)
+-- Is_Raised
-- Defined in exception entities. Set if the entity is referenced by a
-- a raise statement.
@@ -3195,29 +3165,29 @@ package Einfo is
-- Applies to all entities, true for abstract states that are subject to
-- option Relaxed_Initialization.
--- Is_Remote_Call_Interface (Flag62)
+-- Is_Remote_Call_Interface
-- Defined in all entities. Set in E_Package and E_Generic_Package
-- entities to which a pragma Remote_Call_Interface is applied, and
-- also on entities declared in the visible part of such a package.
--- Is_Remote_Types (Flag61)
+-- Is_Remote_Types
-- Defined in all entities. Set in E_Package and E_Generic_Package
-- entities to which a pragma Remote_Types is applied, and also on
-- entities declared in the visible part of the spec of such a package.
-- Also set for types which are generic formal types to which the
-- pragma Remote_Access_Type applies.
--- Is_Renaming_Of_Object (Flag112)
+-- Is_Renaming_Of_Object
-- Defined in all entities, set only for a variable or constant for
-- which the Renamed_Object field is non-empty and for which the
-- renaming is handled by the front end, by macro substitution of
-- a copy of the (evaluated) name tree whereever the variable is used.
--- Is_Return_Object (Flag209)
+-- Is_Return_Object
-- Defined in all object entities. True if the object is the return
-- object of an extended_return_statement; False otherwise.
--- Is_Safe_To_Reevaluate (Flag249)
+-- Is_Safe_To_Reevaluate
-- Defined in all entities. Set in variables that are initialized by
-- means of an assignment statement. When initialized their contents
-- never change and hence they can be seen by the backend as constants.
@@ -3226,7 +3196,7 @@ package Einfo is
-- Is_Scalar_Type (synthesized)
-- Applies to all entities, true for scalar types and subtypes
--- Is_Shared_Passive (Flag60)
+-- Is_Shared_Passive
-- Defined in all entities. Set in E_Package and E_Generic_Package
-- entities to which a pragma Shared_Passive is applied, and also in
-- all entities within such packages.
@@ -3241,7 +3211,7 @@ package Einfo is
-- type is one of the standard string types (String, Wide_String, or
-- Wide_Wide_String).
--- Is_Static_Type (Flag281)
+-- Is_Static_Type
-- Defined in entities. Only set for (sub)types. If set, indicates that
-- the type is known to be a static type (defined as a discrete type with
-- static bounds, a record all of whose component types are static types,
@@ -3249,7 +3219,7 @@ package Einfo is
-- a component type that is a static type). See Set_Uplevel_Type for more
-- information on how this flag is used.
--- Is_Statically_Allocated (Flag28)
+-- Is_Statically_Allocated
-- Defined in all entities. This can only be set for exception,
-- variable, constant, and type/subtype entities. If the flag is set,
-- then the variable or constant must be allocated statically rather
@@ -3288,13 +3258,13 @@ package Einfo is
-- Applies to all entities, true for abstract states that are subject to
-- option Synchronous.
--- Is_Tag (Flag78)
+-- Is_Tag
-- Defined in E_Component and E_Constant entities. For regular tagged
-- type this flag is set on the tag component (whose name is Name_uTag).
-- For CPP_Class tagged types, this flag marks the pointer to the main
-- vtable (i.e. the one to be extended by derivation).
--- Is_Tagged_Type (Flag55)
+-- Is_Tagged_Type
-- Defined in all entities, set for an entity that is a tagged type
-- Is_Task_Interface (synthesized)
@@ -3308,7 +3278,7 @@ package Einfo is
-- Is_Task_Type (synthesized)
-- Applies to all entities. True for task types and subtypes
--- Is_Thunk (Flag225)
+-- Is_Thunk
-- Defined in all entities. True for subprograms that are thunks: that is
-- small subprograms built by the expander for tagged types that cover
-- interface types. As part of the runtime call to an interface, thunks
@@ -3321,13 +3291,13 @@ package Einfo is
-- by Expand_Interface_Thunk and used by Expand_Call to handle extra
-- actuals associated with accessibility level.
--- Is_Trivial_Subprogram (Flag235)
+-- Is_Trivial_Subprogram
-- Defined in all entities. Set in subprograms where either the body
-- consists of a single null statement, or the first or only statement
-- of the body raises an exception. This is used for suppressing certain
-- warnings, see Sem_Ch6.Analyze_Subprogram_Body discussion for details.
--- Is_True_Constant (Flag163)
+-- Is_True_Constant
-- Defined in all entities for constants and variables. Set in constants
-- and variables which have an initial value specified but which are
-- never assigned, partially or in the whole. For variables, it means
@@ -3340,27 +3310,27 @@ package Einfo is
-- Is_Type (synthesized)
-- Applies to all entities, true for a type entity
--- Is_Unchecked_Union (Flag117) [implementation base type only]
+-- Is_Unchecked_Union [implementation base type only]
-- Defined in all entities. Set only in record types to which the
-- pragma Unchecked_Union has been validly applied.
--- Is_Underlying_Full_View (Flag298)
+-- Is_Underlying_Full_View
-- Defined in all entities. Set for types which represent the true full
-- view of a private type completed by another private type. For further
-- details, see attribute Underlying_Full_View.
--- Is_Underlying_Record_View (Flag246) [base type only]
+-- Is_Underlying_Record_View [base type only]
-- Defined in all entities. Set only in record types that represent the
-- underlying record view. This view is built for derivations of types
-- with unknown discriminants; it is a record with the same structure
-- as its corresponding record type, but whose parent is the full view
-- of the parent in the original type extension.
--- Is_Unimplemented (Flag284)
+-- Is_Unimplemented
-- Defined in all entities. Set for any entity to which a valid pragma
-- or aspect Unimplemented applies.
--- Is_Unsigned_Type (Flag144)
+-- Is_Unsigned_Type
-- Defined in all types, but can be set only for discrete and fixed-point
-- type and subtype entities. This flag is only valid if the entity is
-- frozen. If set it indicates that the representation is known to be
@@ -3376,7 +3346,7 @@ package Einfo is
-- cannot be used to determine the comparison operator to emit in the
-- generated code: use the base type.
--- Is_Uplevel_Referenced_Entity (Flag283)
+-- Is_Uplevel_Referenced_Entity
-- Defined in all entities. Used when unnesting subprograms to indicate
-- that an entity is locally defined within a subprogram P, and there is
-- a reference to the entity within a subprogram nested within P (at any
@@ -3387,23 +3357,23 @@ package Einfo is
-- array. This is used internally in Exp_Unst, see this package for
-- further details.
--- Is_Valued_Procedure (Flag127)
+-- Is_Valued_Procedure
-- Defined in procedure entities. Set if an Import_Valued_Procedure
-- or Export_Valued_Procedure pragma applies to the procedure entity.
--- Is_Visible_Formal (Flag206)
+-- Is_Visible_Formal
-- Defined in all entities. Set for instances of the formals of a
-- formal package. Indicates that the entity must be made visible in the
-- body of the instance, to reproduce the visibility of the generic.
-- This simplifies visibility settings in instance bodies.
--- Is_Visible_Lib_Unit (Flag116)
+-- Is_Visible_Lib_Unit
-- Defined in all (root or child) library unit entities. Once compiled,
-- library units remain chained to the entities in the parent scope, and
-- a separate flag must be used to indicate whether the names are visible
-- by selected notation, or not.
--- Is_Volatile (Flag16)
+-- Is_Volatile
-- Defined in all type entities, and also in constants, components and
-- variables. Set if a pragma Volatile applies to the entity. Also set
-- if pragma Shared or pragma Atomic applies to entity. In the case of
@@ -3416,10 +3386,14 @@ package Einfo is
-- Similarly, any front end test which is concerned with suppressing
-- optimizations on volatile objects should test Treat_As_Volatile
-- rather than testing this flag.
+-- This is a synthesized attribute in Einfo.Utils, based on
+-- Is_Volatile_Type and Is_Volatile_Object. The latter two should be
+-- used in preference to Is_Volatile when we know that we have a type
+-- or an object.
--- Is_Volatile_Full_Access (Flag285)
+-- Is_Volatile_Full_Access
-- Defined in all type entities, and also in constants, components, and
--- variables. Set if an aspect/pragma Volatile_Full_Access or an Ada 2020
+-- variables. Set if an aspect/pragma Volatile_Full_Access or an Ada 2022
-- aspect Full_Access_Only applies to the entity. In the case of private
-- and incomplete types, this flag is set in both the partial view and
-- the full view.
@@ -3428,26 +3402,31 @@ package Einfo is
-- Defined in package entities. Indicates that the package has been
-- created as a wrapper for a subprogram instantiation.
--- Itype_Printed (Flag202)
+-- Is_Wrapper
+-- Defined in subprogram entities. Indicates that it has been created as
+-- a wrapper to handle inherited class-wide pre/post conditions that call
+-- overridden primitives or as a wrapper of a controlling function.
+
+-- Itype_Printed
-- Defined in all type and subtype entities. Set in Itypes if the Itype
-- has been printed by Sprint. This is used to avoid printing an Itype
-- more than once.
--- Kill_Elaboration_Checks (Flag32)
+-- Kill_Elaboration_Checks
-- Defined in all entities. Set by the expander to kill elaboration
-- checks which are known not to be needed. Equivalent in effect to
-- the use of pragma Suppress (Elaboration_Checks) for that entity
-- except that the effect is permanent and cannot be undone by a
-- subsequent pragma Unsuppress.
--- Kill_Range_Checks (Flag33)
+-- Kill_Range_Checks
-- Defined in all entities. Equivalent in effect to the use of pragma
-- Suppress (Range_Checks) for that entity except that the result is
-- permanent and cannot be undone by a subsequent pragma Unsuppress.
-- This is currently only used in one odd situation in Sem_Ch3 for
-- record types, and it would be good to get rid of it???
--- Known_To_Have_Preelab_Init (Flag207)
+-- Known_To_Have_Preelab_Init
-- Defined in all type and subtype entities. If set, then the type is
-- known to have preelaborable initialization. In the case of a partial
-- view of a private type, it is only possible for this to be set if a
@@ -3456,20 +3435,20 @@ package Einfo is
-- initialization, it may or may not be set if the type does have
-- preelaborable initialization.
--- Last_Aggregate_Assignment (Node30)
+-- Last_Aggregate_Assignment
-- Applies to controlled constants and variables initialized by an
-- aggregate. Points to the last statement associated with the expansion
-- of the aggregate. The attribute is used by the finalization machinery
-- when marking an object as successfully initialized.
--- Last_Assignment (Node26)
+-- Last_Assignment
-- Defined in entities for variables, and OUT or IN OUT formals. Set for
-- a local variable or formal to point to the left side of an assignment
-- statement assigning a value to the variable. Cleared if the value of
-- the entity is referenced. Used to warn about dubious assignment
-- statements whose value is not used.
--- Last_Entity (Node20)
+-- Last_Entity
-- Defined in all entities which act as scopes to which a list of
-- associated entities is attached (blocks, class subtypes and types,
-- entries, functions, loops, packages, procedures, protected objects,
@@ -3484,35 +3463,42 @@ package Einfo is
-- a subprogram type (the designated type of an Access_To_Subprogram
-- definition) or in an entry.
--- Limited_View (Node23)
+-- Limited_View
-- Defined in non-generic package entities that are not instances. Bona
-- fide package with the limited-view list through the first_entity and
-- first_private attributes. The elements of this list are the shadow
-- entities created for the types and local packages that are declared
-- in a package appearing in a limited_with clause (Ada 2005: AI-50217).
--- Linker_Section_Pragma (Node33)
+-- Linker_Section_Pragma
-- Present in constant, variable, type and subprogram entities. Points
-- to a linker section pragma that applies to the entity, or is Empty if
-- no such pragma applies. Note that for constants and variables, this
-- field may be set as a result of a linker section pragma applied to the
-- type of the object.
--- Lit_Indexes (Node18)
+-- Lit_Hash
+-- Defined in enumeration types and subtypes. Non-empty only for the
+-- case of an enumeration root type, where it contains the entity for
+-- the generated hash function. See unit Exp_Imgv for full details of
+-- the nature and use of this entity for implementing the Value
+-- attribute for the enumeration type in question.
+
+-- Lit_Indexes
-- Defined in enumeration types and subtypes. Non-empty only for the
-- case of an enumeration root type, where it contains the entity for
-- the generated indexes entity. See unit Exp_Imgv for full details of
-- the nature and use of this entity for implementing the Image and
-- Value attributes for the enumeration type in question.
--- Lit_Strings (Node16)
+-- Lit_Strings
-- Defined in enumeration types and subtypes. Non-empty only for the
-- case of an enumeration root type, where it contains the entity for
-- the literals string entity. See unit Exp_Imgv for full details of
-- the nature and use of this entity for implementing the Image and
-- Value attributes for the enumeration type in question.
--- Low_Bound_Tested (Flag205)
+-- Low_Bound_Tested
-- Defined in all entities. Currently this can only be set for formal
-- parameter entries of a standard unconstrained one-dimensional array
-- or string type. Indicates that an explicit test of the low bound of
@@ -3520,14 +3506,14 @@ package Einfo is
-- flag is set, warnings about assuming the index low bound to be one
-- are suppressed.
--- Machine_Radix_10 (Flag84)
+-- Machine_Radix_10
-- Defined in decimal types and subtypes, set if the Machine_Radix is 10,
-- as the result of the specification of a machine radix representation
-- clause. Note that it is possible for this flag to be set without
-- having Has_Machine_Radix_Clause True. This happens when a type is
-- derived from a type with a clause present.
--- Master_Id (Node17)
+-- Master_Id
-- Defined in access types and subtypes. Empty unless Has_Task is set for
-- the designated type, in which case it points to the entity for the
-- Master_Id for the access type master. Also set for access-to-limited-
@@ -3535,13 +3521,13 @@ package Einfo is
-- for access-to-limited-interfaces because they can be used to reference
-- tasks implementing such interface.
--- Materialize_Entity (Flag168)
+-- Materialize_Entity
-- Defined in all entities. Set only for renamed obects which should be
-- materialized for debugging purposes. This means that a memory location
-- containing the renamed address should be allocated. This is needed so
-- that the debugger can find the entity.
--- May_Inherit_Delayed_Rep_Aspects (Flag262)
+-- May_Inherit_Delayed_Rep_Aspects
-- Defined in all entities for types and subtypes. Set if the type is
-- derived from a type which has delayed rep aspects (marked by the flag
-- Has_Delayed_Rep_Aspects being set). In this case, at the freeze point
@@ -3549,14 +3535,14 @@ package Einfo is
-- a given attribute has not been set for the derived type, we copy the
-- value from the parent type. See Freeze.Inherit_Delayed_Rep_Aspects.
--- Mechanism (Uint8) (returned as Mechanism_Type)
+-- Mechanism (returned as Mechanism_Type)
-- Defined in functions and non-generic formal parameters. Indicates
-- the mechanism to be used for the function return or for the formal
-- parameter. See full description in the spec of Sem_Mech. This field
-- is also set (to the default value of zero = Default_Mechanism) in a
-- subprogram body entity but not used in this context.
--- Minimum_Accessibility (Node24)
+-- Minimum_Accessibility
-- Defined in formal parameters in the non-generic case. Normally Empty,
-- but if expansion is active, and a parameter exists for which a
-- dynamic accessibility check is required, then an object is generated
@@ -3564,12 +3550,12 @@ package Einfo is
-- subprogram or the formal's Extra_Accessibility - whichever one is
-- lesser. The Minimum_Accessibility field then points to this object.
--- Modulus (Uint17) [base type only]
+-- Modulus [base type only]
-- Defined in modular types. Contains the modulus. For the binary case,
-- this will be a power of 2, but if Non_Binary_Modulus is set, then it
-- will not be a power of 2.
--- Must_Be_On_Byte_Boundary (Flag183)
+-- Must_Be_On_Byte_Boundary
-- Defined in entities for types and subtypes. Set if objects of the type
-- must always be allocated on a byte boundary (more accurately a storage
-- unit boundary). The front end checks that component clauses respect
@@ -3577,19 +3563,19 @@ package Einfo is
-- violate this rule. Currently the flag is set only for packed arrays
-- longer than 64 bits where the component size is not a power of 2.
--- Must_Have_Preelab_Init (Flag208)
+-- Must_Have_Preelab_Init
-- Defined in entities for types and subtypes. Set in the full type of a
-- private type or subtype if a pragma Has_Preelaborable_Initialization
-- is present for the private type. Used to check that the full type has
-- preelaborable initialization at freeze time (this has to be deferred
-- to the freeze point because of the rule about overriding Initialize).
--- Needs_Activation_Record (Flag306)
+-- Needs_Activation_Record
-- Defined on generated subprogram types. Indicates that a call through
-- a named or anonymous access to subprogram requires an activation
-- record when compiling with unnesting for C or LLVM.
--- Needs_Debug_Info (Flag147)
+-- Needs_Debug_Info
-- Defined in all entities. Set if the entity requires normal debugging
-- information to be generated. This is true of all entities that have
-- Comes_From_Source set, and also transitively for entities associated
@@ -3600,7 +3586,7 @@ package Einfo is
-- use Sem_Util.Set_Debug_Info_Needed, rather than Set_Needs_Debug_Info,
-- so that the flag is set properly on subsidiary entities.
--- Needs_No_Actuals (Flag22)
+-- Needs_No_Actuals
-- Defined in callable entities (subprograms, entries, access to
-- subprograms) which can be called without actuals because all of
-- their formals (if any) have default values. This flag simplifies the
@@ -3609,7 +3595,7 @@ package Einfo is
-- interpreted as an indexing of the result of the call. It is also
-- used to resolve various cases of entry calls.
--- Never_Set_In_Source (Flag115)
+-- Never_Set_In_Source
-- Defined in all entities, but can be set only for variables and
-- parameters. This flag is set if the object is never assigned a value
-- in user source code, either by assignment or by being used as an out
@@ -3672,7 +3658,7 @@ package Einfo is
-- might be the only components of the record. Returns Empty if there
-- are no more discriminants.
--- Next_Entity (Node2)
+-- Next_Entity
-- Defined in all entities. The entities of a scope are chained, with
-- the head of the list being in the First_Entity field of the scope
-- entity. All entities use the Next_Entity field as a forward pointer
@@ -3700,7 +3686,7 @@ package Einfo is
-- unlike most attributes in this package, Next_Index applies to
-- nodes for the indexes, not to entities.
--- Next_Inlined_Subprogram (Node12)
+-- Next_Inlined_Subprogram
-- Defined in subprograms. Used to chain inlined subprograms used in
-- the current compilation, in the order in which they must be compiled
-- by the backend to ensure that all inlinings are performed.
@@ -3710,32 +3696,32 @@ package Einfo is
-- Empty if applied to the last literal. This is actually a synonym
-- for Next, but its use is preferred in this context.
--- No_Dynamic_Predicate_On_Actual (Flag276)
+-- No_Dynamic_Predicate_On_Actual
-- Defined in discrete types. Set for generic formal types that are used
-- in loops and quantified expressions. The corresponing actual cannot
-- have dynamic predicates.
--- No_Pool_Assigned (Flag131) [root type only]
+-- No_Pool_Assigned [root type only]
-- Defined in access types. Set if a storage size clause applies to the
-- variable with a static expression value of zero. This flag is used to
-- generate errors if any attempt is made to allocate or free an instance
-- of such an access type. This is set only in the root type, since
-- derived types must have the same pool.
--- No_Predicate_On_Actual (Flag275)
+-- No_Predicate_On_Actual
-- Defined in discrete types. Set for generic formal types that are used
-- in the spec of a generic package, in constructs that forbid discrete
-- types with predicates.
--- No_Reordering (Flag239) [implementation base type only]
+-- No_Reordering [implementation base type only]
-- Defined in record types. Set only for a base type to which a valid
-- pragma No_Component_Reordering applies.
--- No_Return (Flag113)
+-- No_Return
-- 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]
+-- No_Strict_Aliasing [base type only]
-- Defined in access types. Set to direct the backend to avoid any
-- optimizations based on an assumption about the aliasing status of
-- objects designated by the access type. For the case of the gcc
@@ -3745,38 +3731,38 @@ package Einfo is
-- type occurs in the same source unit as the declaration of the
-- access type, or if an explicit pragma No_Strict_Aliasing applies.
--- No_Tagged_Streams_Pragma (Node32)
+-- No_Tagged_Streams_Pragma
-- Present in all subtype and type entities. Set for tagged types and
-- subtypes (i.e. entities with Is_Tagged_Type set True) if a valid
-- pragma/aspect applies to the type.
--- Non_Binary_Modulus (Flag58) [base type only]
+-- Non_Binary_Modulus [base type only]
-- Defined in all subtype and type entities. Set for modular integer
-- types if the modulus value is other than a power of 2.
--- Non_Limited_View (Node19)
+-- Non_Limited_View
-- Defined in abstract states and incomplete types that act as shadow
-- entities created when analysing a limited with clause (Ada 2005:
-- AI-50217). Points to the defining entity of the original declaration.
--- Nonzero_Is_True (Flag162) [base type only]
+-- Nonzero_Is_True [base type only]
-- Defined in enumeration types. Set if any non-zero value is to be
-- interpreted as true. Currently this is set for derived Boolean
-- types which have a convention of C, C++ or Fortran.
--- Normalized_First_Bit (Uint8)
+-- Normalized_First_Bit
-- Defined in components and discriminants. Indicates the normalized
-- value of First_Bit for the component, i.e. the offset within the
-- lowest addressed storage unit containing part or all of the field.
-- Set to No_Uint if no first bit position is assigned yet.
--- Normalized_Position (Uint14)
+-- Normalized_Position
-- Defined in components and discriminants. Indicates the normalized
-- value of Position for the component, i.e. the offset in storage
-- units from the start of the record to the lowest addressed storage
-- unit containing part or all of the field.
--- Normalized_Position_Max (Uint10)
+-- Normalized_Position_Max
-- Defined in components and discriminants. For almost all cases, this
-- is the same as Normalized_Position. The one exception is for the case
-- of a discriminated record containing one or more arrays whose length
@@ -3808,7 +3794,7 @@ package Einfo is
-- representation item chain is copied for a derived type, it can inherit
-- an object size clause that is not applicable to the entity.
--- OK_To_Rename (Flag247)
+-- OK_To_Rename
-- Defined only in entities for variables. If this flag is set, it
-- means that if the entity is used as the initial value of an object
-- declaration, the object declaration can be safely converted into a
@@ -3819,7 +3805,7 @@ package Einfo is
-- is only worth setting this flag for composites, since for primitive
-- types, it is cheaper to do the copy.
--- Optimize_Alignment_Space (Flag241)
+-- Optimize_Alignment_Space
-- Defined in type, subtype, variable, and constant entities. This
-- flag records that the type or object is to be laid out in a manner
-- consistent with Optimize_Alignment (Space) mode. The compiler and
@@ -3827,7 +3813,7 @@ package Einfo is
-- Optimize_Alignment (Off) mode applies to the type/object, then neither
-- of the flags Optimize_Alignment_Space/Optimize_Alignment_Time is set.
--- Optimize_Alignment_Time (Flag242)
+-- Optimize_Alignment_Time
-- Defined in type, subtype, variable, and constant entities. This
-- flag records that the type or object is to be laid out in a manner
-- consistent with Optimize_Alignment (Time) mode. The compiler and
@@ -3835,25 +3821,25 @@ package Einfo is
-- Optimize_Alignment (Off) mode applies to the type/object, then neither
-- of the flags Optimize_Alignment_Space/Optimize_Alignment_Time is set.
--- Original_Access_Type (Node28)
+-- Original_Access_Type
-- Defined in E_Access_Subprogram_Type entities. Set only if the access
-- type was generated by the expander as part of processing an access-
-- to-protected-subprogram type. Points to the access-to-protected-
-- subprogram type.
--- Original_Array_Type (Node21)
+-- Original_Array_Type
-- Defined in modular types and array types and subtypes. Set only if
-- the Is_Packed_Array_Impl_Type flag is set, indicating that the type
-- is the implementation type for a packed array, and in this case it
-- points to the original array type for which this is the packed
-- array implementation type.
--- Original_Protected_Subprogram (Node41)
+-- Original_Protected_Subprogram
-- Defined in functions and procedures. Set only on internally built
-- dispatching subprograms of protected types to reference their original
-- non-dispatching protected subprogram since their names differ.
--- Original_Record_Component (Node22)
+-- Original_Record_Component
-- Defined in components, including discriminants. The usage depends
-- on whether the record is a base type and whether it is tagged.
--
@@ -3873,12 +3859,12 @@ package Einfo is
-- In subtypes (tagged and untagged):
-- Points to the component in the base type.
--- Overlays_Constant (Flag243)
+-- Overlays_Constant
-- Defined in all entities. Set only for E_Constant or E_Variable for
-- which there is an address clause that causes the entity to overlay
-- a constant object.
--- Overridden_Operation (Node26)
+-- Overridden_Operation
-- Defined in subprograms. For overriding operations, points to the
-- user-defined parent subprogram that is being overridden. Note: this
-- attribute uses the same field as Static_Initialization. The latter
@@ -3886,7 +3872,7 @@ package Einfo is
-- Overridden_Operation is irrelevant. Thus this attribute must not be
-- set for init_procs.
--- Package_Instantiation (Node26)
+-- Package_Instantiation
-- Defined in packages and generic packages. When defined, this field
-- references an N_Generic_Instantiation node associated with an
-- instantiated package. In the case where the referenced node has
@@ -3898,7 +3884,7 @@ package Einfo is
-- it should be set in all cases, including package entities associated
-- with formal packages. ???
--- Packed_Array_Impl_Type (Node23)
+-- Packed_Array_Impl_Type
-- Defined in array types and subtypes, except for the string literal
-- subtype case, if the corresponding type is packed and implemented
-- specially (either bit-packed or packed to eliminate holes in the
@@ -3916,17 +3902,17 @@ package Einfo is
-- used when obtaining the formal kind of a formal parameter (the result
-- is one of E_[In/Out/In_Out]_Parameter).
--- Parent_Subtype (Node19) [base type only]
+-- Parent_Subtype [base type only]
-- Defined in E_Record_Type. Set only for derived tagged types, in which
-- case it points to the subtype of the parent type. This is the type
-- that is used as the Etype of the _parent field.
--- Part_Of_Constituents (Elist10)
+-- Part_Of_Constituents
-- Present in abstract state and variable entities. Contains all
-- constituents that are subject to indicator Part_Of (both aspect and
-- option variants).
--- Part_Of_References (Elist11)
+-- Part_Of_References
-- Present in variable entities. Contains all references to the variable
-- when it is subject to pragma Part_Of. If the variable is a constituent
-- of a single protected/task type, the references are examined as they
@@ -3965,12 +3951,12 @@ package Einfo is
-- abstract states with no or only partial refinement visible, and those
-- that are not themselves abstract states.
--- Partial_View_Has_Unknown_Discr (Flag280)
+-- Partial_View_Has_Unknown_Discr
-- Present in all types. Set to Indicate that the partial view of a type
-- has unknown discriminants. A default initialization of an object of
-- the type does not require an invariant check (AI12-0133).
--- Pending_Access_Types (Elist15)
+-- Pending_Access_Types
-- Defined in all types. Set for incomplete, private, Taft-amendment
-- types, and their corresponding full views. This list contains all
-- access types, both named and anonymous, declared between the partial
@@ -3978,7 +3964,7 @@ package Einfo is
-- ensure that the finalization masters of all pending access types are
-- fully initialized when the full view is frozen.
--- Postconditions_Proc (Node14)
+-- Postconditions_Proc
-- Defined in functions, procedures, entries, and entry families. Refers
-- to the entity of the _Postconditions procedure used to check contract
-- assertions on exit from a subprogram.
@@ -4007,7 +3993,7 @@ package Einfo is
-- is the special version created for membership tests, where if one of
-- these raise expressions is executed, the result is to return False.
--- Predicated_Parent (Node38)
+-- Predicated_Parent
-- Defined on itypes created by subtype indications, when the parent
-- subtype has predicates. The itype shares the Predicate_Function
-- of the predicated parent, but this function may not have been built
@@ -4015,12 +4001,12 @@ package Einfo is
-- retrieval at the point a predicate check needs to be generated.
-- The utility Predicate_Function takes this link into account.
--- Predicates_Ignored (Flag288)
+-- Predicates_Ignored
-- Defined on all types. Indicates whether the subtype 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.
--- Prev_Entity (Node36)
+-- Prev_Entity
-- Defined in all entities. The entities of a scope are chained, and this
-- field is used as a backward pointer for this entity list - effectivly
-- making the entity chain doubly-linked.
@@ -4032,16 +4018,16 @@ package Einfo is
-- Direct_Primitive_Operations of its CRT; otherwise returns No_Elist.
-- For all the other types returns the Direct_Primitive_Operations.
--- Prival (Node17)
+-- Prival
-- Defined in private components of protected types. Refers to the entity
-- of the component renaming declaration generated inside protected
-- subprograms, entries or barrier functions.
--- Prival_Link (Node20)
+-- Prival_Link
-- Defined in constants and variables which rename private components of
-- protected types. Set to the original private component.
--- Private_Dependents (Elist18)
+-- Private_Dependents
-- Defined in private (sub)types. Records the subtypes of the private
-- type, derivations from it, and records and arrays with components
-- dependent on the type.
@@ -4061,62 +4047,62 @@ package Einfo is
-- declaration of the type is seen. Subprograms that have such an
-- access parameter are also placed in the list of private_dependents.
--- Protected_Body_Subprogram (Node11)
+-- Protected_Body_Subprogram
-- Defined in protected operations. References the entity for the
-- subprogram which implements the body of the operation.
--- Protected_Formal (Node22)
+-- Protected_Formal
-- Defined in formal parameters (in, in out and out parameters). Used
-- only for formals of protected operations. References corresponding
-- formal parameter in the unprotected version of the operation that
-- is created during expansion.
--- Protected_Subprogram (Node39)
+-- Protected_Subprogram
-- Defined in functions and procedures. Set for the pair of subprograms
-- which emulate the runtime semantics of a protected subprogram. Denotes
-- the entity of the origial protected subprogram.
--- Protection_Object (Node23)
+-- Protection_Object
-- Applies to protected entries, entry families and subprograms. Denotes
-- the entity which is used to rename the _object component of protected
-- types.
--- Reachable (Flag49)
+-- Reachable
-- Defined in labels. The flag is set over the range of statements in
-- which a goto to that label is legal.
--- Receiving_Entry (Node19)
+-- Receiving_Entry
-- Defined in procedures. Set for an internally generated procedure which
-- wraps the original statements of an accept alternative. Designates the
-- entity of the task entry being accepted.
--- Referenced (Flag156)
+-- Referenced
-- Defined in all entities. Set if the entity is referenced, except for
-- the case of an appearance of a simple variable that is not a renaming
-- as the left side of an assignment in which case Referenced_As_LHS is
-- set instead, or a similar appearance as an out parameter actual, in
-- which case Referenced_As_Out_Parameter is set.
--- Referenced_As_LHS (Flag36):
+-- Referenced_As_LHS :
-- Defined in all entities. This flag is set instead of Referenced if a
-- simple variable that is not a renaming appears as the left side of an
-- assignment. The reason we distinguish this kind of reference is that
-- we have a separate warning for variables that are only assigned and
-- never read.
--- Referenced_As_Out_Parameter (Flag227):
+-- Referenced_As_Out_Parameter :
-- Defined in all entities. This flag is set instead of Referenced if a
-- simple variable that is not a renaming appears as an actual for an out
-- formal. The reason we distinguish this kind of reference is that
-- we have a separate warning for variables that are only assigned and
-- never read, and out parameters are a special case.
--- Refinement_Constituents (Elist8)
+-- Refinement_Constituents
-- Present in abstract state entities. Contains all the constituents that
-- refine the state, in other words, all the hidden states that appear in
-- the constituent_list of aspect/pragma Refined_State.
--- Register_Exception_Call (Node20)
+-- Register_Exception_Call
-- Defined in exception entities. When an exception is declared,
-- a call is expanded to Register_Exception. This field points to
-- the expanded N_Procedure_Call_Statement node for this call. It
@@ -4124,13 +4110,13 @@ package Einfo is
-- register call to make appropriate entries in the special tables
-- used for handling these pragmas at run time.
--- Related_Array_Object (Node25)
+-- Related_Array_Object
-- Defined in array types and subtypes. Used only for the base type
-- and subtype created for an anonymous array object. Set to point
-- to the entity of the corresponding array object. Currently used
-- only for type-related error messages.
--- Related_Expression (Node24)
+-- Related_Expression
-- Defined in variables, types and functions. When Set for internally
-- generated entities, it may be used to denote the source expression
-- whose elaboration created the variable declaration. If set, it is used
@@ -4145,37 +4131,37 @@ package Einfo is
-- Shouldn't it also be used for the same purpose in errout? It seems
-- odd to have two mechanisms here???
--- Related_Instance (Node15)
+-- Related_Instance
-- Defined in the wrapper packages created for subprogram instances.
-- The internal subprogram that implements the instance is inside the
-- wrapper package, but for debugging purposes its external symbol
-- must correspond to the name and scope of the related instance.
--- Related_Type (Node27)
+-- Related_Type
-- Defined in components, constants and variables. Set when there is an
-- associated dispatch table to point to entities containing primary or
-- secondary tags. Not set in the _tag component of record types.
--- Relative_Deadline_Variable (Node28) [implementation base type only]
+-- Relative_Deadline_Variable [implementation base type only]
-- Defined in task type entities. This flag is set if a valid and
-- effective pragma Relative_Deadline applies to the base type. Points
-- to the entity for a variable that is created to hold the value given
-- in a Relative_Deadline pragma for a task type.
--- Renamed_Entity (Node18)
+-- Renamed_Entity
-- Defined in exception, generic unit, package, and subprogram entities.
-- Set when the entity is defined by a renaming declaration. Denotes the
-- renamed entity, or transitively the ultimate renamed entity if there
-- is a chain of renaming declarations. Empty if no renaming.
--- Renamed_In_Spec (Flag231)
+-- Renamed_In_Spec
-- Defined in package entities. If a package renaming occurs within
-- a package spec, then this flag is set on the renamed package. The
-- purpose is to prevent a warning about unused entities in the renamed
-- package. Such a warning would be inappropriate since clients of the
-- package can see the entities in the package via the renaming.
--- Renamed_Object (Node18)
+-- Renamed_Object
-- Defined in components, constants, discriminants, formal parameters,
-- generic formals, loop parameters, and variables. Set to non-Empty if
-- the object was declared by a renaming declaration. For constants and
@@ -4187,22 +4173,13 @@ package Einfo is
-- within an accept statement. For all remaining cases (discriminants,
-- loop parameters) the field is Empty.
--- Renaming_Map (Uint9)
--- Defined in generic subprograms, generic packages, and their
--- instances. Also defined in the instances of the corresponding
--- bodies. Denotes the renaming map (generic entities => instance
--- entities) used to construct the instance by giving an index into
--- the tables used to represent these maps. See Sem_Ch12 for further
--- details. The maps for package instances are also used when the
--- instance is the actual corresponding to a formal package.
-
--- Requires_Overriding (Flag213)
+-- Requires_Overriding
-- Defined in all subprograms and entries. Set for subprograms that
-- require overriding as defined by RM-2005-3.9.3(6/2). Note that this
-- is True only for implicitly declared subprograms; it is not set on the
-- parent type's subprogram. See also Is_Abstract_Subprogram.
--- Return_Applies_To (Node8)
+-- Return_Applies_To
-- Defined in E_Return_Statement. Points to the entity representing
-- the construct to which the return statement applies, as defined in
-- RM-6.5(4/2). Note that a (simple) return statement within an
@@ -4213,20 +4190,25 @@ package Einfo is
-- by Expand_N_Extended_Return_Statement before being turned into an
-- E_Block by semantic analysis.
--- Return_Present (Flag54)
+-- Return_Present
-- Defined in function and generic function entities. Set if the
-- function contains a return statement (used for error checking).
-- This flag can also be set in procedure and generic procedure
-- entities (for convenience in setting it), but is only tested
-- for the function case.
--- Returns_By_Ref (Flag90)
+-- Return_Statement
+-- Defined in E_Variable. Set when Is_Return_Object is set, in which
+-- case it points to the N_Simple_Return_Statement made from the
+-- extended return statement.
+
+-- Returns_By_Ref
-- 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]
+-- Reverse_Bit_Order [base type only]
-- Defined in all record type entities. Set if entity has a Bit_Order
-- aspect (set by an aspect clause or attribute definition clause) that
-- has reversed the order of bits from the default value. When this flag
@@ -4234,7 +4216,7 @@ package Einfo is
-- a single storage unit (Ada 95) or within a single machine scalar (see
-- Ada 2005 AI-133), or must occupy an integral number of storage units.
--- Reverse_Storage_Order (Flag93) [base type only]
+-- Reverse_Storage_Order [base type only]
-- Defined in all record and array type entities. Set if entity has a
-- Scalar_Storage_Order aspect (set by an aspect clause or attribute
-- definition clause) that has reversed the order of storage elements
@@ -4242,13 +4224,13 @@ package Einfo is
-- the Bit_Order aspect must be set to the same value (either explicitly
-- or as the target default value).
--- Rewritten_For_C (Flag287)
+-- Rewritten_For_C
-- Defined on functions that return a constrained array type, when
-- Modify_Tree_For_C is set. Indicates that a procedure with an extra
-- out parameter has been created for it, and calls must be rewritten as
-- calls to the new procedure.
--- RM_Size (Uint13)
+-- RM_Size
-- Defined in all type and subtype entities. Contains the value of
-- type'Size as defined in the RM. See also the Esize field and
-- and the description on "Handling of Type'Size Values". A value
@@ -4267,7 +4249,7 @@ package Einfo is
-- does not correspond exactly to the use of root type in the RM, since
-- in the RM root type applies to a class of types, not to a type.
--- Scalar_Range (Node20)
+-- Scalar_Range
-- Defined in all scalar types (including modular types, where the
-- bounds are 0 .. modulus - 1). References a node in the tree that
-- contains the bounds for the range. Note that this information
@@ -4278,13 +4260,13 @@ package Einfo is
-- but not a simple subtype reference (a subtype is converted into a
-- explicit range).
--- Scale_Value (Uint16)
+-- Scale_Value
-- Defined in decimal fixed-point types and subtypes. This holds the
-- value of the Scale attribute for the type, i.e. the scale of the type
-- defined as the integer N such that the delta is equal to 10.0**(-N).
-- Note that, if Scale_Value is positive, then it is equal to Aft_Value.
--- Scope (Node3)
+-- Scope
-- Defined in all entities. Points to the entity for the scope (block,
-- loop, subprogram, package etc.) in which the entity is declared.
-- Since this field is in the base part of the entity node, the access
@@ -4300,7 +4282,7 @@ package Einfo is
-- simply the scope depth value, for record entities, it is the
-- Scope_Depth of the record scope.
--- Scope_Depth_Value (Uint22)
+-- Scope_Depth_Value
-- Defined in program units, blocks, loops, return statements,
-- concurrent types, private types and entries.
-- Indicates the number of scopes that statically enclose the declaration
@@ -4313,38 +4295,37 @@ package Einfo is
-- indicating whether or not the Scope_Depth field has been set. It is
-- needed, since returns an invalid value in this case.
--- Sec_Stack_Needed_For_Return (Flag167)
+-- Sec_Stack_Needed_For_Return
-- Defined in scope entities (blocks, entries, entry families, functions,
-- and procedures). Set to True when secondary stack is used to hold the
-- returned value of a function and thus should not be released on scope
-- exit.
--- Shared_Var_Procs_Instance (Node22)
+-- Shared_Var_Procs_Instance
-- Defined in variables. Set non-Empty only if Is_Shared_Passive is
-- set, in which case this is the entity for the associated instance of
-- System.Shared_Storage.Shared_Var_Procs. See Exp_Smem for full details.
--- Size_Check_Code (Node19)
+-- Size_Check_Code
-- Defined in constants and variables. Normally Empty. Set if code is
-- generated to check the size of the object. This field is used to
-- suppress this code if a subsequent address clause is encountered.
-- Size_Clause (synthesized)
--- Applies to all entities. If a size clause is present in the rep
--- item chain for an entity then the attribute definition clause node
--- for the size clause is returned. Otherwise Size_Clause returns Empty
--- if no item is present. Usually this is only meaningful if the flag
--- Has_Size_Clause is set. This is because when the representation item
--- chain is copied for a derived type, it can inherit a size clause that
--- is not applicable to the entity.
-
--- Size_Depends_On_Discriminant (Flag177)
+-- Applies to all entities. If a size or value size clause is present in
+-- the rep item chain for an entity then that attribute definition clause
+-- is returned. Otherwise Size_Clause returns Empty. Usually this is only
+-- meaningful if the flag Has_Size_Clause is set. This is because when
+-- the representation item chain is copied for a derived type, it can
+-- inherit a size clause that is not applicable to the entity.
+
+-- Size_Depends_On_Discriminant
-- Defined in all entities for types and subtypes. Indicates that the
-- size of the type depends on the value of one or more discriminants.
-- Currently, this flag is only set for arrays which have one or more
-- bounds depending on a discriminant value.
--- Size_Known_At_Compile_Time (Flag92)
+-- Size_Known_At_Compile_Time
-- Defined in all entities for types and subtypes. Indicates that the
-- size of objects of the type is known at compile time. This flag is
-- used to optimize some generated code sequences, and also to enable
@@ -4356,12 +4337,12 @@ package Einfo is
-- to the back end, so the fact that this flag is set does not mean that
-- the front end can access the value.
--- Small_Value (Ureal21)
+-- Small_Value
-- Defined in fixed point types. Points to the universal real for the
-- Small of the type, either as given in a representation clause, or
-- as computed (as a power of two) by the compiler.
--- SPARK_Aux_Pragma (Node41)
+-- SPARK_Aux_Pragma
-- Present in concurrent type, [generic] package spec and package body
-- entities. For concurrent types and package specs it refers to the
-- SPARK mode setting for the private part. This field points to the
@@ -4372,12 +4353,12 @@ package Einfo is
-- inherited from the enclosing context. In all cases, if the pragma is
-- inherited, then the SPARK_Aux_Pragma_Inherited flag is set.
--- SPARK_Aux_Pragma_Inherited (Flag266)
+-- SPARK_Aux_Pragma_Inherited
-- Present in concurrent type, [generic] package spec and package body
-- entities. Set if the SPARK_Aux_Pragma field points to a pragma that is
-- inherited, rather than a local one.
--- SPARK_Pragma (Node40)
+-- SPARK_Pragma
-- Present in the following entities:
--
-- abstract states
@@ -4398,7 +4379,7 @@ package Einfo is
-- flag SPARK_Pragma_Inherited is set. Empty if no SPARK_Mode pragma is
-- applicable.
--- SPARK_Pragma_Inherited (Flag265)
+-- SPARK_Pragma_Inherited
-- Present in the following entities:
--
-- abstract states
@@ -4415,23 +4396,23 @@ package Einfo is
-- Set if the SPARK_Pragma attribute points to an inherited pragma rather
-- than a local one.
--- Spec_Entity (Node19)
+-- Spec_Entity
-- Defined in package body entities. Points to corresponding package
-- spec entity. Also defined in subprogram body parameters in the
-- case where there is a separate spec, where this field references
-- the corresponding parameter entities in the spec.
--- SSO_Set_High_By_Default (Flag273) [base type only]
+-- SSO_Set_High_By_Default [base type only]
-- Defined for record and array types. Set in the base type if a pragma
-- Default_Scalar_Storage_Order (High_Order_First) was active at the time
-- the record or array was declared and therefore applies to it.
--- SSO_Set_Low_By_Default (Flag272) [base type only]
+-- SSO_Set_Low_By_Default [base type only]
-- Defined for record and array types. Set in the base type if a pragma
-- Default_Scalar_Storage_Order (High_Order_First) was active at the time
-- the record or array was declared and therefore applies to it.
--- Static_Discrete_Predicate (List25)
+-- Static_Discrete_Predicate
-- Defined in discrete types/subtypes with static predicates (with the
-- two flags Has_Predicates and Has_Static_Predicate set). Set if the
-- type/subtype has a static predicate. Points to a list of expression
@@ -4442,13 +4423,13 @@ package Einfo is
-- are fully analyzed and typed with the base type of the subtype. Note
-- that all entries are static and have values within the subtype range.
--- Static_Elaboration_Desired (Flag77)
+-- Static_Elaboration_Desired
-- Defined in library-level packages. Set by the pragma of the same
-- name, to indicate that static initialization must be attempted for
-- all types declared in the package, and that a warning must be emitted
-- for those types to which static initialization is not available.
--- Static_Initialization (Node30)
+-- Static_Initialization
-- Defined in initialization procedures for types whose objects can be
-- initialized statically. The value of this attribute is a positional
-- aggregate whose components are compile-time static values. Used
@@ -4457,7 +4438,7 @@ package Einfo is
-- This attribute uses the same field as Overridden_Operation, which is
-- irrelevant in init_procs.
--- Static_Real_Or_String_Predicate (Node25)
+-- Static_Real_Or_String_Predicate
-- Defined in real types/subtypes with static predicates (with the two
-- flags Has_Predicates and Has_Static_Predicate set). Set if the type
-- or subtype has a static predicate. Points to the return expression
@@ -4477,7 +4458,7 @@ package Einfo is
-- from another predicate but does not add a predicate of its own, the
-- expression may consist of the above xxxPredicate call on its own.
--- Status_Flag_Or_Transient_Decl (Node15)
+-- Status_Flag_Or_Transient_Decl
-- Defined in constant, loop, and variable entities. Applies to objects
-- that require special treatment by the finalization machinery, such as
-- extended return results, IF and CASE expression results, and objects
@@ -4486,7 +4467,7 @@ package Einfo is
-- code or the declaration of a "hook" object.
-- In which case is it a flag, or a hook object???
--- Storage_Size_Variable (Node26) [implementation base type only]
+-- Storage_Size_Variable [implementation base type only]
-- Defined in access types and task type entities. This flag is set
-- if a valid and effective pragma Storage_Size applies to the base
-- type. Points to the entity for a variable that is created to
@@ -4495,36 +4476,36 @@ package Einfo is
-- this field is defined only in the root type (since derived types
-- share the same storage pool).
--- Stored_Constraint (Elist23)
+-- Stored_Constraint
-- Defined in entities that can have discriminants (concurrent types
-- subtypes, record types and subtypes, private types and subtypes,
-- limited private types and subtypes and incomplete types). Points
-- to an element list containing the expressions for each of the
-- stored discriminants for the record (sub)type.
--- Stores_Attribute_Old_Prefix (Flag270)
+-- Stores_Attribute_Old_Prefix
-- Defined in constants, variables, and types which are created during
-- expansion in order to save the value of attribute 'Old's prefix.
--- Strict_Alignment (Flag145) [implementation base type only]
+-- Strict_Alignment [implementation base type only]
-- Defined in all type entities. Indicates that the type is by-reference
-- or contains an aliased part. This forbids packing a component of this
-- type tighter than the alignment and size of the type, as specified by
-- RM 13.2(7) modified by AI12-001 as a Binding Interpretation.
--- String_Literal_Length (Uint16)
+-- String_Literal_Length
-- Defined in string literal subtypes (which are created to correspond
-- to string literals in the program). Contains the length of the string
-- literal.
--- String_Literal_Low_Bound (Node18)
+-- String_Literal_Low_Bound
-- Defined in string literal subtypes (which are created to correspond
-- to string literals in the program). Contains an expression whose
-- value represents the low bound of the literal. This is a copy of
-- the low bound of the applicable index constraint if there is one,
-- or a copy of the low bound of the index base type if not.
--- Subprograms_For_Type (Elist29)
+-- Subprograms_For_Type
-- Defined in all types. The list may contain the entities of the default
-- initial condition procedure, invariant procedure, and the two versions
-- of the predicate function.
@@ -4533,14 +4514,14 @@ package Einfo is
-- entities rather than an Elist. The Elist allows greater flexibility
-- in inheritance of subprograms between views of the same type.
--- Subps_Index (Uint24)
+-- Subps_Index
-- Present in subprogram entries. Set if the subprogram contains nested
-- subprograms, or is a subprogram nested within such a subprogram. Holds
-- the index in the Exp_Unst.Subps table for the subprogram. Note that
-- for the outer level subprogram, this is the starting index in the Subp
-- table for the entries for this subprogram.
--- Suppress_Elaboration_Warnings (Flag303)
+-- Suppress_Elaboration_Warnings
-- NOTE: this flag is relevant only for the legacy ABE mechanism and
-- should not be used outside of that context.
--
@@ -4554,7 +4535,7 @@ package Einfo is
-- and it is set on variables when a warning is given to avoid multiple
-- elaboration warnings for the same variable.
--- Suppress_Initialization (Flag105)
+-- Suppress_Initialization
-- Defined in all variable, type and subtype entities. If set for a base
-- type, then the generation of initialization procedures is suppressed
-- for the type. Any other implicit initialization (e.g. from the use of
@@ -4566,17 +4547,17 @@ package Einfo is
-- we know that no initialization is required. For example, enumeration
-- image table entities set it.
--- Suppress_Style_Checks (Flag165)
+-- Suppress_Style_Checks
-- Defined in all entities. Suppresses any style checks specifically
-- associated with the given entity if set.
--- Suppress_Value_Tracking_On_Call (Flag217)
+-- Suppress_Value_Tracking_On_Call
-- Defined in all entities. Set in a scope entity if value tracking is to
-- be suppressed on any call within the scope. Used when an access to a
-- local subprogram is computed, to deal with the possibility that this
-- value may be passed around, and if used, may clobber a local variable.
--- Task_Body_Procedure (Node25)
+-- Task_Body_Procedure
-- Defined in task types and subtypes. Points to the entity for the task
-- task body procedure (as further described in Exp_Ch9, task bodies are
-- expanded into procedures). A convenient function to retrieve this
@@ -4585,11 +4566,11 @@ package Einfo is
-- The last sentence is odd??? Why not have Task_Body_Procedure go to the
-- Underlying_Type of the Root_Type???
--- Thunk_Entity (Node31)
+-- Thunk_Entity
-- Defined in functions and procedures which have been classified as
-- Is_Thunk. Set to the target entity called by the thunk.
--- Treat_As_Volatile (Flag41)
+-- Treat_As_Volatile
-- Defined in all type entities, and also in constants, components and
-- variables. Set if this entity is to be treated as volatile for code
-- generation purposes. Always set if Is_Volatile is set, but can also
@@ -4618,7 +4599,7 @@ package Einfo is
-- base type, but may be an expression in the case of scalar type with
-- dynamic bounds.
--- Underlying_Full_View (Node19)
+-- Underlying_Full_View
-- Defined in private subtypes that are the completion of other private
-- types, or in private types that are derived from private subtypes. If
-- the full view of a private type T is derived from another private type
@@ -4632,7 +4613,7 @@ package Einfo is
-- private completion. If Td is already constrained, then its full view
-- can serve directly as the full view of T.
--- Underlying_Record_View (Node28)
+-- Underlying_Record_View
-- Defined in record types. Set for record types that are extensions of
-- types with unknown discriminants, and also set for internally built
-- underlying record views to reference its original record type. Record
@@ -4658,7 +4639,7 @@ package Einfo is
-- type is declared in an enclosing package, the attribute will be non-
-- trivial only after the full view of the type has been analyzed.
--- Universal_Aliasing (Flag216) [implementation base type only]
+-- Universal_Aliasing [implementation base type only]
-- Defined in all type entities. Set to direct the back-end to avoid
-- any optimizations based on type-based alias analysis for this type.
-- Indicates that objects of this type can alias objects of any other
@@ -4667,67 +4648,73 @@ package Einfo is
-- of these objects. In other words, the effect is as though access
-- types designating this type were subject to No_Strict_Aliasing.
--- Unset_Reference (Node16)
+-- Unset_Reference
-- Defined in variables and out parameters. This is normally Empty. It
-- is set to point to an identifier that represents a reference to the
-- entity before any value has been set. Only the first such reference
-- is identified. This field is used to generate a warning message if
-- necessary (see Sem_Warn.Check_Unset_Reference).
--- Used_As_Generic_Actual (Flag222)
+-- Used_As_Generic_Actual
-- Defined in all entities, set if the entity is used as an argument to
-- a generic instantiation. Used to tune certain warning messages, and
-- in checking type conformance within an instantiation that involves
-- incomplete formal and actual types.
--- Uses_Lock_Free (Flag188)
+-- Uses_Lock_Free
-- Defined in protected type entities. Set to True when the Lock Free
-- implementation is used for the protected type. This implementation is
-- based on atomic transactions and doesn't require anymore the use of
-- Protection object (see System.Tasking.Protected_Objects).
--- Uses_Sec_Stack (Flag95)
+-- Uses_Sec_Stack
-- Defined in scope entities (blocks, entries, entry families, functions,
-- loops, and procedures). Set to True when the secondary stack is used
-- in this scope and must be released on exit unless flag
-- Sec_Stack_Needed_For_Return is set.
--- Validated_Object (Node38)
+-- Validated_Object
-- Defined in variables. Contains the object whose value is captured by
-- the variable for validity check purposes.
--- Warnings_Off (Flag96)
+-- Warnings_Off
-- Defined in all entities. Set if a pragma Warnings (Off, entity-name)
-- is used to suppress warnings for a given entity. It is also used by
-- the compiler in some situations to kill spurious warnings. Note that
-- clients should generally not test this flag directly, but instead
-- use function Has_Warnings_Off.
--- Warnings_Off_Used (Flag236)
+-- Warnings_Off_Used
-- Defined in all entities. Can only be set if Warnings_Off is set. If
-- set indicates that a warning was suppressed by the Warnings_Off flag,
-- and Unmodified/Unreferenced would not have suppressed the warning.
--- Warnings_Off_Used_Unmodified (Flag237)
+-- Warnings_Off_Used_Unmodified
-- Defined in all entities. Can only be set if Warnings_Off is set and
-- Has_Pragma_Unmodified is not set. If set indicates that a warning was
-- suppressed by the Warnings_Off status but that pragma Unmodified
-- would also have suppressed the warning.
--- Warnings_Off_Used_Unreferenced (Flag238)
+-- Warnings_Off_Used_Unreferenced
-- Defined in all entities. Can only be set if Warnings_Off is set and
-- Has_Pragma_Unreferenced is not set. If set indicates that a warning
-- was suppressed by the Warnings_Off status but that pragma Unreferenced
-- would also have suppressed the warning.
--- Was_Hidden (Flag196)
+-- Was_Hidden
-- Defined in all entities. Used to save the value of the Is_Hidden
-- attribute when the limited-view is installed (Ada 2005: AI-217).
--- Wrapped_Entity (Node27)
+-- Wrapped_Entity
-- Defined in functions and procedures which have been classified as
-- Is_Primitive_Wrapper. Set to the entity being wrapper.
+-- LSP_Subprogram
+-- Defined in subprogram entities. Set on wrappers created to handle
+-- inherited class-wide pre/post conditions that call overridden
+-- primitives. It references the parent primitive that has the
+-- class-wide pre/post conditions.
+
---------------------------
-- Renaming and Aliasing --
---------------------------
@@ -4742,8 +4729,8 @@ package Einfo is
-- Renamed_Object
-- Alias
--- They all overlap because they are supposed to apply to different entity
--- kinds. They are semantically related, and have the following intended uses:
+-- These are implemented in Einfo.Utils as renamings of the Renamed_Or_Alias
+-- field. They are semantically related, and have the following intended uses:
-- a) Renamed_Entity applies to entities in renaming declarations that rename
-- an entity, so the value of the attribute IS an entity. This applies to
@@ -4839,763 +4826,6 @@ package Einfo is
-- resolution. Any_Access is also replaced by the context type after
-- resolution.
---------------------------------
--- Classification of Entities --
---------------------------------
-
--- The classification of program entities which follows is a refinement of
--- the list given in RM 3.1(1). E.g., separate entities denote subtypes of
--- different type classes. Ada 95 entities include class wide types,
--- protected types, subprogram types, generalized access types, generic
--- formal derived types and generic formal packages.
-
--- The order chosen for these kinds allows us to classify related entities
--- so that they are contiguous. As a result, they do not appear in the
--- exact same order as their order of first appearance in the LRM (For
--- example, private types are listed before packages). The contiguity
--- allows us to define useful subtypes (see below) such as type entities,
--- overloaded entities, etc.
-
--- Each entity (explicitly or implicitly declared) has a kind, which is
--- a value of the following type:
-
- type Entity_Kind is (
-
- E_Void,
- -- The initial Ekind value for a newly created entity. Also used as the
- -- Ekind for Standard_Void_Type, a type entity in Standard used as a
- -- dummy type for the return type of a procedure (the reason we create
- -- this type is to share the circuits for performing overload resolution
- -- on calls).
-
- -------------
- -- Objects --
- -------------
-
- E_Component,
- -- Components of a record declaration, private declarations of
- -- protected objects.
-
- E_Constant,
- -- Constants created by an object declaration with a constant keyword
-
- E_Discriminant,
- -- A discriminant, created by the use of a discriminant in a type
- -- declaration.
-
- E_Loop_Parameter,
- -- A loop parameter created by a for loop
-
- E_Variable,
- -- Variables created by an object declaration with no constant keyword
-
- ------------------------
- -- Parameter Entities --
- ------------------------
-
- -- Parameters are also objects
-
- E_Out_Parameter,
- -- An out parameter of a subprogram or entry
-
- E_In_Out_Parameter,
- -- An in-out parameter of a subprogram or entry
-
- E_In_Parameter,
- -- An in parameter of a subprogram or entry
-
- --------------------------------
- -- Generic Parameter Entities --
- --------------------------------
-
- -- Generic parameters are also objects
-
- E_Generic_In_Out_Parameter,
- -- A generic in out parameter, created by the use of a generic in out
- -- parameter in a generic declaration.
-
- E_Generic_In_Parameter,
- -- A generic in parameter, created by the use of a generic in
- -- parameter in a generic declaration.
-
- -------------------
- -- Named Numbers --
- -------------------
-
- E_Named_Integer,
- -- Named numbers created by a number declaration with an integer value
-
- E_Named_Real,
- -- Named numbers created by a number declaration with a real value
-
- -----------------------
- -- Enumeration Types --
- -----------------------
-
- E_Enumeration_Type,
- -- Enumeration types, created by an enumeration type declaration
-
- E_Enumeration_Subtype,
- -- Enumeration subtypes, created by an explicit or implicit subtype
- -- declaration applied to an enumeration type or subtype.
-
- -------------------
- -- Numeric Types --
- -------------------
-
- E_Signed_Integer_Type,
- -- Signed integer type, used for the anonymous base type of the
- -- integer subtype created by an integer type declaration.
-
- E_Signed_Integer_Subtype,
- -- Signed integer subtype, created by either an integer subtype or
- -- integer type declaration (in the latter case an integer type is
- -- created for the base type, and this is the first named subtype).
-
- E_Modular_Integer_Type,
- -- Modular integer type, used for the anonymous base type of the
- -- integer subtype created by a modular integer type declaration.
-
- E_Modular_Integer_Subtype,
- -- Modular integer subtype, created by either an modular subtype
- -- or modular type declaration (in the latter case a modular type
- -- is created for the base type, and this is the first named subtype).
-
- E_Ordinary_Fixed_Point_Type,
- -- Ordinary fixed type, used for the anonymous base type of the fixed
- -- subtype created by an ordinary fixed point type declaration.
-
- E_Ordinary_Fixed_Point_Subtype,
- -- Ordinary fixed point subtype, created by either an ordinary fixed
- -- point subtype or ordinary fixed point type declaration (in the
- -- latter case a fixed point type is created for the base type, and
- -- this is the first named subtype).
-
- E_Decimal_Fixed_Point_Type,
- -- Decimal fixed type, used for the anonymous base type of the decimal
- -- fixed subtype created by an ordinary fixed point type declaration.
-
- E_Decimal_Fixed_Point_Subtype,
- -- Decimal fixed point subtype, created by either a decimal fixed point
- -- subtype or decimal fixed point type declaration (in the latter case
- -- a fixed point type is created for the base type, and this is the
- -- first named subtype).
-
- E_Floating_Point_Type,
- -- Floating point type, used for the anonymous base type of the
- -- floating point subtype created by a floating point type declaration.
-
- E_Floating_Point_Subtype,
-
- -- Floating point subtype, created by either a floating point subtype
- -- or floating point type declaration (in the latter case a floating
- -- point type is created for the base type, and this is the first
- -- named subtype).
-
- ------------------
- -- Access Types --
- ------------------
-
- E_Access_Type,
- -- An access type created by an access type declaration with no all
- -- keyword present. Note that the predefined type Any_Access, which
- -- has E_Access_Type Ekind, is used to label NULL in the upwards pass
- -- of type analysis, to be replaced by the true access type in the
- -- downwards resolution pass.
-
- E_Access_Subtype,
- -- An access subtype created by a subtype declaration for any access
- -- type (whether or not it is a general access type).
-
- E_Access_Attribute_Type,
- -- An access type created for an access attribute (one of 'Access,
- -- 'Unrestricted_Access, or Unchecked_Access).
-
- E_Allocator_Type,
- -- A special internal type used to label allocators and references to
- -- objects using 'Reference. This is needed because special resolution
- -- rules apply to these constructs. On the resolution pass, this type
- -- is almost always replaced by the actual access type, but if the
- -- context does not provide one, the backend will see Allocator_Type
- -- itself (which will already have been frozen).
-
- E_General_Access_Type,
- -- An access type created by an access type declaration with the all
- -- keyword present.
-
- E_Access_Subprogram_Type,
- -- An access-to-subprogram type, created by an access-to-subprogram
- -- declaration.
-
- E_Access_Protected_Subprogram_Type,
- -- An access to a protected subprogram, created by the corresponding
- -- declaration. Values of such a type denote both a protected object
- -- and a protected operation within, and have different compile-time
- -- and run-time properties than other access-to-subprogram values.
-
- E_Anonymous_Access_Protected_Subprogram_Type,
- -- An anonymous access-to-protected-subprogram type, created by an
- -- access-to-subprogram declaration.
-
- E_Anonymous_Access_Subprogram_Type,
- -- An anonymous access-to-subprogram type, created by an access-to-
- -- subprogram declaration, or generated for a current instance of
- -- a type name appearing within a component definition that has an
- -- anonymous access-to-subprogram type.
-
- E_Anonymous_Access_Type,
- -- An anonymous access type created by an access parameter or access
- -- discriminant.
-
- ---------------------
- -- Composite Types --
- ---------------------
-
- E_Array_Type,
- -- An array type created by an array type declaration. Includes all
- -- cases of arrays, except for string types.
-
- E_Array_Subtype,
- -- An array subtype, created by an explicit array subtype declaration,
- -- or the use of an anonymous array subtype.
-
- E_String_Literal_Subtype,
- -- A special string subtype, used only to describe the type of a string
- -- literal (will always be one dimensional, with literal bounds).
-
- E_Class_Wide_Type,
- -- A class wide type, created by any tagged type declaration (i.e. if
- -- a tagged type is declared, the corresponding class type is always
- -- created, using this Ekind value).
-
- E_Class_Wide_Subtype,
- -- A subtype of a class wide type, created by a subtype declaration
- -- used to declare a subtype of a class type.
-
- E_Record_Type,
- -- A record type, created by a record type declaration
-
- E_Record_Subtype,
- -- A record subtype, created by a record subtype declaration
-
- E_Record_Type_With_Private,
- -- Used for types defined by a private extension declaration,
- -- and for tagged private types. Includes the fields for both
- -- private types and for record types (with the sole exception of
- -- Corresponding_Concurrent_Type which is obviously not needed). This
- -- entity is considered to be both a record type and a private type.
-
- E_Record_Subtype_With_Private,
- -- A subtype of a type defined by a private extension declaration
-
- E_Private_Type,
- -- A private type, created by a private type declaration that has
- -- neither the keyword limited nor the keyword tagged.
-
- E_Private_Subtype,
- -- A subtype of a private type, created by a subtype declaration used
- -- to declare a subtype of a private type.
-
- E_Limited_Private_Type,
- -- A limited private type, created by a private type declaration that
- -- has the keyword limited, but not the keyword tagged.
-
- E_Limited_Private_Subtype,
- -- A subtype of a limited private type, created by a subtype declaration
- -- used to declare a subtype of a limited private type.
-
- E_Incomplete_Type,
- -- An incomplete type, created by an incomplete type declaration
-
- E_Incomplete_Subtype,
- -- An incomplete subtype, created by a subtype declaration where the
- -- subtype mark denotes an incomplete type.
-
- E_Task_Type,
- -- A task type, created by a task type declaration. An entity with this
- -- Ekind is also created to describe the anonymous type of a task that
- -- is created by a single task declaration.
-
- E_Task_Subtype,
- -- A subtype of a task type, created by a subtype declaration used to
- -- declare a subtype of a task type.
-
- E_Protected_Type,
- -- A protected type, created by a protected type declaration. An entity
- -- with this Ekind is also created to describe the anonymous type of
- -- a protected object created by a single protected declaration.
-
- E_Protected_Subtype,
- -- A subtype of a protected type, created by a subtype declaration used
- -- to declare a subtype of a protected type.
-
- -----------------
- -- Other Types --
- -----------------
-
- E_Exception_Type,
- -- The type of an exception created by an exception declaration
-
- E_Subprogram_Type,
- -- This is the designated type of an Access_To_Subprogram. Has type and
- -- signature like a subprogram entity, so can appear in calls, which
- -- are resolved like regular calls, except that such an entity is not
- -- overloadable.
-
- ---------------------------
- -- Overloadable Entities --
- ---------------------------
-
- E_Enumeration_Literal,
- -- An enumeration literal, created by the use of the literal in an
- -- enumeration type definition.
-
- E_Function,
- -- A function, created by a function declaration or a function body
- -- that acts as its own declaration.
-
- E_Operator,
- -- A predefined operator, appearing in Standard, or an implicitly
- -- defined concatenation operator created whenever an array is declared.
- -- We do not make normal derived operators explicit in the tree, but the
- -- concatenation operators are made explicit.
-
- E_Procedure,
- -- A procedure, created by a procedure declaration or a procedure
- -- body that acts as its own declaration.
-
- E_Abstract_State,
- -- A state abstraction. Used to designate entities introduced by aspect
- -- or pragma Abstract_State. The entity carries the various properties
- -- of the state.
-
- E_Entry,
- -- An entry, created by an entry declaration in a task or protected
- -- object.
-
- --------------------
- -- Other Entities --
- --------------------
-
- E_Entry_Family,
- -- An entry family, created by an entry family declaration in a
- -- task or protected type definition.
-
- E_Block,
- -- A block identifier, created by an explicit or implicit label on
- -- a block or declare statement.
-
- E_Entry_Index_Parameter,
- -- An entry index parameter created by an entry index specification
- -- for the body of a protected entry family.
-
- E_Exception,
- -- An exception created by an exception declaration. The exception
- -- itself uses E_Exception for the Ekind, the implicit type that is
- -- created to represent its type uses the Ekind E_Exception_Type.
-
- E_Generic_Function,
- -- A generic function. This is the entity for a generic function
- -- created by a generic subprogram declaration.
-
- E_Generic_Procedure,
- -- A generic function. This is the entity for a generic procedure
- -- created by a generic subprogram declaration.
-
- E_Generic_Package,
- -- A generic package, this is the entity for a generic package created
- -- by a generic package declaration.
-
- E_Label,
- -- The defining entity for a label. Note that this is created by the
- -- implicit label declaration, not the occurrence of the label itself,
- -- which is simply a direct name referring to the label.
-
- E_Loop,
- -- A loop identifier, created by an explicit or implicit label on a
- -- loop statement.
-
- E_Return_Statement,
- -- A dummy entity created for each return statement. Used to hold
- -- information about the return statement (what it applies to) and in
- -- rules checking. For example, a simple_return_statement that applies
- -- to an extended_return_statement cannot have an expression; this
- -- requires putting the E_Return_Statement entity for the
- -- extended_return_statement on the scope stack.
-
- E_Package,
- -- A package, created by a package declaration
-
- E_Package_Body,
- -- A package body. This entity serves only limited functions, since
- -- most semantic analysis uses the package entity (E_Package). However
- -- there are some attributes that are significant for the body entity.
- -- For example, collection of exception handlers.
-
- E_Protected_Body,
- -- A protected body. This entity serves almost no function, since all
- -- semantic analysis uses the protected entity (E_Protected_Type).
-
- E_Task_Body,
- -- A task body. This entity serves almost no function, since all
- -- semantic analysis uses the protected entity (E_Task_Type).
-
- E_Subprogram_Body
- -- A subprogram body. Used when a subprogram has a separate declaration
- -- to represent the entity for the body. This entity serves almost no
- -- function, since all semantic analysis uses the subprogram entity
- -- for the declaration (E_Function or E_Procedure).
- );
-
- for Entity_Kind'Size use 8;
- -- The data structures in Atree assume this
-
- --------------------------
- -- Subtype Declarations --
- --------------------------
-
- -- The above entities are arranged so that they can be conveniently grouped
- -- into subtype ranges. Note that for each of the xxx_Kind ranges defined
- -- below, there is a corresponding Is_xxx (or for types, Is_xxx_Type)
- -- predicate which is to be used in preference to direct range tests using
- -- the subtype name. However, the subtype names are available for direct
- -- use, e.g. as choices in case statements.
-
- subtype Access_Kind is Entity_Kind range
- E_Access_Type ..
- -- E_Access_Subtype
- -- E_Access_Attribute_Type
- -- E_Allocator_Type
- -- E_General_Access_Type
- -- E_Access_Subprogram_Type
- -- E_Access_Protected_Subprogram_Type
- -- E_Anonymous_Access_Protected_Subprogram_Type
- -- E_Anonymous_Access_Subprogram_Type
- E_Anonymous_Access_Type;
-
- subtype Access_Subprogram_Kind is Entity_Kind range
- E_Access_Subprogram_Type ..
- -- E_Access_Protected_Subprogram_Type
- -- E_Anonymous_Access_Protected_Subprogram_Type
- E_Anonymous_Access_Subprogram_Type;
-
- subtype Access_Protected_Kind is Entity_Kind range
- E_Access_Protected_Subprogram_Type ..
- E_Anonymous_Access_Protected_Subprogram_Type;
-
- subtype Aggregate_Kind is Entity_Kind range
- E_Array_Type ..
- -- E_Array_Subtype
- -- E_String_Literal_Subtype
- -- E_Class_Wide_Type
- -- E_Class_Wide_Subtype
- -- E_Record_Type
- E_Record_Subtype;
-
- subtype Anonymous_Access_Kind is Entity_Kind range
- E_Anonymous_Access_Protected_Subprogram_Type ..
- -- E_Anonymous_Subprogram_Type
- E_Anonymous_Access_Type;
-
- subtype Array_Kind is Entity_Kind range
- E_Array_Type ..
- -- E_Array_Subtype
- E_String_Literal_Subtype;
-
- subtype Assignable_Kind is Entity_Kind range
- E_Variable ..
- -- E_Out_Parameter
- E_In_Out_Parameter;
-
- subtype Class_Wide_Kind is Entity_Kind range
- E_Class_Wide_Type ..
- E_Class_Wide_Subtype;
-
- subtype Composite_Kind is Entity_Kind range
- E_Array_Type ..
- -- E_Array_Subtype
- -- E_String_Literal_Subtype
- -- E_Class_Wide_Type
- -- E_Class_Wide_Subtype
- -- E_Record_Type
- -- E_Record_Subtype
- -- E_Record_Type_With_Private
- -- E_Record_Subtype_With_Private
- -- E_Private_Type
- -- E_Private_Subtype
- -- E_Limited_Private_Type
- -- E_Limited_Private_Subtype
- -- E_Incomplete_Type
- -- E_Incomplete_Subtype
- -- E_Task_Type
- -- E_Task_Subtype,
- -- E_Protected_Type,
- E_Protected_Subtype;
-
- subtype Concurrent_Kind is Entity_Kind range
- E_Task_Type ..
- -- E_Task_Subtype,
- -- E_Protected_Type,
- E_Protected_Subtype;
-
- subtype Concurrent_Body_Kind is Entity_Kind range
- E_Protected_Body ..
- E_Task_Body;
-
- subtype Decimal_Fixed_Point_Kind is Entity_Kind range
- E_Decimal_Fixed_Point_Type ..
- E_Decimal_Fixed_Point_Subtype;
-
- subtype Digits_Kind is Entity_Kind range
- E_Decimal_Fixed_Point_Type ..
- -- E_Decimal_Fixed_Point_Subtype
- -- E_Floating_Point_Type
- E_Floating_Point_Subtype;
-
- subtype Discrete_Kind is Entity_Kind range
- E_Enumeration_Type ..
- -- E_Enumeration_Subtype
- -- E_Signed_Integer_Type
- -- E_Signed_Integer_Subtype
- -- E_Modular_Integer_Type
- E_Modular_Integer_Subtype;
-
- subtype Discrete_Or_Fixed_Point_Kind is Entity_Kind range
- E_Enumeration_Type ..
- -- E_Enumeration_Subtype
- -- E_Signed_Integer_Type
- -- E_Signed_Integer_Subtype
- -- E_Modular_Integer_Type
- -- E_Modular_Integer_Subtype
- -- E_Ordinary_Fixed_Point_Type
- -- E_Ordinary_Fixed_Point_Subtype
- -- E_Decimal_Fixed_Point_Type
- E_Decimal_Fixed_Point_Subtype;
-
- subtype Elementary_Kind is Entity_Kind range
- E_Enumeration_Type ..
- -- E_Enumeration_Subtype
- -- E_Signed_Integer_Type
- -- E_Signed_Integer_Subtype
- -- E_Modular_Integer_Type
- -- E_Modular_Integer_Subtype
- -- E_Ordinary_Fixed_Point_Type
- -- E_Ordinary_Fixed_Point_Subtype
- -- E_Decimal_Fixed_Point_Type
- -- E_Decimal_Fixed_Point_Subtype
- -- E_Floating_Point_Type
- -- E_Floating_Point_Subtype
- -- E_Access_Type
- -- E_Access_Subtype
- -- E_Access_Attribute_Type
- -- E_Allocator_Type
- -- E_General_Access_Type
- -- E_Access_Subprogram_Type
- -- E_Access_Protected_Subprogram_Type
- -- E_Anonymous_Access_Protected_Subprogram_Type
- -- E_Anonymous_Access_Subprogram_Type
- E_Anonymous_Access_Type;
-
- subtype Enumeration_Kind is Entity_Kind range
- E_Enumeration_Type ..
- E_Enumeration_Subtype;
-
- subtype Entry_Kind is Entity_Kind range
- E_Entry ..
- E_Entry_Family;
-
- subtype Fixed_Point_Kind is Entity_Kind range
- E_Ordinary_Fixed_Point_Type ..
- -- E_Ordinary_Fixed_Point_Subtype
- -- E_Decimal_Fixed_Point_Type
- E_Decimal_Fixed_Point_Subtype;
-
- subtype Float_Kind is Entity_Kind range
- E_Floating_Point_Type ..
- E_Floating_Point_Subtype;
-
- subtype Formal_Kind is Entity_Kind range
- E_Out_Parameter ..
- -- E_In_Out_Parameter
- E_In_Parameter;
-
- subtype Formal_Object_Kind is Entity_Kind range
- E_Generic_In_Out_Parameter ..
- E_Generic_In_Parameter;
-
- subtype Generic_Subprogram_Kind is Entity_Kind range
- E_Generic_Function ..
- E_Generic_Procedure;
-
- subtype Generic_Unit_Kind is Entity_Kind range
- E_Generic_Function ..
- -- E_Generic_Procedure
- E_Generic_Package;
-
- subtype Incomplete_Kind is Entity_Kind range
- E_Incomplete_Type ..
- E_Incomplete_Subtype;
-
- subtype Incomplete_Or_Private_Kind is Entity_Kind range
- E_Record_Type_With_Private ..
- -- E_Record_Subtype_With_Private
- -- E_Private_Type
- -- E_Private_Subtype
- -- E_Limited_Private_Type
- -- E_Limited_Private_Subtype
- -- E_Incomplete_Type
- E_Incomplete_Subtype;
-
- subtype Integer_Kind is Entity_Kind range
- E_Signed_Integer_Type ..
- -- E_Signed_Integer_Subtype
- -- E_Modular_Integer_Type
- E_Modular_Integer_Subtype;
-
- subtype Modular_Integer_Kind is Entity_Kind range
- E_Modular_Integer_Type ..
- E_Modular_Integer_Subtype;
-
- subtype Named_Kind is Entity_Kind range
- E_Named_Integer ..
- E_Named_Real;
-
- subtype Numeric_Kind is Entity_Kind range
- E_Signed_Integer_Type ..
- -- E_Signed_Integer_Subtype
- -- E_Modular_Integer_Type
- -- E_Modular_Integer_Subtype
- -- E_Ordinary_Fixed_Point_Type
- -- E_Ordinary_Fixed_Point_Subtype
- -- E_Decimal_Fixed_Point_Type
- -- E_Decimal_Fixed_Point_Subtype
- -- E_Floating_Point_Type
- E_Floating_Point_Subtype;
-
- subtype Object_Kind is Entity_Kind range
- E_Component ..
- -- E_Constant
- -- E_Discriminant
- -- E_Loop_Parameter
- -- E_Variable
- -- E_Out_Parameter
- -- E_In_Out_Parameter
- -- E_In_Parameter
- -- E_Generic_In_Out_Parameter
- E_Generic_In_Parameter;
-
- subtype Ordinary_Fixed_Point_Kind is Entity_Kind range
- E_Ordinary_Fixed_Point_Type ..
- E_Ordinary_Fixed_Point_Subtype;
-
- subtype Overloadable_Kind is Entity_Kind range
- E_Enumeration_Literal ..
- -- E_Function
- -- E_Operator
- -- E_Procedure
- -- E_Abstract_State
- E_Entry;
-
- subtype Private_Kind is Entity_Kind range
- E_Record_Type_With_Private ..
- -- E_Record_Subtype_With_Private
- -- E_Private_Type
- -- E_Private_Subtype
- -- E_Limited_Private_Type
- E_Limited_Private_Subtype;
-
- subtype Protected_Kind is Entity_Kind range
- E_Protected_Type ..
- E_Protected_Subtype;
-
- subtype Real_Kind is Entity_Kind range
- E_Ordinary_Fixed_Point_Type ..
- -- E_Ordinary_Fixed_Point_Subtype
- -- E_Decimal_Fixed_Point_Type
- -- E_Decimal_Fixed_Point_Subtype
- -- E_Floating_Point_Type
- E_Floating_Point_Subtype;
-
- subtype Record_Kind is Entity_Kind range
- E_Class_Wide_Type ..
- -- E_Class_Wide_Subtype
- -- E_Record_Type
- -- E_Record_Subtype
- -- E_Record_Type_With_Private
- E_Record_Subtype_With_Private;
-
- subtype Scalar_Kind is Entity_Kind range
- E_Enumeration_Type ..
- -- E_Enumeration_Subtype
- -- E_Signed_Integer_Type
- -- E_Signed_Integer_Subtype
- -- E_Modular_Integer_Type
- -- E_Modular_Integer_Subtype
- -- E_Ordinary_Fixed_Point_Type
- -- E_Ordinary_Fixed_Point_Subtype
- -- E_Decimal_Fixed_Point_Type
- -- E_Decimal_Fixed_Point_Subtype
- -- E_Floating_Point_Type
- E_Floating_Point_Subtype;
-
- subtype Subprogram_Kind is Entity_Kind range
- E_Function ..
- -- E_Operator
- E_Procedure;
-
- subtype Signed_Integer_Kind is Entity_Kind range
- E_Signed_Integer_Type ..
- E_Signed_Integer_Subtype;
-
- subtype Task_Kind is Entity_Kind range
- E_Task_Type ..
- E_Task_Subtype;
-
- subtype Type_Kind is Entity_Kind range
- E_Enumeration_Type ..
- -- E_Enumeration_Subtype
- -- E_Signed_Integer_Type
- -- E_Signed_Integer_Subtype
- -- E_Modular_Integer_Type
- -- E_Modular_Integer_Subtype
- -- E_Ordinary_Fixed_Point_Type
- -- E_Ordinary_Fixed_Point_Subtype
- -- E_Decimal_Fixed_Point_Type
- -- E_Decimal_Fixed_Point_Subtype
- -- E_Floating_Point_Type
- -- E_Floating_Point_Subtype
- -- E_Access_Type
- -- E_Access_Subtype
- -- E_Access_Attribute_Type
- -- E_Allocator_Type,
- -- E_General_Access_Type
- -- E_Access_Subprogram_Type,
- -- E_Access_Protected_Subprogram_Type
- -- E_Anonymous_Access_Protected_Subprogram_Type
- -- E_Anonymous_Access_Subprogram_Type
- -- E_Anonymous_Access_Type
- -- E_Array_Type
- -- E_Array_Subtype
- -- E_String_Literal_Subtype
- -- E_Class_Wide_Subtype
- -- E_Class_Wide_Type
- -- E_Record_Type
- -- E_Record_Subtype
- -- E_Record_Type_With_Private
- -- E_Record_Subtype_With_Private
- -- E_Private_Type
- -- E_Private_Subtype
- -- E_Limited_Private_Type
- -- E_Limited_Private_Subtype
- -- E_Incomplete_Type
- -- E_Incomplete_Subtype
- -- E_Task_Type
- -- E_Task_Subtype
- -- E_Protected_Type
- -- E_Protected_Subtype
- -- E_Exception_Type
- E_Subprogram_Type;
-
--------------------------------------------------------
-- Description of Defined Attributes for Entity_Kinds --
--------------------------------------------------------
@@ -5610,116 +4840,117 @@ package Einfo is
-- Ekind (Ekind)
- -- Chars (Name1)
- -- Next_Entity (Node2)
- -- Scope (Node3)
- -- Homonym (Node4)
- -- Etype (Node5)
- -- First_Rep_Item (Node6)
- -- Freeze_Node (Node7)
- -- Prev_Entity (Node36)
- -- Associated_Entity (Node37)
-
- -- Address_Taken (Flag104)
- -- Can_Never_Be_Null (Flag38)
- -- Checks_May_Be_Suppressed (Flag31)
- -- Debug_Info_Off (Flag166)
- -- Has_Convention_Pragma (Flag119)
- -- Has_Delayed_Aspects (Flag200)
- -- Has_Delayed_Freeze (Flag18)
- -- Has_Fully_Qualified_Name (Flag173)
- -- Has_Gigi_Rep_Item (Flag82)
- -- Has_Homonym (Flag56)
- -- Has_Pragma_Elaborate_Body (Flag150)
- -- Has_Pragma_Inline (Flag157)
- -- Has_Pragma_Inline_Always (Flag230)
- -- Has_Pragma_No_Inline (Flag201)
- -- Has_Pragma_Pure (Flag203)
- -- Has_Pragma_Pure_Function (Flag179)
- -- Has_Pragma_Thread_Local_Storage (Flag169)
- -- Has_Pragma_Unmodified (Flag233)
- -- Has_Pragma_Unreferenced (Flag180)
- -- Has_Pragma_Unused (Flag294)
- -- Has_Private_Declaration (Flag155)
- -- Has_Qualified_Name (Flag161)
- -- Has_Stream_Size_Clause (Flag184)
- -- Has_Unknown_Discriminants (Flag72)
- -- Has_Xref_Entry (Flag182)
- -- In_Private_Part (Flag45)
- -- Is_Ada_2005_Only (Flag185)
- -- Is_Ada_2012_Only (Flag199)
- -- Is_Bit_Packed_Array (Flag122) (base type only)
- -- Is_Aliased (Flag15)
- -- Is_Character_Type (Flag63)
- -- Is_Checked_Ghost_Entity (Flag277)
- -- Is_Child_Unit (Flag73)
- -- Is_Compilation_Unit (Flag149)
- -- Is_Descendant_Of_Address (Flag223)
- -- Is_Discrim_SO_Function (Flag176)
- -- Is_Discriminant_Check_Function (Flag264)
- -- Is_Dispatch_Table_Entity (Flag234)
- -- Is_Dispatching_Operation (Flag6)
- -- Is_Entry_Formal (Flag52)
- -- Is_Exported (Flag99)
- -- Is_First_Subtype (Flag70)
- -- Is_Formal_Subprogram (Flag111)
- -- Is_Generic_Instance (Flag130)
- -- Is_Generic_Type (Flag13)
- -- Is_Hidden (Flag57)
- -- Is_Hidden_Open_Scope (Flag171)
- -- Is_Ignored_Ghost_Entity (Flag278)
- -- Is_Immediately_Visible (Flag7)
- -- Is_Implementation_Defined (Flag254)
- -- Is_Imported (Flag24)
- -- Is_Inlined (Flag11)
- -- Is_Internal (Flag17)
- -- Is_Itype (Flag91)
- -- Is_Known_Non_Null (Flag37)
- -- Is_Known_Null (Flag204)
- -- Is_Known_Valid (Flag170)
- -- Is_Limited_Composite (Flag106)
- -- Is_Limited_Record (Flag25)
- -- Is_Loop_Parameter (Flag307)
- -- Is_Obsolescent (Flag153)
- -- Is_Package_Body_Entity (Flag160)
- -- Is_Packed_Array_Impl_Type (Flag138)
- -- Is_Potentially_Use_Visible (Flag9)
- -- Is_Preelaborated (Flag59)
- -- Is_Primitive_Wrapper (Flag195)
- -- Is_Public (Flag10)
- -- Is_Pure (Flag44)
- -- Is_Remote_Call_Interface (Flag62)
- -- Is_Remote_Types (Flag61)
- -- Is_Renaming_Of_Object (Flag112)
- -- Is_Shared_Passive (Flag60)
- -- Is_Statically_Allocated (Flag28)
- -- Is_Static_Type (Flag281)
- -- Is_Tagged_Type (Flag55)
- -- Is_Thunk (Flag225)
- -- Is_Trivial_Subprogram (Flag235)
- -- Is_Unchecked_Union (Flag117)
- -- Is_Unimplemented (Flag284)
- -- Is_Visible_Formal (Flag206)
- -- Kill_Elaboration_Checks (Flag32)
- -- Kill_Range_Checks (Flag33)
- -- Low_Bound_Tested (Flag205)
- -- Materialize_Entity (Flag168)
- -- Needs_Debug_Info (Flag147)
- -- Never_Set_In_Source (Flag115)
- -- No_Return (Flag113)
- -- Overlays_Constant (Flag243)
- -- Referenced (Flag156)
- -- Referenced_As_LHS (Flag36)
- -- Referenced_As_Out_Parameter (Flag227)
- -- Suppress_Elaboration_Warnings (Flag303)
- -- Suppress_Style_Checks (Flag165)
- -- Suppress_Value_Tracking_On_Call (Flag217)
- -- Used_As_Generic_Actual (Flag222)
- -- Warnings_Off (Flag96)
- -- Warnings_Off_Used (Flag236)
- -- Warnings_Off_Used_Unmodified (Flag237)
- -- Warnings_Off_Used_Unreferenced (Flag238)
- -- Was_Hidden (Flag196)
+ -- Chars
+ -- Next_Entity
+ -- Scope
+ -- Homonym
+ -- Etype
+ -- First_Rep_Item
+ -- Freeze_Node
+ -- Prev_Entity
+ -- Associated_Entity
+
+ -- Address_Taken
+ -- Can_Never_Be_Null
+ -- Checks_May_Be_Suppressed
+ -- Debug_Info_Off
+ -- Has_Convention_Pragma
+ -- Has_Delayed_Aspects
+ -- Has_Delayed_Freeze
+ -- Has_Fully_Qualified_Name
+ -- Has_Gigi_Rep_Item
+ -- Has_Homonym
+ -- Has_Pragma_Elaborate_Body
+ -- Has_Pragma_Inline
+ -- Has_Pragma_Inline_Always
+ -- Has_Pragma_No_Inline
+ -- Has_Pragma_Pure
+ -- Has_Pragma_Pure_Function
+ -- Has_Pragma_Thread_Local_Storage
+ -- Has_Pragma_Unmodified
+ -- Has_Pragma_Unreferenced
+ -- Has_Pragma_Unused
+ -- Has_Private_Declaration
+ -- Has_Qualified_Name
+ -- Has_Stream_Size_Clause
+ -- Has_Unknown_Discriminants
+ -- Has_Xref_Entry
+ -- In_Private_Part
+ -- Is_Ada_2005_Only
+ -- Is_Ada_2012_Only
+ -- Is_Ada_2022_Only
+ -- Is_Bit_Packed_Array (base type only)
+ -- Is_Aliased
+ -- Is_Character_Type
+ -- Is_Checked_Ghost_Entity
+ -- Is_Child_Unit
+ -- Is_Compilation_Unit
+ -- Is_Descendant_Of_Address
+ -- Is_Discrim_SO_Function
+ -- Is_Discriminant_Check_Function
+ -- Is_Dispatch_Table_Entity
+ -- Is_Dispatching_Operation
+ -- Is_Entry_Formal
+ -- Is_Exported
+ -- Is_First_Subtype
+ -- Is_Formal_Subprogram
+ -- Is_Generic_Instance
+ -- Is_Generic_Type
+ -- Is_Hidden
+ -- Is_Hidden_Open_Scope
+ -- Is_Ignored_Ghost_Entity
+ -- Is_Immediately_Visible
+ -- Is_Implementation_Defined
+ -- Is_Imported
+ -- Is_Inlined
+ -- Is_Internal
+ -- Is_Itype
+ -- Is_Known_Non_Null
+ -- Is_Known_Null
+ -- Is_Known_Valid
+ -- Is_Limited_Composite
+ -- Is_Limited_Record
+ -- Is_Loop_Parameter
+ -- Is_Obsolescent
+ -- Is_Package_Body_Entity
+ -- Is_Packed_Array_Impl_Type
+ -- Is_Potentially_Use_Visible
+ -- Is_Preelaborated
+ -- Is_Primitive_Wrapper
+ -- Is_Public
+ -- Is_Pure
+ -- Is_Remote_Call_Interface
+ -- Is_Remote_Types
+ -- Is_Renaming_Of_Object
+ -- Is_Shared_Passive
+ -- Is_Statically_Allocated
+ -- Is_Static_Type
+ -- Is_Tagged_Type
+ -- Is_Thunk
+ -- Is_Trivial_Subprogram
+ -- Is_Unchecked_Union
+ -- Is_Unimplemented
+ -- Is_Visible_Formal
+ -- Kill_Elaboration_Checks
+ -- Kill_Range_Checks
+ -- Low_Bound_Tested
+ -- Materialize_Entity
+ -- Needs_Debug_Info
+ -- Never_Set_In_Source
+ -- No_Return
+ -- Overlays_Constant
+ -- Referenced
+ -- Referenced_As_LHS
+ -- Referenced_As_Out_Parameter
+ -- Suppress_Elaboration_Warnings
+ -- Suppress_Style_Checks
+ -- Suppress_Value_Tracking_On_Call
+ -- Used_As_Generic_Actual
+ -- Warnings_Off
+ -- Warnings_Off_Used
+ -- Warnings_Off_Used_Unmodified
+ -- Warnings_Off_Used_Unreferenced
+ -- Was_Hidden
-- Declaration_Node (synth)
-- Has_Foreign_Convention (synth)
@@ -5734,95 +4965,95 @@ package Einfo is
-- types and subtypes. References to this list appear subsequently as
-- "(plus type attributes)" for each appropriate Entity_Kind.
- -- Associated_Node_For_Itype (Node8)
- -- Class_Wide_Type (Node9)
- -- Full_View (Node11)
- -- Esize (Uint12)
- -- RM_Size (Uint13)
- -- Alignment (Uint14)
- -- Pending_Access_Types (Elist15)
- -- Related_Expression (Node24)
- -- Current_Use_Clause (Node27)
- -- Subprograms_For_Type (Elist29)
- -- Derived_Type_Link (Node31)
- -- No_Tagged_Streams_Pragma (Node32)
- -- Linker_Section_Pragma (Node33)
- -- SPARK_Pragma (Node40)
-
- -- Depends_On_Private (Flag14)
- -- Disable_Controlled (Flag253)
- -- Discard_Names (Flag88)
- -- Finalize_Storage_Only (Flag158) (base type only)
- -- From_Limited_With (Flag159)
- -- Has_Aliased_Components (Flag135) (base type only)
- -- Has_Alignment_Clause (Flag46)
- -- Has_Atomic_Components (Flag86) (base type only)
- -- Has_Completion_In_Body (Flag71)
- -- Has_Complex_Representation (Flag140) (base type only)
- -- Has_Constrained_Partial_View (Flag187)
- -- Has_Controlled_Component (Flag43) (base type only)
- -- Has_Default_Aspect (Flag39) (base type only)
- -- Has_Delayed_Rep_Aspects (Flag261)
- -- Has_Discriminants (Flag5)
- -- Has_Dynamic_Predicate_Aspect (Flag258)
- -- Has_Independent_Components (Flag34) (base type only)
- -- Has_Inheritable_Invariants (Flag248) (base type only)
- -- Has_Inherited_DIC (Flag133) (base type only)
- -- Has_Inherited_Invariants (Flag291) (base type only)
- -- Has_Non_Standard_Rep (Flag75) (base type only)
- -- Has_Object_Size_Clause (Flag172)
- -- Has_Own_DIC (Flag3) (base type only)
- -- Has_Own_Invariants (Flag232) (base type only)
- -- Has_Pragma_Preelab_Init (Flag221)
- -- Has_Pragma_Unreferenced_Objects (Flag212)
- -- Has_Predicates (Flag250)
- -- Has_Primitive_Operations (Flag120) (base type only)
- -- Has_Protected (Flag271) (base type only)
- -- Has_Size_Clause (Flag29)
- -- Has_Specified_Layout (Flag100) (base type only)
- -- Has_Specified_Stream_Input (Flag190)
- -- Has_Specified_Stream_Output (Flag191)
- -- Has_Specified_Stream_Read (Flag192)
- -- Has_Specified_Stream_Write (Flag193)
- -- Has_Static_Predicate (Flag269)
- -- Has_Static_Predicate_Aspect (Flag259)
- -- Has_Task (Flag30) (base type only)
- -- Has_Timing_Event (Flag289) (base type only)
- -- Has_Unchecked_Union (Flag123) (base type only)
- -- Has_Volatile_Components (Flag87) (base type only)
- -- In_Use (Flag8)
- -- Is_Abstract_Type (Flag146)
- -- Is_Asynchronous (Flag81)
- -- Is_Atomic (Flag85)
- -- Is_Constr_Subt_For_U_Nominal (Flag80)
- -- Is_Constr_Subt_For_UN_Aliased (Flag141)
- -- Is_Controlled_Active (Flag42) (base type only)
- -- Is_Eliminated (Flag124)
- -- Is_Frozen (Flag4)
- -- Is_Generic_Actual_Type (Flag94)
- -- Is_Independent (Flag268)
- -- Is_Non_Static_Subtype (Flag109)
- -- Is_Packed (Flag51) (base type only)
- -- Is_Private_Composite (Flag107)
- -- Is_RACW_Stub_Type (Flag244)
- -- Is_Unsigned_Type (Flag144)
- -- Is_Volatile (Flag16)
- -- Is_Volatile_Full_Access (Flag285)
- -- Itype_Printed (Flag202) (itypes only)
- -- Known_To_Have_Preelab_Init (Flag207)
- -- May_Inherit_Delayed_Rep_Aspects (Flag262)
- -- Must_Be_On_Byte_Boundary (Flag183)
- -- Must_Have_Preelab_Init (Flag208)
- -- Optimize_Alignment_Space (Flag241)
- -- Optimize_Alignment_Time (Flag242)
- -- Partial_View_Has_Unknown_Discr (Flag280)
- -- Size_Depends_On_Discriminant (Flag177)
- -- Size_Known_At_Compile_Time (Flag92)
- -- SPARK_Pragma_Inherited (Flag265)
- -- Strict_Alignment (Flag145) (base type only)
- -- Suppress_Initialization (Flag105)
- -- Treat_As_Volatile (Flag41)
- -- Universal_Aliasing (Flag216) (impl base type only)
+ -- Associated_Node_For_Itype
+ -- Class_Wide_Type
+ -- Full_View
+ -- Esize
+ -- RM_Size
+ -- Alignment
+ -- Pending_Access_Types
+ -- Related_Expression
+ -- Current_Use_Clause
+ -- Subprograms_For_Type
+ -- Derived_Type_Link
+ -- No_Tagged_Streams_Pragma
+ -- Linker_Section_Pragma
+ -- SPARK_Pragma
+
+ -- Depends_On_Private
+ -- Disable_Controlled
+ -- Discard_Names
+ -- Finalize_Storage_Only (base type only)
+ -- From_Limited_With
+ -- Has_Aliased_Components (base type only)
+ -- Has_Alignment_Clause
+ -- Has_Atomic_Components (base type only)
+ -- Has_Completion_In_Body
+ -- Has_Complex_Representation (base type only)
+ -- Has_Constrained_Partial_View
+ -- Has_Controlled_Component (base type only)
+ -- Has_Default_Aspect (base type only)
+ -- Has_Delayed_Rep_Aspects
+ -- Has_Discriminants
+ -- Has_Dynamic_Predicate_Aspect
+ -- Has_Independent_Components (base type only)
+ -- Has_Inheritable_Invariants (base type only)
+ -- Has_Inherited_DIC (base type only)
+ -- Has_Inherited_Invariants (base type only)
+ -- Has_Non_Standard_Rep (base type only)
+ -- Has_Object_Size_Clause
+ -- Has_Own_DIC (base type only)
+ -- Has_Own_Invariants (base type only)
+ -- Has_Pragma_Preelab_Init
+ -- Has_Pragma_Unreferenced_Objects
+ -- Has_Predicates
+ -- Has_Primitive_Operations (base type only)
+ -- Has_Protected (base type only)
+ -- Has_Size_Clause
+ -- Has_Specified_Layout (base type only)
+ -- Has_Specified_Stream_Input
+ -- Has_Specified_Stream_Output
+ -- Has_Specified_Stream_Read
+ -- Has_Specified_Stream_Write
+ -- Has_Static_Predicate
+ -- Has_Static_Predicate_Aspect
+ -- Has_Task (base type only)
+ -- Has_Timing_Event (base type only)
+ -- Has_Unchecked_Union (base type only)
+ -- Has_Volatile_Components (base type only)
+ -- In_Use
+ -- Is_Abstract_Type
+ -- Is_Asynchronous
+ -- Is_Atomic
+ -- Is_Constr_Subt_For_U_Nominal
+ -- Is_Constr_Subt_For_UN_Aliased
+ -- Is_Controlled_Active (base type only)
+ -- Is_Eliminated
+ -- Is_Frozen
+ -- Is_Generic_Actual_Type
+ -- Is_Independent
+ -- Is_Non_Static_Subtype
+ -- Is_Packed (base type only)
+ -- Is_Private_Composite
+ -- Is_RACW_Stub_Type
+ -- Is_Unsigned_Type
+ -- Is_Volatile
+ -- Is_Volatile_Full_Access
+ -- Itype_Printed (itypes only)
+ -- Known_To_Have_Preelab_Init
+ -- May_Inherit_Delayed_Rep_Aspects
+ -- Must_Be_On_Byte_Boundary
+ -- Must_Have_Preelab_Init
+ -- Optimize_Alignment_Space
+ -- Optimize_Alignment_Time
+ -- Partial_View_Has_Unknown_Discr
+ -- Size_Depends_On_Discriminant
+ -- Size_Known_At_Compile_Time
+ -- SPARK_Pragma_Inherited
+ -- Strict_Alignment (base type only)
+ -- Suppress_Initialization
+ -- Treat_As_Volatile
+ -- Universal_Aliasing (impl base type only)
-- Alignment_Clause (synth)
-- Base_Type (synth)
@@ -5846,17 +5077,22 @@ package Einfo is
-- Applicable attributes by entity kind --
------------------------------------------
+ -- In the conversion to variable-sized nodes and entities, a number of
+ -- discrepancies were noticed. They are documented in comments, and marked
+ -- with "$$$".
+
-- E_Abstract_State
- -- Refinement_Constituents (Elist8)
- -- Part_Of_Constituents (Elist10)
- -- Body_References (Elist16)
- -- Non_Limited_View (Node19)
- -- Encapsulating_State (Node32)
- -- SPARK_Pragma (Node40)
- -- From_Limited_With (Flag159)
- -- Has_Partial_Visible_Refinement (Flag296)
- -- Has_Visible_Refinement (Flag263)
- -- SPARK_Pragma_Inherited (Flag265)
+ -- Refinement_Constituents
+ -- Part_Of_Constituents
+ -- Body_References
+ -- Non_Limited_View
+ -- Encapsulating_State
+ -- SPARK_Pragma
+ -- From_Limited_With
+ -- Has_Partial_Visible_Refinement
+ -- Has_Visible_Refinement
+ -- SPARK_Pragma_Inherited
+ -- First_Entity $$$
-- Has_Non_Limited_View (synth)
-- Has_Non_Null_Visible_Refinement (synth)
-- Has_Null_Visible_Refinement (synth)
@@ -5867,1017 +5103,1095 @@ package Einfo is
-- Partial_Refinement_Constituents (synth)
-- E_Access_Protected_Subprogram_Type
- -- Equivalent_Type (Node18)
- -- Directly_Designated_Type (Node20)
- -- Needs_No_Actuals (Flag22)
- -- Can_Use_Internal_Rep (Flag229)
+ -- Equivalent_Type
+ -- Directly_Designated_Type
+ -- Needs_No_Actuals
+ -- Can_Use_Internal_Rep
-- (plus type attributes)
-- E_Access_Subprogram_Type
- -- Equivalent_Type (Node18) (remote types only)
- -- Directly_Designated_Type (Node20)
- -- Needs_No_Actuals (Flag22)
- -- Original_Access_Type (Node28)
- -- Can_Use_Internal_Rep (Flag229)
- -- Needs_Activation_Record (Flag306)
+ -- Equivalent_Type (remote types only)
+ -- Directly_Designated_Type
+ -- Needs_No_Actuals
+ -- Original_Access_Type
+ -- Can_Use_Internal_Rep
+ -- Needs_Activation_Record
+ -- Associated_Storage_Pool $$$
+ -- Interface_Name $$$
-- (plus type attributes)
-- E_Access_Type
-- E_Access_Subtype
- -- Master_Id (Node17)
- -- Directly_Designated_Type (Node20)
- -- Associated_Storage_Pool (Node22) (base type only)
- -- Finalization_Master (Node23) (base type only)
- -- Storage_Size_Variable (Node26) (base type only)
- -- Has_Pragma_Controlled (Flag27) (base type only)
- -- Has_Storage_Size_Clause (Flag23) (base type only)
- -- Is_Access_Constant (Flag69)
- -- Is_Local_Anonymous_Access (Flag194)
- -- Is_Pure_Unit_Access_Type (Flag189)
- -- No_Pool_Assigned (Flag131) (base type only)
- -- No_Strict_Aliasing (Flag136) (base type only)
- -- Is_Param_Block_Component_Type (Flag215) (base type only)
+ -- Direct_Primitive_Operations $$$ type
+ -- Master_Id
+ -- Directly_Designated_Type
+ -- Associated_Storage_Pool (base type only)
+ -- Finalization_Master (base type only)
+ -- Storage_Size_Variable (base type only)
+ -- Has_Pragma_Controlled (base type only)
+ -- Has_Storage_Size_Clause (base type only)
+ -- Is_Access_Constant
+ -- Is_Local_Anonymous_Access
+ -- Is_Pure_Unit_Access_Type
+ -- No_Pool_Assigned (base type only)
+ -- No_Strict_Aliasing (base type only)
+ -- Is_Param_Block_Component_Type (base type only)
-- (plus type attributes)
-- E_Access_Attribute_Type
- -- Directly_Designated_Type (Node20)
+ -- Renamed_Entity $$$
+ -- Directly_Designated_Type
-- (plus type attributes)
-- E_Allocator_Type
- -- Directly_Designated_Type (Node20)
+ -- Directly_Designated_Type
+ -- Associated_Storage_Pool $$$
-- (plus type attributes)
-- E_Anonymous_Access_Subprogram_Type
-- E_Anonymous_Access_Protected_Subprogram_Type
- -- Directly_Designated_Type (Node20)
- -- Storage_Size_Variable (Node26) ??? is this needed ???
- -- Can_Use_Internal_Rep (Flag229)
- -- Needs_Activation_Record (Flag306)
+ -- Interface_Name $$$ E_Anonymous_Access_Subprogram_Type
+ -- Directly_Designated_Type
+ -- Storage_Size_Variable is this needed ???
+ -- Can_Use_Internal_Rep
+ -- Needs_Activation_Record
-- (plus type attributes)
-- E_Anonymous_Access_Type
- -- Directly_Designated_Type (Node20)
- -- Finalization_Master (Node23)
- -- Storage_Size_Variable (Node26) ??? is this needed ???
+ -- Directly_Designated_Type
+ -- Finalization_Master
+ -- Storage_Size_Variable is this needed ???
+ -- Associated_Storage_Pool $$$
-- (plus type attributes)
-- E_Array_Type
-- E_Array_Subtype
- -- First_Index (Node17)
- -- Default_Aspect_Component_Value (Node19) (base type only)
- -- Component_Type (Node20) (base type only)
- -- Original_Array_Type (Node21)
- -- Component_Size (Uint22) (base type only)
- -- Packed_Array_Impl_Type (Node23)
- -- Related_Array_Object (Node25)
- -- Predicated_Parent (Node38) (subtype only)
- -- Component_Alignment (special) (base type only)
- -- Has_Component_Size_Clause (Flag68) (base type only)
- -- Has_Pragma_Pack (Flag121) (impl base type only)
- -- Is_Constrained (Flag12)
- -- Reverse_Storage_Order (Flag93) (base type only)
- -- SSO_Set_High_By_Default (Flag273) (base type only)
- -- SSO_Set_Low_By_Default (Flag272) (base type only)
- -- Next_Index (synth)
- -- Number_Dimensions (synth)
+ -- First_Entity $$$
+ -- Direct_Primitive_Operations $$$ subtype
+ -- Renamed_Object $$$ E_Array_Subtype
+ -- First_Index
+ -- Default_Aspect_Component_Value (base type only)
+ -- Component_Type (base type only)
+ -- Original_Array_Type
+ -- Component_Size (base type only)
+ -- Packed_Array_Impl_Type
+ -- Related_Array_Object
+ -- Predicated_Parent (subtype only)
+ -- Component_Alignment (special) (base type only)
+ -- Has_Component_Size_Clause (base type only)
+ -- Has_Pragma_Pack (impl base type only)
+ -- Is_Constrained
+ -- Reverse_Storage_Order (base type only)
+ -- SSO_Set_High_By_Default (base type only)
+ -- SSO_Set_Low_By_Default (base type only)
+ -- Next_Index (synth)
+ -- Number_Dimensions (synth)
-- (plus type attributes)
-- E_Block
- -- Return_Applies_To (Node8)
- -- Block_Node (Node11)
- -- First_Entity (Node17)
- -- Last_Entity (Node20)
- -- Scope_Depth_Value (Uint22)
- -- Entry_Cancel_Parameter (Node23)
- -- Contains_Ignored_Ghost_Code (Flag279)
- -- Delay_Cleanups (Flag114)
- -- Discard_Names (Flag88)
- -- Has_Master_Entity (Flag21)
- -- Has_Nested_Block_With_Handler (Flag101)
- -- Is_Exception_Handler (Flag286)
- -- Sec_Stack_Needed_For_Return (Flag167)
- -- Uses_Sec_Stack (Flag95)
+ -- Renamed_Entity $$$
+ -- Renamed_Object $$$
+ -- Return_Applies_To
+ -- Block_Node
+ -- First_Entity
+ -- Last_Entity
+ -- Scope_Depth_Value
+ -- Entry_Cancel_Parameter
+ -- Contains_Ignored_Ghost_Code
+ -- Delay_Cleanups
+ -- Discard_Names
+ -- Has_Master_Entity
+ -- Has_Nested_Block_With_Handler
+ -- Is_Exception_Handler
+ -- Sec_Stack_Needed_For_Return
+ -- Uses_Sec_Stack
-- Scope_Depth (synth)
-- E_Class_Wide_Type
-- E_Class_Wide_Subtype
- -- Direct_Primitive_Operations (Elist10)
- -- Cloned_Subtype (Node16) (subtype case only)
- -- First_Entity (Node17)
- -- Equivalent_Type (Node18) (always Empty for type)
- -- Non_Limited_View (Node19)
- -- Last_Entity (Node20)
- -- SSO_Set_High_By_Default (Flag273) (base type only)
- -- SSO_Set_Low_By_Default (Flag272) (base type only)
- -- First_Component (synth)
- -- First_Component_Or_Discriminant (synth)
- -- Has_Non_Limited_View (synth)
+ -- Direct_Primitive_Operations
+ -- Cloned_Subtype (subtype case only)
+ -- First_Entity
+ -- Equivalent_Type (always Empty for type)
+ -- Non_Limited_View
+ -- Last_Entity
+ -- SSO_Set_High_By_Default (base type only)
+ -- SSO_Set_Low_By_Default (base type only)
+ -- Corresponding_Remote_Type $$$ type
+ -- Renamed_Entity $$$ type
+ -- First_Component (synth)
+ -- First_Component_Or_Discriminant (synth)
+ -- Has_Non_Limited_View (synth)
-- (plus type attributes)
-- E_Component
- -- Normalized_First_Bit (Uint8)
- -- Current_Value (Node9) (always Empty)
- -- Normalized_Position_Max (Uint10)
- -- Component_Bit_Offset (Uint11)
- -- Esize (Uint12)
- -- Component_Clause (Node13)
- -- Normalized_Position (Uint14)
- -- DT_Entry_Count (Uint15)
- -- Entry_Formal (Node16)
- -- Prival (Node17)
- -- Renamed_Object (Node18) (always Empty)
- -- Discriminant_Checking_Func (Node20)
- -- Corresponding_Record_Component (Node21)
- -- Original_Record_Component (Node22)
- -- DT_Offset_To_Top_Func (Node25)
- -- Related_Type (Node27)
- -- Has_Biased_Representation (Flag139)
- -- Has_Per_Object_Constraint (Flag154)
- -- Is_Atomic (Flag85)
- -- Is_Independent (Flag268)
- -- Is_Return_Object (Flag209)
- -- Is_Tag (Flag78)
- -- Is_Volatile (Flag16)
- -- Is_Volatile_Full_Access (Flag285)
- -- Treat_As_Volatile (Flag41)
+ -- Linker_Section_Pragma $$$
+ -- Normalized_First_Bit
+ -- Current_Value (always Empty)
+ -- Normalized_Position_Max
+ -- Component_Bit_Offset
+ -- Esize
+ -- Component_Clause
+ -- Normalized_Position
+ -- DT_Entry_Count
+ -- Entry_Formal
+ -- Prival
+ -- Renamed_Object (always Empty)
+ -- Discriminant_Checking_Func
+ -- Corresponding_Record_Component
+ -- Original_Record_Component
+ -- DT_Offset_To_Top_Func
+ -- Related_Type
+ -- Has_Biased_Representation
+ -- Has_Per_Object_Constraint
+ -- Is_Atomic
+ -- Is_Independent
+ -- Is_Return_Object
+ -- Is_Tag
+ -- Is_Volatile
+ -- Is_Volatile_Full_Access
+ -- Treat_As_Volatile
-- Is_Full_Access (synth)
-- Next_Component (synth)
-- Next_Component_Or_Discriminant (synth)
-- E_Constant
-- E_Loop_Parameter
- -- Current_Value (Node9) (always Empty)
- -- Discriminal_Link (Node10)
- -- Full_View (Node11)
- -- Esize (Uint12)
- -- Extra_Accessibility (Node13) (constants only)
- -- Alignment (Uint14)
- -- Status_Flag_Or_Transient_Decl (Node15)
- -- Actual_Subtype (Node17)
- -- Renamed_Object (Node18)
- -- Size_Check_Code (Node19) (constants only)
- -- Prival_Link (Node20) (privals only)
- -- Interface_Name (Node21) (constants only)
- -- Related_Type (Node27) (constants only)
- -- Initialization_Statements (Node28)
- -- BIP_Initialization_Call (Node29)
- -- Last_Aggregate_Assignment (Node30)
- -- Activation_Record_Component (Node31)
- -- Encapsulating_State (Node32) (constants only)
- -- Linker_Section_Pragma (Node33)
- -- Contract (Node34) (constants only)
- -- SPARK_Pragma (Node40) (constants only)
- -- Has_Alignment_Clause (Flag46)
- -- Has_Atomic_Components (Flag86)
- -- Has_Biased_Representation (Flag139)
- -- Has_Completion (Flag26) (constants only)
- -- Has_Independent_Components (Flag34)
- -- Has_Size_Clause (Flag29)
- -- Has_Thunks (Flag228) (constants only)
- -- Has_Volatile_Components (Flag87)
- -- Is_Atomic (Flag85)
- -- Is_Elaboration_Checks_OK_Id (Flag148) (constants only)
- -- Is_Elaboration_Warnings_OK_Id (Flag304) (constants only)
- -- Is_Eliminated (Flag124)
- -- Is_Finalized_Transient (Flag252)
- -- Is_Ignored_Transient (Flag295)
- -- Is_Independent (Flag268)
- -- Is_Return_Object (Flag209)
- -- Is_True_Constant (Flag163)
- -- Is_Uplevel_Referenced_Entity (Flag283)
- -- Is_Volatile (Flag16)
- -- Is_Volatile_Full_Access (Flag285)
- -- Optimize_Alignment_Space (Flag241) (constants only)
- -- Optimize_Alignment_Time (Flag242) (constants only)
- -- SPARK_Pragma_Inherited (Flag265) (constants only)
- -- Stores_Attribute_Old_Prefix (Flag270) (constants only)
- -- Treat_As_Volatile (Flag41)
- -- Address_Clause (synth)
- -- Alignment_Clause (synth)
- -- Is_Elaboration_Target (synth)
- -- Is_Full_Access (synth)
- -- Size_Clause (synth)
+ -- Current_Value (always Empty)
+ -- Discriminal_Link
+ -- Full_View
+ -- Esize
+ -- Extra_Accessibility (constants only)
+ -- Alignment
+ -- Status_Flag_Or_Transient_Decl
+ -- Actual_Subtype
+ -- Renamed_Object
+ -- Renamed_Entity $$$
+ -- Size_Check_Code (constants only)
+ -- Prival_Link (privals only)
+ -- Interface_Name (constants only)
+ -- Related_Type (constants only)
+ -- Initialization_Statements
+ -- BIP_Initialization_Call
+ -- Last_Aggregate_Assignment
+ -- Activation_Record_Component
+ -- Encapsulating_State (constants only)
+ -- Linker_Section_Pragma
+ -- Contract (constants only)
+ -- SPARK_Pragma (constants only)
+ -- Has_Alignment_Clause
+ -- Has_Atomic_Components
+ -- Has_Biased_Representation
+ -- Has_Completion (constants only)
+ -- Has_Independent_Components
+ -- Has_Size_Clause
+ -- Has_Thunks (constants only)
+ -- Has_Volatile_Components
+ -- Is_Atomic
+ -- Is_Elaboration_Checks_OK_Id (constants only)
+ -- Is_Elaboration_Warnings_OK_Id (constants only)
+ -- Is_Eliminated
+ -- Is_Finalized_Transient
+ -- Is_Ignored_Transient
+ -- Is_Independent
+ -- Is_Return_Object
+ -- Is_True_Constant
+ -- Is_Uplevel_Referenced_Entity
+ -- Is_Volatile
+ -- Is_Volatile_Full_Access
+ -- Optimize_Alignment_Space (constants only)
+ -- Optimize_Alignment_Time (constants only)
+ -- SPARK_Pragma_Inherited (constants only)
+ -- Stores_Attribute_Old_Prefix (constants only)
+ -- Treat_As_Volatile
+ -- Address_Clause (synth)
+ -- Alignment_Clause (synth)
+ -- Is_Elaboration_Target (synth)
+ -- Is_Full_Access (synth)
+ -- Size_Clause (synth)
-- E_Decimal_Fixed_Point_Type
- -- E_Decimal_Fixed_Subtype
- -- Scale_Value (Uint16)
- -- Digits_Value (Uint17)
- -- Scalar_Range (Node20)
- -- Delta_Value (Ureal18)
- -- Small_Value (Ureal21)
- -- Static_Real_Or_String_Predicate (Node25)
- -- Has_Machine_Radix_Clause (Flag83)
- -- Machine_Radix_10 (Flag84)
+ -- E_Decimal_Fixed_Subtype$$$no such thing
+ -- Scale_Value
+ -- Digits_Value
+ -- Scalar_Range
+ -- Delta_Value
+ -- Small_Value
+ -- Static_Real_Or_String_Predicate
+ -- Has_Machine_Radix_Clause
+ -- Machine_Radix_10
-- Aft_Value (synth)
-- Type_Low_Bound (synth)
-- Type_High_Bound (synth)
-- (plus type attributes)
-- E_Discriminant
- -- Normalized_First_Bit (Uint8)
- -- Current_Value (Node9) (always Empty)
- -- Normalized_Position_Max (Uint10)
- -- Component_Bit_Offset (Uint11)
- -- Esize (Uint12)
- -- Component_Clause (Node13)
- -- Normalized_Position (Uint14)
- -- Discriminant_Number (Uint15)
- -- Discriminal (Node17)
- -- Renamed_Object (Node18) (always Empty)
- -- Corresponding_Discriminant (Node19)
- -- Discriminant_Default_Value (Node20)
- -- Corresponding_Record_Component (Node21)
- -- Original_Record_Component (Node22)
- -- CR_Discriminant (Node23)
- -- Is_Completely_Hidden (Flag103)
- -- Is_Return_Object (Flag209)
+ -- Normalized_First_Bit
+ -- Current_Value (always Empty)
+ -- Normalized_Position_Max
+ -- Component_Bit_Offset
+ -- Esize
+ -- Component_Clause
+ -- Normalized_Position
+ -- Discriminant_Number
+ -- Discriminal
+ -- Renamed_Object (always Empty)
+ -- Corresponding_Discriminant
+ -- Discriminant_Default_Value
+ -- Corresponding_Record_Component
+ -- Original_Record_Component
+ -- CR_Discriminant
+ -- Is_Completely_Hidden
+ -- Is_Return_Object
+ -- Entry_Formal $$$
+ -- Linker_Section_Pragma $$$
-- Next_Component_Or_Discriminant (synth)
-- Next_Discriminant (synth)
-- Next_Stored_Discriminant (synth)
-- E_Entry
-- E_Entry_Family
- -- Protected_Body_Subprogram (Node11)
- -- Barrier_Function (Node12)
- -- Elaboration_Entity (Node13)
- -- Postconditions_Proc (Node14)
- -- Entry_Parameters_Type (Node15)
- -- First_Entity (Node17)
- -- Alias (Node18) (for entry only. Empty)
- -- Last_Entity (Node20)
- -- Accept_Address (Elist21)
- -- Scope_Depth_Value (Uint22)
- -- Protection_Object (Node23) (protected kind)
- -- Contract_Wrapper (Node25)
- -- Extra_Formals (Node28)
- -- Contract (Node34)
- -- 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)
- -- Is_Elaboration_Warnings_OK_Id (Flag304)
- -- Is_Entry_Wrapper (Flag297)
- -- Needs_No_Actuals (Flag22)
- -- Sec_Stack_Needed_For_Return (Flag167)
- -- SPARK_Pragma_Inherited (Flag265) (protected kind)
- -- Uses_Sec_Stack (Flag95)
- -- Address_Clause (synth)
- -- Entry_Index_Type (synth)
- -- First_Formal (synth)
- -- First_Formal_With_Extras (synth)
- -- Is_Elaboration_Target (synth)
- -- Last_Formal (synth)
- -- Number_Formals (synth)
- -- Scope_Depth (synth)
+ -- Protected_Body_Subprogram
+ -- Barrier_Function
+ -- Elaboration_Entity
+ -- Postconditions_Proc
+ -- Entry_Parameters_Type
+ -- First_Entity
+ -- Alias (for entry only. Empty)
+ -- Last_Entity
+ -- Accept_Address
+ -- Scope_Depth_Value
+ -- Protection_Object (protected kind)
+ -- Contract_Wrapper
+ -- Extra_Formals
+ -- Contract
+ -- SPARK_Pragma (protected kind)
+ -- Default_Expressions_Processed
+ -- Entry_Accepted
+ -- Has_Yield_Aspect
+ -- Has_Expanded_Contract
+ -- Ignore_SPARK_Mode_Pragmas
+ -- Is_Elaboration_Checks_OK_Id
+ -- Is_Elaboration_Warnings_OK_Id
+ -- Is_Entry_Wrapper
+ -- Needs_No_Actuals
+ -- Sec_Stack_Needed_For_Return
+ -- SPARK_Pragma_Inherited (protected kind)
+ -- Uses_Sec_Stack
+ -- Renamed_Entity $$$
+ -- Address_Clause (synth)
+ -- Entry_Index_Type (synth)
+ -- First_Formal (synth)
+ -- First_Formal_With_Extras (synth)
+ -- Is_Elaboration_Target (synth)
+ -- Last_Formal (synth)
+ -- Number_Formals (synth)
+ -- Scope_Depth (synth)
-- E_Entry_Index_Parameter
- -- Entry_Index_Constant (Node18)
+ -- Entry_Index_Constant
-- E_Enumeration_Literal
- -- Enumeration_Pos (Uint11)
- -- Enumeration_Rep (Uint12)
- -- Alias (Node18)
- -- Enumeration_Rep_Expr (Node22)
- -- Next_Literal (synth)
+ -- Enumeration_Pos
+ -- Enumeration_Rep
+ -- Alias
+ -- Enumeration_Rep_Expr
+ -- Interface_Name $$$
+ -- Renamed_Object $$$
+ -- Esize $$$
+ -- Renamed_Entity $$$
+ -- Next_Literal (synth)
-- E_Enumeration_Type
-- E_Enumeration_Subtype
- -- Lit_Strings (Node16) (root type only)
- -- First_Literal (Node17)
- -- Lit_Indexes (Node18) (root type only)
- -- Default_Aspect_Value (Node19) (base type only)
- -- Scalar_Range (Node20)
- -- Enum_Pos_To_Rep (Node23) (type only)
- -- Static_Discrete_Predicate (List25)
- -- Has_Biased_Representation (Flag139)
- -- Has_Contiguous_Rep (Flag181)
- -- Has_Enumeration_Rep_Clause (Flag66)
- -- Has_Pragma_Ordered (Flag198) (base type only)
- -- Nonzero_Is_True (Flag162) (base type only)
- -- No_Predicate_On_Actual (Flag275)
- -- No_Dynamic_Predicate_On_Actual (Flag276)
- -- Type_Low_Bound (synth)
- -- Type_High_Bound (synth)
+ -- First_Entity $$$ type
+ -- Renamed_Object $$$
+ -- Lit_Strings (root type only)
+ -- First_Literal
+ -- Lit_Indexes (root type only)
+ -- Default_Aspect_Value (base type only)
+ -- Scalar_Range
+ -- Lit_Hash (root type only)
+ -- Enum_Pos_To_Rep (type only)
+ -- Static_Discrete_Predicate
+ -- Has_Biased_Representation
+ -- Has_Contiguous_Rep
+ -- Has_Enumeration_Rep_Clause
+ -- Has_Pragma_Ordered (base type only)
+ -- Nonzero_Is_True (base type only)
+ -- No_Predicate_On_Actual
+ -- No_Dynamic_Predicate_On_Actual
+ -- Type_Low_Bound (synth)
+ -- Type_High_Bound (synth)
-- (plus type attributes)
-- E_Exception
- -- Esize (Uint12)
- -- Alignment (Uint14)
- -- Renamed_Entity (Node18)
- -- Register_Exception_Call (Node20)
- -- Interface_Name (Node21)
- -- Activation_Record_Component (Node31)
- -- Discard_Names (Flag88)
- -- Is_Raised (Flag224)
+ -- Esize
+ -- Alignment
+ -- Renamed_Entity
+ -- Register_Exception_Call
+ -- Interface_Name
+ -- Activation_Record_Component
+ -- Discard_Names
+ -- Is_Raised
+ -- Renamed_Object $$$
-- E_Exception_Type
- -- Equivalent_Type (Node18)
+ -- Equivalent_Type
-- (plus type attributes)
-- E_Floating_Point_Type
-- E_Floating_Point_Subtype
- -- Digits_Value (Uint17)
- -- Float_Rep (Uint10) (Float_Rep_Kind)
- -- Default_Aspect_Value (Node19) (base type only)
- -- Scalar_Range (Node20)
- -- Static_Real_Or_String_Predicate (Node25)
- -- Machine_Emax_Value (synth)
- -- Machine_Emin_Value (synth)
- -- Machine_Mantissa_Value (synth)
- -- Machine_Radix_Value (synth)
- -- Model_Emin_Value (synth)
- -- Model_Epsilon_Value (synth)
- -- Model_Mantissa_Value (synth)
- -- Model_Small_Value (synth)
- -- Safe_Emax_Value (synth)
- -- Safe_First_Value (synth)
- -- Safe_Last_Value (synth)
- -- Type_Low_Bound (synth)
- -- Type_High_Bound (synth)
+ -- Digits_Value
+ -- Float_Rep (Float_Rep_Kind)
+ -- Default_Aspect_Value (base type only)
+ -- Scalar_Range
+ -- Static_Real_Or_String_Predicate
+ -- Machine_Emax_Value (synth)
+ -- Machine_Emin_Value (synth)
+ -- Machine_Mantissa_Value (synth)
+ -- Machine_Radix_Value (synth)
+ -- Model_Emin_Value (synth)
+ -- Model_Epsilon_Value (synth)
+ -- Model_Mantissa_Value (synth)
+ -- Model_Small_Value (synth)
+ -- Safe_Emax_Value (synth)
+ -- Safe_First_Value (synth)
+ -- Safe_Last_Value (synth)
+ -- Type_Low_Bound (synth)
+ -- Type_High_Bound (synth)
-- (plus type attributes)
-- E_Function
-- E_Generic_Function
- -- Mechanism (Uint8) (Mechanism_Type)
- -- Renaming_Map (Uint9)
- -- Handler_Records (List10) (non-generic case only)
- -- Protected_Body_Subprogram (Node11)
- -- Next_Inlined_Subprogram (Node12)
- -- Elaboration_Entity (Node13) (not implicit /=)
- -- Postconditions_Proc (Node14) (non-generic case only)
- -- DT_Position (Uint15)
- -- DTC_Entity (Node16)
- -- First_Entity (Node17)
- -- Alias (Node18) (non-generic case only)
- -- Renamed_Entity (Node18)
- -- Extra_Accessibility_Of_Result (Node19) (non-generic case only)
- -- Last_Entity (Node20)
- -- Interface_Name (Node21)
- -- Scope_Depth_Value (Uint22)
- -- Generic_Renamings (Elist23) (for an instance)
- -- Inner_Instances (Elist23) (generic case only)
- -- Protection_Object (Node23) (for concurrent kind)
- -- Subps_Index (Uint24) (non-generic case only)
- -- Interface_Alias (Node25)
- -- Overridden_Operation (Node26)
- -- Wrapped_Entity (Node27) (non-generic case only)
- -- Extra_Formals (Node28)
- -- Anonymous_Masters (Elist29) (non-generic case only)
- -- Corresponding_Equality (Node30) (implicit /= only)
- -- Thunk_Entity (Node31) (thunk case only)
- -- Corresponding_Procedure (Node32) (generate C code only)
- -- Linker_Section_Pragma (Node33)
- -- Contract (Node34)
- -- Import_Pragma (Node35) (non-generic case only)
- -- Class_Wide_Clone (Node38)
- -- Protected_Subprogram (Node39) (non-generic case only)
- -- SPARK_Pragma (Node40)
- -- Original_Protected_Subprogram (Node41)
- -- Body_Needed_For_SAL (Flag40)
- -- Contains_Ignored_Ghost_Code (Flag279)
- -- Default_Expressions_Processed (Flag108)
- -- Delay_Cleanups (Flag114)
- -- Delay_Subprogram_Descriptors (Flag50)
- -- Discard_Names (Flag88)
- -- Elaboration_Entity_Required (Flag174)
- -- Has_Completion (Flag26)
- -- Has_Controlling_Result (Flag98)
- -- Has_Expanded_Contract (Flag240) (non-generic case only)
- -- Has_Master_Entity (Flag21)
- -- Has_Missing_Return (Flag142)
- -- Has_Nested_Block_With_Handler (Flag101)
- -- 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)
- -- Is_Elaboration_Checks_OK_Id (Flag148)
- -- Is_Elaboration_Warnings_OK_Id (Flag304)
- -- Is_Eliminated (Flag124)
- -- Is_Generic_Actual_Subprogram (Flag274) (non-generic case only)
- -- Is_Hidden_Non_Overridden_Subpgm (Flag2) (non-generic case only)
- -- Is_Initial_Condition_Procedure (Flag302) (non-generic case only)
- -- Is_Inlined_Always (Flag1) (non-generic case only)
- -- Is_Instantiated (Flag126) (generic case only)
- -- Is_Intrinsic_Subprogram (Flag64)
- -- Is_Invariant_Procedure (Flag257) (non-generic case only)
- -- Is_Machine_Code_Subprogram (Flag137) (non-generic case only)
- -- Is_Partial_Invariant_Procedure (Flag292) (non-generic case only)
- -- Is_Predicate_Function (Flag255) (non-generic case only)
- -- Is_Predicate_Function_M (Flag256) (non-generic case only)
- -- Is_Primitive (Flag218)
- -- Is_Primitive_Wrapper (Flag195) (non-generic case only)
- -- Is_Private_Descendant (Flag53)
- -- Is_Private_Primitive (Flag245) (non-generic case only)
- -- Is_Pure (Flag44)
- -- Is_Visible_Lib_Unit (Flag116)
- -- Needs_No_Actuals (Flag22)
- -- Requires_Overriding (Flag213) (non-generic case only)
- -- Return_Present (Flag54)
- -- Returns_By_Ref (Flag90)
- -- Rewritten_For_C (Flag287) (generate C code only)
- -- Sec_Stack_Needed_For_Return (Flag167)
- -- SPARK_Pragma_Inherited (Flag265)
- -- Uses_Sec_Stack (Flag95)
- -- Address_Clause (synth)
- -- First_Formal (synth)
- -- First_Formal_With_Extras (synth)
- -- Is_Elaboration_Target (synth)
- -- Last_Formal (synth)
- -- Number_Formals (synth)
- -- Scope_Depth (synth)
+ -- Mechanism (Mechanism_Type)
+ -- Handler_Records (non-generic case only)
+ -- Protected_Body_Subprogram
+ -- Next_Inlined_Subprogram
+ -- Elaboration_Entity (not implicit /=)
+ -- Postconditions_Proc (non-generic case only)
+ -- DT_Position
+ -- DTC_Entity
+ -- First_Entity
+ -- Alias (non-generic case only)
+ -- Renamed_Entity
+ -- Renamed_Object $$$
+ -- Extra_Accessibility_Of_Result (non-generic case only)
+ -- Last_Entity
+ -- Interface_Name
+ -- Scope_Depth_Value
+ -- Generic_Renamings (for an instance)
+ -- Inner_Instances (generic case only)
+ -- Inner_Instances $$$ also E_Function
+ -- Protection_Object (for concurrent kind)
+ -- Subps_Index (non-generic case only)
+ -- Interface_Alias
+ -- LSP_Subprogram (non-generic case only)
+ -- Overridden_Operation
+ -- Wrapped_Entity (non-generic case only)
+ -- Extra_Formals
+ -- Anonymous_Masters (non-generic case only)
+ -- Corresponding_Equality (implicit /= only)
+ -- Thunk_Entity (thunk case only)
+ -- Corresponding_Procedure (generate C code only)
+ -- Linker_Section_Pragma
+ -- Contract
+ -- Import_Pragma (non-generic case only)
+ -- Class_Wide_Clone
+ -- Protected_Subprogram (non-generic case only)
+ -- SPARK_Pragma
+ -- Original_Protected_Subprogram
+ -- Body_Needed_For_SAL
+ -- Contains_Ignored_Ghost_Code
+ -- Default_Expressions_Processed
+ -- Delay_Cleanups
+ -- Delay_Subprogram_Descriptors
+ -- Discard_Names
+ -- Elaboration_Entity_Required
+ -- Has_Completion
+ -- Has_Controlling_Result
+ -- Has_Expanded_Contract (non-generic case only)
+ -- Has_Master_Entity
+ -- Has_Missing_Return
+ -- Has_Nested_Block_With_Handler
+ -- Has_Nested_Subprogram
+ -- Has_Out_Or_In_Out_Parameter
+ -- Has_Recursive_Call
+ -- Has_Yield_Aspect
+ -- Ignore_SPARK_Mode_Pragmas
+ -- Is_Abstract_Subprogram (non-generic case only)
+ -- Is_Called (non-generic case only)
+ -- Is_Constructor
+ -- Is_CUDA_Kernel (non-generic case only)
+ -- Is_DIC_Procedure (non-generic case only)
+ -- Is_Discrim_SO_Function
+ -- Is_Discriminant_Check_Function
+ -- Is_Elaboration_Checks_OK_Id
+ -- Is_Elaboration_Warnings_OK_Id
+ -- Is_Eliminated
+ -- Is_Generic_Actual_Subprogram (non-generic case only)
+ -- Is_Hidden_Non_Overridden_Subpgm (non-generic case only)
+ -- Is_Initial_Condition_Procedure (non-generic case only)
+ -- Is_Inlined_Always (non-generic case only)
+ -- Is_Instantiated (generic case only)
+ -- Is_Intrinsic_Subprogram
+ -- Is_Invariant_Procedure (non-generic case only)
+ -- Is_Machine_Code_Subprogram (non-generic case only)
+ -- Is_Partial_Invariant_Procedure (non-generic case only)
+ -- Is_Predicate_Function (non-generic case only)
+ -- Is_Predicate_Function_M (non-generic case only)
+ -- Is_Primitive
+ -- Is_Primitive_Wrapper (non-generic case only)
+ -- Is_Private_Descendant
+ -- Is_Private_Primitive (non-generic case only)
+ -- Is_Pure
+ -- Is_Visible_Lib_Unit
+ -- Is_Wrapper
+ -- Needs_No_Actuals
+ -- Requires_Overriding (non-generic case only)
+ -- Return_Present
+ -- Returns_By_Ref
+ -- Rewritten_For_C (generate C code only)
+ -- Sec_Stack_Needed_For_Return
+ -- SPARK_Pragma_Inherited
+ -- Uses_Sec_Stack
+ -- Address_Clause (synth)
+ -- First_Formal (synth)
+ -- First_Formal_With_Extras (synth)
+ -- Is_Elaboration_Target (synth)
+ -- Last_Formal (synth)
+ -- Number_Formals (synth)
+ -- Scope_Depth (synth)
-- E_General_Access_Type
- -- Master_Id (Node17)
- -- Directly_Designated_Type (Node20)
- -- Associated_Storage_Pool (Node22) (root type only)
- -- Finalization_Master (Node23) (root type only)
- -- Storage_Size_Variable (Node26) (base type only)
+ -- First_Entity $$$
+ -- Renamed_Entity $$$
+ -- Master_Id
+ -- Directly_Designated_Type
+ -- Associated_Storage_Pool (root type only)
+ -- Finalization_Master (root type only)
+ -- Storage_Size_Variable (base type only)
-- (plus type attributes)
-- E_Generic_In_Parameter
-- E_Generic_In_Out_Parameter
- -- Current_Value (Node9) (always Empty)
- -- Entry_Component (Node11)
- -- Actual_Subtype (Node17)
- -- Renamed_Object (Node18) (always Empty)
- -- Default_Value (Node20)
- -- Protected_Formal (Node22)
- -- Is_Controlling_Formal (Flag97)
- -- Is_Return_Object (Flag209)
- -- Parameter_Mode (synth)
+ -- Current_Value (always Empty)
+ -- Entry_Component
+ -- Actual_Subtype
+ -- Renamed_Object (always Empty)
+ -- Default_Value
+ -- Protected_Formal
+ -- Is_Controlling_Formal
+ -- Is_Return_Object
+ -- Parameter_Mode (synth)
-- E_Incomplete_Type
-- E_Incomplete_Subtype
- -- Direct_Primitive_Operations (Elist10)
- -- Non_Limited_View (Node19)
- -- Private_Dependents (Elist18)
- -- Discriminant_Constraint (Elist21)
- -- Stored_Constraint (Elist23)
- -- Has_Non_Limited_View (synth)
+ -- Direct_Primitive_Operations
+ -- Non_Limited_View
+ -- Private_Dependents
+ -- Discriminant_Constraint
+ -- Stored_Constraint
+ -- First_Entity $$$
+ -- Last_Entity $$$
+ -- Has_Non_Limited_View (synth)
-- (plus type attributes)
-- E_In_Parameter
-- E_In_Out_Parameter
-- E_Out_Parameter
- -- Mechanism (Uint8) (Mechanism_Type)
- -- Current_Value (Node9)
- -- Discriminal_Link (Node10) (discriminals only)
- -- Entry_Component (Node11)
- -- Esize (Uint12)
- -- Extra_Accessibility (Node13)
- -- Alignment (Uint14)
- -- Extra_Formal (Node15)
- -- Unset_Reference (Node16)
- -- Actual_Subtype (Node17)
- -- Renamed_Object (Node18)
- -- Spec_Entity (Node19)
- -- Default_Value (Node20)
- -- Default_Expr_Function (Node21)
- -- Protected_Formal (Node22)
- -- Extra_Constrained (Node23)
- -- Minimum_Accessibility (Node24)
- -- Last_Assignment (Node26) (OUT, IN-OUT only)
- -- Activation_Record_Component (Node31)
- -- Has_Initial_Value (Flag219)
- -- Is_Controlling_Formal (Flag97)
- -- Is_Only_Out_Parameter (Flag226)
- -- Low_Bound_Tested (Flag205)
- -- Is_Return_Object (Flag209)
- -- Is_Activation_Record (Flag305)
- -- Parameter_Mode (synth)
+ -- Linker_Section_Pragma $$$
+ -- Mechanism (Mechanism_Type)
+ -- Current_Value
+ -- Discriminal_Link (discriminals only)
+ -- Entry_Component
+ -- Esize
+ -- Extra_Accessibility
+ -- Alignment
+ -- Extra_Formal
+ -- Unset_Reference
+ -- Actual_Subtype
+ -- Renamed_Object
+ -- Spec_Entity
+ -- Default_Value
+ -- Default_Expr_Function
+ -- Protected_Formal
+ -- Extra_Constrained
+ -- Minimum_Accessibility
+ -- Last_Assignment (OUT, IN-OUT only)
+ -- Activation_Record_Component
+ -- Has_Initial_Value
+ -- Is_Controlling_Formal
+ -- Is_Only_Out_Parameter
+ -- Low_Bound_Tested
+ -- Is_Return_Object
+ -- Is_Activation_Record
+ -- Parameter_Mode (synth)
-- E_Label
- -- Enclosing_Scope (Node18)
- -- Reachable (Flag49)
+ -- Renamed_Object $$$
+ -- Renamed_Entity $$$
+ -- Enclosing_Scope
+ -- Reachable
-- E_Limited_Private_Type
-- E_Limited_Private_Subtype
- -- First_Entity (Node17)
- -- Private_Dependents (Elist18)
- -- Underlying_Full_View (Node19)
- -- Last_Entity (Node20)
- -- Discriminant_Constraint (Elist21)
- -- Stored_Constraint (Elist23)
- -- Has_Completion (Flag26)
+ -- Scalar_Range $$$ type
+ -- First_Entity
+ -- Private_Dependents
+ -- Underlying_Full_View
+ -- Last_Entity
+ -- Discriminant_Constraint
+ -- Stored_Constraint
+ -- Has_Completion
-- (plus type attributes)
-- E_Loop
- -- First_Exit_Statement (Node8)
- -- Has_Exit (Flag47)
- -- Has_Loop_Entry_Attributes (Flag260)
- -- Has_Master_Entity (Flag21)
- -- Has_Nested_Block_With_Handler (Flag101)
- -- Uses_Sec_Stack (Flag95)
+ -- First_Exit_Statement
+ -- Has_Exit
+ -- Has_Loop_Entry_Attributes
+ -- Has_Master_Entity
+ -- Has_Nested_Block_With_Handler
+ -- Uses_Sec_Stack
+ -- First_Entity $$$
+ -- Last_Entity $$$
+ -- Renamed_Object $$$
-- E_Modular_Integer_Type
-- E_Modular_Integer_Subtype
- -- Modulus (Uint17) (base type only)
- -- Default_Aspect_Value (Node19) (base type only)
- -- Original_Array_Type (Node21)
- -- Scalar_Range (Node20)
- -- Static_Discrete_Predicate (List25)
- -- Non_Binary_Modulus (Flag58) (base type only)
- -- Has_Biased_Representation (Flag139)
- -- Has_Shift_Operator (Flag267) (base type only)
- -- No_Predicate_On_Actual (Flag275)
- -- No_Dynamic_Predicate_On_Actual (Flag276)
- -- Type_Low_Bound (synth)
- -- Type_High_Bound (synth)
+ -- Modulus (base type only)
+ -- Default_Aspect_Value (base type only)
+ -- Original_Array_Type
+ -- Scalar_Range
+ -- Static_Discrete_Predicate
+ -- Non_Binary_Modulus (base type only)
+ -- Has_Biased_Representation
+ -- Has_Shift_Operator (base type only)
+ -- No_Predicate_On_Actual
+ -- No_Dynamic_Predicate_On_Actual
+ -- Type_Low_Bound (synth)
+ -- Type_High_Bound (synth)
-- (plus type attributes)
-- E_Named_Integer
+ -- Renamed_Object $$$
-- E_Named_Real
-- E_Operator
- -- First_Entity (Node17)
- -- Alias (Node18)
- -- Extra_Accessibility_Of_Result (Node19)
- -- Last_Entity (Node20)
- -- Subps_Index (Uint24)
- -- Overridden_Operation (Node26)
- -- Linker_Section_Pragma (Node33)
- -- Contract (Node34)
- -- Import_Pragma (Node35)
- -- SPARK_Pragma (Node40)
- -- Default_Expressions_Processed (Flag108)
- -- Has_Nested_Subprogram (Flag282)
- -- Ignore_SPARK_Mode_Pragmas (Flag301)
- -- Is_Elaboration_Checks_OK_Id (Flag148)
- -- Is_Elaboration_Warnings_OK_Id (Flag304)
- -- Is_Intrinsic_Subprogram (Flag64)
- -- Is_Machine_Code_Subprogram (Flag137)
- -- Is_Primitive (Flag218)
- -- Is_Pure (Flag44)
- -- SPARK_Pragma_Inherited (Flag265)
- -- Is_Elaboration_Target (synth)
+ -- First_Entity
+ -- Alias
+ -- Extra_Accessibility_Of_Result
+ -- Last_Entity
+ -- Subps_Index
+ -- Overridden_Operation
+ -- Linker_Section_Pragma
+ -- Contract
+ -- Import_Pragma
+ -- LSP_Subprogram
+ -- SPARK_Pragma
+ -- Default_Expressions_Processed
+ -- Has_Nested_Subprogram
+ -- Ignore_SPARK_Mode_Pragmas
+ -- Is_Elaboration_Checks_OK_Id
+ -- Is_Elaboration_Warnings_OK_Id
+ -- Is_Intrinsic_Subprogram
+ -- Is_Machine_Code_Subprogram
+ -- Is_Primitive
+ -- Is_Pure
+ -- Is_Wrapper
+ -- SPARK_Pragma_Inherited
+ -- Interface_Name $$$
+ -- Renamed_Entity $$$
+ -- Renamed_Object $$$
+ -- Is_Elaboration_Target (synth)
-- Aren't there more flags and fields? seems like this list should be
-- more similar to the E_Function list, which is much longer ???
-- E_Ordinary_Fixed_Point_Type
-- E_Ordinary_Fixed_Point_Subtype
- -- Delta_Value (Ureal18)
- -- Default_Aspect_Value (Node19) (base type only)
- -- Scalar_Range (Node20)
- -- Static_Real_Or_String_Predicate (Node25)
- -- Small_Value (Ureal21)
- -- Has_Small_Clause (Flag67)
- -- Aft_Value (synth)
- -- Type_Low_Bound (synth)
- -- Type_High_Bound (synth)
+ -- Delta_Value
+ -- Default_Aspect_Value (base type only)
+ -- Scalar_Range
+ -- Static_Real_Or_String_Predicate
+ -- Small_Value
+ -- Has_Small_Clause
+ -- Aft_Value (synth)
+ -- Type_Low_Bound (synth)
+ -- Type_High_Bound (synth)
-- (plus type attributes)
-- E_Package
-- E_Generic_Package
- -- Dependent_Instances (Elist8) (for an instance)
- -- Renaming_Map (Uint9)
- -- Handler_Records (List10) (non-generic case only)
- -- Generic_Homonym (Node11) (generic case only)
- -- Associated_Formal_Package (Node12)
- -- Elaboration_Entity (Node13)
- -- Related_Instance (Node15) (non-generic case only)
- -- First_Private_Entity (Node16)
- -- First_Entity (Node17)
- -- Renamed_Entity (Node18)
- -- Body_Entity (Node19)
- -- Last_Entity (Node20)
- -- Interface_Name (Node21)
- -- Scope_Depth_Value (Uint22)
- -- Generic_Renamings (Elist23) (for an instance)
- -- Inner_Instances (Elist23) (generic case only)
- -- Limited_View (Node23) (non-generic/instance)
- -- Incomplete_Actuals (Elist24) (for an instance)
- -- Abstract_States (Elist25)
- -- Package_Instantiation (Node26)
- -- Current_Use_Clause (Node27)
- -- Finalizer (Node28) (non-generic case only)
- -- Anonymous_Masters (Elist29) (non-generic case only)
- -- Contract (Node34)
- -- SPARK_Pragma (Node40)
- -- SPARK_Aux_Pragma (Node41)
- -- Body_Needed_For_Inlining (Flag299)
- -- Body_Needed_For_SAL (Flag40)
- -- Contains_Ignored_Ghost_Code (Flag279)
- -- Delay_Subprogram_Descriptors (Flag50)
- -- Discard_Names (Flag88)
- -- Elaborate_Body_Desirable (Flag210) (non-generic case only)
- -- Elaboration_Entity_Required (Flag174)
- -- From_Limited_With (Flag159)
- -- Has_All_Calls_Remote (Flag79)
- -- Has_Completion (Flag26)
- -- Has_Forward_Instantiation (Flag175)
- -- Has_Master_Entity (Flag21)
- -- Has_RACW (Flag214) (non-generic case only)
- -- Ignore_SPARK_Mode_Pragmas (Flag301)
- -- Is_Called (Flag102) (non-generic case only)
- -- Is_Elaboration_Checks_OK_Id (Flag148)
- -- Is_Elaboration_Warnings_OK_Id (Flag304)
- -- Is_Instantiated (Flag126)
- -- In_Package_Body (Flag48)
- -- Is_Private_Descendant (Flag53)
- -- In_Use (Flag8)
- -- Is_Visible_Lib_Unit (Flag116)
- -- Renamed_In_Spec (Flag231) (non-generic case only)
- -- SPARK_Aux_Pragma_Inherited (Flag266)
- -- SPARK_Pragma_Inherited (Flag265)
- -- Static_Elaboration_Desired (Flag77) (non-generic case only)
- -- Has_Non_Null_Abstract_State (synth)
- -- Has_Null_Abstract_State (synth)
- -- Is_Elaboration_Target (synth)
- -- Is_Wrapper_Package (synth) (non-generic case only)
- -- Has_Limited_View (synth) (non-generic case only)
- -- Scope_Depth (synth)
+ -- Dependent_Instances (for an instance)
+ -- Handler_Records (non-generic case only)
+ -- Generic_Homonym (generic case only)
+ -- Associated_Formal_Package
+ -- Elaboration_Entity
+ -- Related_Instance (non-generic case only)
+ -- First_Private_Entity
+ -- First_Entity
+ -- Renamed_Entity
+ -- Renamed_Object $$$
+ -- Body_Entity
+ -- Last_Entity
+ -- Interface_Name
+ -- Scope_Depth_Value
+ -- Generic_Renamings (for an instance)
+ -- Inner_Instances (generic case only)
+ -- Inner_Instances $$$ also E_Package
+ -- Limited_View (non-generic/instance)
+ -- Incomplete_Actuals (for an instance)
+ -- Abstract_States
+ -- Package_Instantiation
+ -- Current_Use_Clause
+ -- Finalizer (non-generic case only)
+ -- Anonymous_Masters (non-generic case only)
+ -- Contract
+ -- SPARK_Pragma
+ -- SPARK_Aux_Pragma
+ -- Body_Needed_For_Inlining
+ -- Body_Needed_For_SAL
+ -- Contains_Ignored_Ghost_Code
+ -- Delay_Subprogram_Descriptors
+ -- Discard_Names
+ -- Elaborate_Body_Desirable (non-generic case only)
+ -- Elaboration_Entity_Required
+ -- From_Limited_With
+ -- Has_All_Calls_Remote
+ -- Has_Completion
+ -- Has_Forward_Instantiation
+ -- Has_Master_Entity
+ -- Has_RACW (non-generic case only)
+ -- Ignore_SPARK_Mode_Pragmas
+ -- Is_Called (non-generic case only)
+ -- Is_Elaboration_Checks_OK_Id
+ -- Is_Elaboration_Warnings_OK_Id
+ -- Is_Instantiated
+ -- In_Package_Body
+ -- Is_Private_Descendant
+ -- In_Use
+ -- Is_Visible_Lib_Unit
+ -- Renamed_In_Spec (non-generic case only)
+ -- SPARK_Aux_Pragma_Inherited
+ -- SPARK_Pragma_Inherited
+ -- Static_Elaboration_Desired (non-generic case only)
+ -- Renamed_Object $$$
+ -- Has_Non_Null_Abstract_State (synth)
+ -- Has_Null_Abstract_State (synth)
+ -- Is_Elaboration_Target (synth)
+ -- Is_Wrapper_Package (synth) (non-generic case only)
+ -- Has_Limited_View (synth) (non-generic case only)
+ -- Scope_Depth (synth)
-- E_Package_Body
- -- Handler_Records (List10) (non-generic case only)
- -- Related_Instance (Node15) (non-generic case only)
- -- First_Entity (Node17)
- -- Spec_Entity (Node19)
- -- Last_Entity (Node20)
- -- Scope_Depth_Value (Uint22)
- -- Finalizer (Node28) (non-generic case only)
- -- Contract (Node34)
- -- SPARK_Pragma (Node40)
- -- SPARK_Aux_Pragma (Node41)
- -- Contains_Ignored_Ghost_Code (Flag279)
- -- Delay_Subprogram_Descriptors (Flag50)
- -- Ignore_SPARK_Mode_Pragmas (Flag301)
- -- SPARK_Aux_Pragma_Inherited (Flag266)
- -- SPARK_Pragma_Inherited (Flag265)
- -- Scope_Depth (synth)
+ -- Handler_Records (non-generic case only)
+ -- Related_Instance (non-generic case only)
+ -- First_Entity
+ -- Spec_Entity
+ -- Last_Entity
+ -- Scope_Depth_Value
+ -- Finalizer (non-generic case only)
+ -- Contract
+ -- SPARK_Pragma
+ -- SPARK_Aux_Pragma
+ -- Contains_Ignored_Ghost_Code
+ -- Delay_Subprogram_Descriptors
+ -- Ignore_SPARK_Mode_Pragmas
+ -- SPARK_Aux_Pragma_Inherited
+ -- SPARK_Pragma_Inherited
+ -- Renamed_Entity $$$
+ -- Scope_Depth (synth)
-- E_Private_Type
-- E_Private_Subtype
- -- Direct_Primitive_Operations (Elist10)
- -- First_Entity (Node17)
- -- Private_Dependents (Elist18)
- -- Underlying_Full_View (Node19)
- -- Last_Entity (Node20)
- -- Discriminant_Constraint (Elist21)
- -- Stored_Constraint (Elist23)
- -- Has_Completion (Flag26)
- -- Is_Controlled_Active (Flag42) (base type only)
+ -- Scalar_Range $$$ type
+ -- Direct_Primitive_Operations
+ -- First_Entity
+ -- Private_Dependents
+ -- Underlying_Full_View
+ -- Last_Entity
+ -- Discriminant_Constraint
+ -- Stored_Constraint
+ -- Has_Completion
+ -- Is_Controlled_Active (base type only)
+ -- $$$above in (plus type attributes)
-- (plus type attributes)
-- E_Procedure
-- E_Generic_Procedure
- -- Renaming_Map (Uint9)
- -- Handler_Records (List10) (non-generic case only)
- -- Protected_Body_Subprogram (Node11)
- -- Next_Inlined_Subprogram (Node12)
- -- Elaboration_Entity (Node13)
- -- Postconditions_Proc (Node14) (non-generic case only)
- -- DT_Position (Uint15)
- -- DTC_Entity (Node16)
- -- First_Entity (Node17)
- -- Alias (Node18) (non-generic case only)
- -- Renamed_Entity (Node18)
- -- Receiving_Entry (Node19) (non-generic case only)
- -- Last_Entity (Node20)
- -- Interface_Name (Node21)
- -- Scope_Depth_Value (Uint22)
- -- Generic_Renamings (Elist23) (for an instance)
- -- Inner_Instances (Elist23) (generic case only)
- -- Protection_Object (Node23) (for concurrent kind)
- -- Subps_Index (Uint24) (non-generic case only)
- -- Interface_Alias (Node25)
- -- Overridden_Operation (Node26) (never for init proc)
- -- Wrapped_Entity (Node27) (non-generic case only)
- -- Extra_Formals (Node28)
- -- Anonymous_Masters (Elist29) (non-generic case only)
- -- Static_Initialization (Node30) (init_proc only)
- -- Thunk_Entity (Node31) (thunk case only)
- -- Corresponding_Function (Node32) (generate C code only)
- -- Linker_Section_Pragma (Node33)
- -- Contract (Node34)
- -- Import_Pragma (Node35) (non-generic case only)
- -- Class_Wide_Clone (Node38)
- -- Protected_Subprogram (Node39) (non-generic case only)
- -- SPARK_Pragma (Node40)
- -- Original_Protected_Subprogram (Node41)
- -- Body_Needed_For_SAL (Flag40)
- -- Contains_Ignored_Ghost_Code (Flag279)
- -- Delay_Cleanups (Flag114)
- -- Discard_Names (Flag88)
- -- Elaboration_Entity_Required (Flag174)
- -- Default_Expressions_Processed (Flag108)
- -- Delay_Cleanups (Flag114)
- -- Delay_Subprogram_Descriptors (Flag50)
- -- Discard_Names (Flag88)
- -- Has_Completion (Flag26)
- -- Has_Expanded_Contract (Flag240) (non-generic case only)
- -- 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)
- -- Is_Eliminated (Flag124)
- -- Is_Generic_Actual_Subprogram (Flag274) (non-generic case only)
- -- Is_Hidden_Non_Overridden_Subpgm (Flag2) (non-generic case only)
- -- Is_Initial_Condition_Procedure (Flag302) (non-generic case only)
- -- Is_Inlined_Always (Flag1) (non-generic case only)
- -- Is_Instantiated (Flag126) (generic case only)
- -- Is_Interrupt_Handler (Flag89)
- -- Is_Intrinsic_Subprogram (Flag64)
- -- Is_Invariant_Procedure (Flag257) (non-generic case only)
- -- Is_Machine_Code_Subprogram (Flag137) (non-generic case only)
- -- Is_Null_Init_Proc (Flag178)
- -- Is_Partial_DIC_Procedure (synth) (non-generic case only)
- -- Is_Partial_Invariant_Procedure (Flag292) (non-generic case only)
- -- Is_Predicate_Function (Flag255) (non-generic case only)
- -- Is_Predicate_Function_M (Flag256) (non-generic case only)
- -- Is_Primitive (Flag218)
- -- Is_Primitive_Wrapper (Flag195) (non-generic case only)
- -- Is_Private_Descendant (Flag53)
- -- Is_Private_Primitive (Flag245) (non-generic case only)
- -- Is_Pure (Flag44)
- -- Is_Valued_Procedure (Flag127)
- -- Is_Visible_Lib_Unit (Flag116)
- -- Needs_No_Actuals (Flag22)
- -- No_Return (Flag113)
- -- Requires_Overriding (Flag213) (non-generic case only)
- -- Sec_Stack_Needed_For_Return (Flag167)
- -- SPARK_Pragma_Inherited (Flag265)
- -- Address_Clause (synth)
- -- First_Formal (synth)
- -- First_Formal_With_Extras (synth)
- -- Is_Elaboration_Target (synth)
- -- Is_Finalizer (synth)
- -- Last_Formal (synth)
- -- Number_Formals (synth)
+ -- Associated_Node_For_Itype $$$ E_Procedure
+ -- Handler_Records (non-generic case only)
+ -- Protected_Body_Subprogram
+ -- Next_Inlined_Subprogram
+ -- Elaboration_Entity
+ -- Postconditions_Proc (non-generic case only)
+ -- DT_Position
+ -- DTC_Entity
+ -- First_Entity
+ -- Alias (non-generic case only)
+ -- Renamed_Entity
+ -- Renamed_Object $$$
+ -- Receiving_Entry (non-generic case only)
+ -- Last_Entity
+ -- Interface_Name
+ -- Scope_Depth_Value
+ -- Generic_Renamings (for an instance)
+ -- Inner_Instances (generic case only)
+ -- Inner_Instances $$$ also E_Procedure
+ -- Protection_Object (for concurrent kind)
+ -- Subps_Index (non-generic case only)
+ -- Interface_Alias
+ -- LSP_Subprogram (non-generic case only)
+ -- Overridden_Operation (never for init proc)
+ -- Wrapped_Entity (non-generic case only)
+ -- Extra_Formals
+ -- Anonymous_Masters (non-generic case only)
+ -- Static_Initialization (init_proc only)
+ -- Thunk_Entity (thunk case only)
+ -- Corresponding_Function (generate C code only)
+ -- Linker_Section_Pragma
+ -- Contract
+ -- Import_Pragma (non-generic case only)
+ -- Class_Wide_Clone
+ -- Protected_Subprogram (non-generic case only)
+ -- SPARK_Pragma
+ -- Original_Protected_Subprogram
+ -- Body_Needed_For_SAL
+ -- Contains_Ignored_Ghost_Code
+ -- Delay_Cleanups $$$Dup below
+ -- Discard_Names $$$Dup below
+ -- Elaboration_Entity_Required
+ -- Default_Expressions_Processed
+ -- Delay_Cleanups
+ -- Delay_Subprogram_Descriptors
+ -- Discard_Names
+ -- Has_Completion
+ -- Has_Expanded_Contract (non-generic case only)
+ -- Has_Master_Entity
+ -- Has_Nested_Block_With_Handler
+ -- Has_Nested_Subprogram
+ -- Has_Yield_Aspect
+ -- Ignore_SPARK_Mode_Pragmas
+ -- Is_Abstract_Subprogram (non-generic case only)
+ -- Is_Asynchronous
+ -- Is_Called (non-generic case only)
+ -- Is_Constructor
+ -- Is_CUDA_Kernel
+ -- Is_DIC_Procedure (non-generic case only)
+ -- Is_Elaboration_Checks_OK_Id
+ -- Is_Elaboration_Warnings_OK_Id
+ -- Is_Eliminated
+ -- Is_Generic_Actual_Subprogram (non-generic case only)
+ -- Is_Hidden_Non_Overridden_Subpgm (non-generic case only)
+ -- Is_Initial_Condition_Procedure (non-generic case only)
+ -- Is_Inlined_Always (non-generic case only)
+ -- Is_Instantiated (generic case only)
+ -- Is_Interrupt_Handler
+ -- Is_Intrinsic_Subprogram
+ -- Is_Invariant_Procedure (non-generic case only)
+ -- Is_Machine_Code_Subprogram (non-generic case only)
+ -- Is_Null_Init_Proc
+ -- Is_Partial_DIC_Procedure (synth) (non-generic case only)
+ -- Is_Partial_Invariant_Procedure (non-generic case only)
+ -- Is_Predicate_Function (non-generic case only)
+ -- Is_Predicate_Function_M (non-generic case only)
+ -- Is_Primitive
+ -- Is_Primitive_Wrapper (non-generic case only)
+ -- Is_Private_Descendant
+ -- Is_Private_Primitive (non-generic case only)
+ -- Is_Pure
+ -- Is_Wrapper
+ -- Is_Valued_Procedure
+ -- Is_Visible_Lib_Unit
+ -- Needs_No_Actuals
+ -- No_Return
+ -- Requires_Overriding (non-generic case only)
+ -- Sec_Stack_Needed_For_Return
+ -- SPARK_Pragma_Inherited
+ -- Entry_Parameters_Type $$$
+ -- Address_Clause (synth)
+ -- First_Formal (synth)
+ -- First_Formal_With_Extras (synth)
+ -- Is_Elaboration_Target (synth)
+ -- Is_Finalizer (synth)
+ -- Last_Formal (synth)
+ -- Number_Formals (synth)
-- E_Protected_Body
- -- SPARK_Pragma (Node40)
- -- Ignore_SPARK_Mode_Pragmas (Flag301)
- -- SPARK_Pragma_Inherited (Flag265)
+ -- SPARK_Pragma
+ -- Ignore_SPARK_Mode_Pragmas
+ -- SPARK_Pragma_Inherited
-- (any others??? First/Last Entity, Scope_Depth???)
- -- E_Protected_Object
+ -- E_Protected_Object$$$No such thing
-- E_Protected_Type
-- E_Protected_Subtype
- -- Direct_Primitive_Operations (Elist10)
- -- First_Private_Entity (Node16)
- -- First_Entity (Node17)
- -- Corresponding_Record_Type (Node18)
- -- Entry_Bodies_Array (Node19)
- -- Last_Entity (Node20)
- -- Discriminant_Constraint (Elist21)
- -- Scope_Depth_Value (Uint22)
- -- Stored_Constraint (Elist23)
- -- Anonymous_Object (Node30)
- -- Contract (Node34)
- -- Entry_Max_Queue_Lengths_Array (Node35)
- -- SPARK_Aux_Pragma (Node41)
- -- Ignore_SPARK_Mode_Pragmas (Flag301)
- -- SPARK_Aux_Pragma_Inherited (Flag266)
- -- Uses_Lock_Free (Flag188)
- -- First_Component (synth)
- -- First_Component_Or_Discriminant (synth)
- -- Has_Entries (synth)
- -- Has_Interrupt_Handler (synth)
- -- Number_Entries (synth)
- -- Scope_Depth (synth)
+ -- Direct_Primitive_Operations
+ -- First_Private_Entity
+ -- First_Entity
+ -- Corresponding_Record_Type
+ -- Entry_Bodies_Array
+ -- Last_Entity
+ -- Discriminant_Constraint
+ -- Scope_Depth_Value
+ -- Stored_Constraint
+ -- Anonymous_Object
+ -- Contract
+ -- Entry_Max_Queue_Lengths_Array
+ -- SPARK_Aux_Pragma
+ -- Ignore_SPARK_Mode_Pragmas
+ -- SPARK_Aux_Pragma_Inherited
+ -- Uses_Lock_Free
+ -- First_Component (synth)
+ -- First_Component_Or_Discriminant (synth)
+ -- Has_Entries (synth)
+ -- Has_Interrupt_Handler (synth)
+ -- Number_Entries (synth)
+ -- Scope_Depth (synth)
-- (plus type attributes)
-- E_Record_Type
-- E_Record_Subtype
- -- Direct_Primitive_Operations (Elist10)
- -- Access_Disp_Table (Elist16) (base type only)
- -- Cloned_Subtype (Node16) (subtype case only)
- -- First_Entity (Node17)
- -- Corresponding_Concurrent_Type (Node18)
- -- Parent_Subtype (Node19) (base type only)
- -- Last_Entity (Node20)
- -- Discriminant_Constraint (Elist21)
- -- Corresponding_Remote_Type (Node22)
- -- Stored_Constraint (Elist23)
- -- Interfaces (Elist25)
- -- Dispatch_Table_Wrappers (Elist26) (base type only)
- -- Underlying_Record_View (Node28) (base type only)
- -- Access_Disp_Table_Elab_Flag (Node30) (base type only)
- -- Predicated_Parent (Node38) (subtype only)
- -- Component_Alignment (special) (base type only)
- -- C_Pass_By_Copy (Flag125) (base type only)
- -- Has_Dispatch_Table (Flag220) (base tagged type only)
- -- Has_Pragma_Pack (Flag121) (impl base type only)
- -- Has_Private_Ancestor (Flag151)
- -- Has_Private_Extension (Flag300)
- -- Has_Record_Rep_Clause (Flag65) (base type only)
- -- Has_Static_Discriminants (Flag211) (subtype only)
- -- Is_Class_Wide_Equivalent_Type (Flag35)
- -- Is_Concurrent_Record_Type (Flag20)
- -- Is_Constrained (Flag12)
- -- Is_Controlled_Active (Flag42) (base type only)
- -- Is_Interface (Flag186)
- -- Is_Limited_Interface (Flag197)
- -- No_Reordering (Flag239) (base type only)
- -- Reverse_Bit_Order (Flag164) (base type only)
- -- Reverse_Storage_Order (Flag93) (base type only)
- -- SSO_Set_High_By_Default (Flag273) (base type only)
- -- SSO_Set_Low_By_Default (Flag272) (base type only)
- -- First_Component (synth)
- -- First_Component_Or_Discriminant (synth)
+ -- Renamed_Entity $$$ type
+ -- Interface_Name $$$ type
+ -- Direct_Primitive_Operations
+ -- Access_Disp_Table (base type only)
+ -- Cloned_Subtype (subtype case only)
+ -- First_Entity
+ -- Corresponding_Concurrent_Type
+ -- Parent_Subtype (base type only)
+ -- Last_Entity
+ -- Discriminant_Constraint
+ -- Corresponding_Remote_Type
+ -- Stored_Constraint
+ -- Interfaces
+ -- Dispatch_Table_Wrappers (base type only)
+ -- Underlying_Record_View (base type only)
+ -- Access_Disp_Table_Elab_Flag (base type only)
+ -- Predicated_Parent (subtype only)
+ -- Component_Alignment (special) (base type only)
+ -- C_Pass_By_Copy (base type only)
+ -- Has_Dispatch_Table (base tagged type only)
+ -- Has_Pragma_Pack (impl base type only)
+ -- Has_Private_Ancestor
+ -- Has_Private_Extension
+ -- Has_Record_Rep_Clause (base type only)
+ -- Has_Static_Discriminants (subtype only)
+ -- Is_Class_Wide_Equivalent_Type
+ -- Is_Concurrent_Record_Type
+ -- Is_Constrained
+ -- Is_Controlled_Active (base type only)
+ -- $$$above in (plus type attributes)
+ -- Is_Interface
+ -- Is_Limited_Interface
+ -- No_Reordering (base type only)
+ -- Reverse_Bit_Order (base type only)
+ -- Reverse_Storage_Order (base type only)
+ -- SSO_Set_High_By_Default (base type only)
+ -- SSO_Set_Low_By_Default (base type only)
+ -- First_Component (synth)
+ -- First_Component_Or_Discriminant (synth)
-- (plus type attributes)
-- E_Record_Type_With_Private
-- E_Record_Subtype_With_Private
- -- Direct_Primitive_Operations (Elist10)
- -- First_Entity (Node17)
- -- Private_Dependents (Elist18)
- -- Underlying_Full_View (Node19)
- -- Last_Entity (Node20)
- -- Discriminant_Constraint (Elist21)
- -- Stored_Constraint (Elist23)
- -- Interfaces (Elist25)
- -- Predicated_Parent (Node38) (subtype only)
- -- Has_Completion (Flag26)
- -- Has_Private_Ancestor (Flag151)
- -- Has_Private_Extension (Flag300)
- -- Has_Record_Rep_Clause (Flag65) (base type only)
- -- Is_Concurrent_Record_Type (Flag20)
- -- Is_Constrained (Flag12)
- -- Is_Controlled_Active (Flag42) (base type only)
- -- Is_Interface (Flag186)
- -- Is_Limited_Interface (Flag197)
- -- No_Reordering (Flag239) (base type only)
- -- Reverse_Bit_Order (Flag164) (base type only)
- -- Reverse_Storage_Order (Flag93) (base type only)
- -- SSO_Set_High_By_Default (Flag273) (base type only)
- -- SSO_Set_Low_By_Default (Flag272) (base type only)
- -- First_Component (synth)
- -- First_Component_Or_Discriminant (synth)
+ -- Corresponding_Remote_Type $$$ E_Record_Subtype_With_Private
+ -- Direct_Primitive_Operations
+ -- First_Entity
+ -- Private_Dependents
+ -- Underlying_Full_View
+ -- Last_Entity
+ -- Discriminant_Constraint
+ -- Stored_Constraint
+ -- Interfaces
+ -- Underlying_Record_View $$$ (base type only)
+ -- Predicated_Parent (subtype only)
+ -- Has_Completion
+ -- Has_Private_Ancestor
+ -- Has_Private_Extension
+ -- Has_Record_Rep_Clause (base type only)
+ -- Is_Concurrent_Record_Type
+ -- Is_Constrained
+ -- Is_Controlled_Active (base type only)
+ -- $$$above in (plus type attributes)
+ -- Is_Interface
+ -- Is_Limited_Interface
+ -- No_Reordering (base type only)
+ -- Reverse_Bit_Order (base type only)
+ -- Reverse_Storage_Order (base type only)
+ -- SSO_Set_High_By_Default (base type only)
+ -- SSO_Set_Low_By_Default (base type only)
+ -- Corresponding_Remote_Type $$$ type
+ -- First_Component (synth)
+ -- First_Component_Or_Discriminant (synth)
-- (plus type attributes)
-- E_Return_Statement
- -- Return_Applies_To (Node8)
+ -- Return_Applies_To
+ -- First_Entity $$$
+ -- Last_Entity $$$
-- E_Signed_Integer_Type
-- E_Signed_Integer_Subtype
- -- Default_Aspect_Value (Node19) (base type only)
- -- Scalar_Range (Node20)
- -- Static_Discrete_Predicate (List25)
- -- Has_Biased_Representation (Flag139)
- -- Has_Shift_Operator (Flag267) (base type only)
- -- No_Predicate_On_Actual (Flag275)
- -- No_Dynamic_Predicate_On_Actual (Flag276)
- -- Type_Low_Bound (synth)
- -- Type_High_Bound (synth)
+ -- Renamed_Object $$$ subtype
+ -- Interface_Name $$$ subtype
+ -- Direct_Primitive_Operations $$$ type
+ -- First_Entity $$$
+ -- Default_Aspect_Value (base type only)
+ -- Scalar_Range
+ -- Static_Discrete_Predicate
+ -- Has_Biased_Representation
+ -- Has_Shift_Operator (base type only)
+ -- No_Predicate_On_Actual
+ -- No_Dynamic_Predicate_On_Actual
+ -- Type_Low_Bound (synth)
+ -- Type_High_Bound (synth)
-- (plus type attributes)
-- E_String_Literal_Subtype
- -- String_Literal_Length (Uint16)
- -- First_Index (Node17) (always Empty)
- -- String_Literal_Low_Bound (Node18)
- -- Packed_Array_Impl_Type (Node23)
+ -- String_Literal_Length
+ -- First_Index (always Empty)
+ -- String_Literal_Low_Bound
+ -- Packed_Array_Impl_Type
-- (plus type attributes)
-- E_Subprogram_Body
- -- Mechanism (Uint8)
- -- First_Entity (Node17)
- -- Corresponding_Protected_Entry (Node18)
- -- Last_Entity (Node20)
- -- Scope_Depth_Value (Uint22)
- -- Extra_Formals (Node28)
- -- Anonymous_Masters (Elist29)
- -- Contract (Node34)
- -- SPARK_Pragma (Node40)
- -- Contains_Ignored_Ghost_Code (Flag279)
- -- SPARK_Pragma_Inherited (Flag265)
- -- Scope_Depth (synth)
+ -- Mechanism
+ -- First_Entity
+ -- Corresponding_Protected_Entry
+ -- Last_Entity
+ -- Scope_Depth_Value
+ -- Extra_Formals
+ -- Anonymous_Masters
+ -- Contract
+ -- SPARK_Pragma
+ -- Contains_Ignored_Ghost_Code
+ -- SPARK_Pragma_Inherited
+ -- Interface_Name $$$
+ -- Renamed_Entity $$$
+ -- Scope_Depth (synth)
-- E_Subprogram_Type
- -- 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)
+ -- Extra_Accessibility_Of_Result
+ -- Directly_Designated_Type
+ -- Extra_Formals
+ -- Access_Subprogram_Wrapper
+ -- First_Formal (synth)
+ -- First_Formal_With_Extras (synth)
+ -- Last_Formal (synth)
+ -- Number_Formals (synth)
+ -- Returns_By_Ref
+ -- First_Entity $$$
+ -- Last_Entity $$$
+ -- Interface_Name $$$
-- (plus type attributes)
-- E_Task_Body
- -- Contract (Node34)
- -- SPARK_Pragma (Node40)
- -- Ignore_SPARK_Mode_Pragmas (Flag301)
- -- SPARK_Pragma_Inherited (Flag265)
+ -- Contract
+ -- SPARK_Pragma
+ -- Ignore_SPARK_Mode_Pragmas
+ -- SPARK_Pragma_Inherited
+ -- First_Entity $$$
-- (any others??? First/Last Entity, Scope_Depth???)
-- E_Task_Type
-- E_Task_Subtype
- -- Direct_Primitive_Operations (Elist10)
- -- First_Private_Entity (Node16)
- -- First_Entity (Node17)
- -- Corresponding_Record_Type (Node18)
- -- Last_Entity (Node20)
- -- Discriminant_Constraint (Elist21)
- -- Scope_Depth_Value (Uint22)
- -- Stored_Constraint (Elist23)
- -- Task_Body_Procedure (Node25)
- -- Storage_Size_Variable (Node26) (base type only)
- -- Relative_Deadline_Variable (Node28) (base type only)
- -- Anonymous_Object (Node30)
- -- Contract (Node34)
- -- SPARK_Aux_Pragma (Node41)
- -- Delay_Cleanups (Flag114)
- -- Has_Master_Entity (Flag21)
- -- Has_Storage_Size_Clause (Flag23) (base type only)
- -- Ignore_SPARK_Mode_Pragmas (Flag301)
- -- Is_Elaboration_Checks_OK_Id (Flag148)
- -- Is_Elaboration_Warnings_OK_Id (Flag304)
- -- SPARK_Aux_Pragma_Inherited (Flag266)
- -- First_Component (synth)
- -- First_Component_Or_Discriminant (synth)
- -- Has_Entries (synth)
- -- Is_Elaboration_Target (synth)
- -- Number_Entries (synth)
- -- Scope_Depth (synth)
+ -- Direct_Primitive_Operations
+ -- First_Private_Entity
+ -- First_Entity
+ -- Corresponding_Record_Type
+ -- Last_Entity
+ -- Discriminant_Constraint
+ -- Scope_Depth_Value
+ -- Stored_Constraint
+ -- Task_Body_Procedure
+ -- Storage_Size_Variable (base type only)
+ -- Relative_Deadline_Variable (base type only)
+ -- Anonymous_Object
+ -- Contract
+ -- SPARK_Aux_Pragma
+ -- Delay_Cleanups
+ -- Has_Master_Entity
+ -- Has_Storage_Size_Clause (base type only)
+ -- Ignore_SPARK_Mode_Pragmas
+ -- Is_Elaboration_Checks_OK_Id
+ -- Is_Elaboration_Warnings_OK_Id
+ -- SPARK_Aux_Pragma_Inherited
+ -- First_Component (synth)
+ -- First_Component_Or_Discriminant (synth)
+ -- Has_Entries (synth)
+ -- Is_Elaboration_Target (synth)
+ -- Number_Entries (synth)
+ -- Scope_Depth (synth)
-- (plus type attributes)
-- E_Variable
- -- Hiding_Loop_Variable (Node8)
- -- Current_Value (Node9)
- -- Part_Of_Constituents (Elist10)
- -- Part_Of_References (Elist11)
- -- Esize (Uint12)
- -- Extra_Accessibility (Node13)
- -- Alignment (Uint14)
- -- Status_Flag_Or_Transient_Decl (Node15) (transient object only)
- -- Unset_Reference (Node16)
- -- Actual_Subtype (Node17)
- -- Renamed_Object (Node18)
- -- Size_Check_Code (Node19)
- -- Prival_Link (Node20)
- -- Interface_Name (Node21)
- -- Shared_Var_Procs_Instance (Node22)
- -- Extra_Constrained (Node23)
- -- Related_Expression (Node24)
- -- Debug_Renaming_Link (Node25)
- -- Last_Assignment (Node26)
- -- Related_Type (Node27)
- -- Initialization_Statements (Node28)
- -- BIP_Initialization_Call (Node29)
- -- Last_Aggregate_Assignment (Node30)
- -- Activation_Record_Component (Node31)
- -- Encapsulating_State (Node32)
- -- Linker_Section_Pragma (Node33)
- -- Contract (Node34)
- -- Anonymous_Designated_Type (Node35)
- -- Validated_Object (Node38)
- -- SPARK_Pragma (Node40)
- -- Has_Alignment_Clause (Flag46)
- -- Has_Atomic_Components (Flag86)
- -- Has_Biased_Representation (Flag139)
- -- Has_Independent_Components (Flag34)
- -- Has_Initial_Value (Flag219)
- -- Has_Size_Clause (Flag29)
- -- Has_Volatile_Components (Flag87)
- -- Is_Atomic (Flag85)
- -- Is_Elaboration_Checks_OK_Id (Flag148)
- -- Is_Elaboration_Warnings_OK_Id (Flag304)
- -- Is_Eliminated (Flag124)
- -- Is_Finalized_Transient (Flag252)
- -- Is_Ignored_Transient (Flag295)
- -- Is_Independent (Flag268)
- -- Is_Return_Object (Flag209)
- -- Is_Safe_To_Reevaluate (Flag249)
- -- Is_Shared_Passive (Flag60)
- -- Is_True_Constant (Flag163)
- -- Is_Uplevel_Referenced_Entity (Flag283)
- -- Is_Volatile (Flag16)
- -- Is_Volatile_Full_Access (Flag285)
- -- OK_To_Rename (Flag247)
- -- Optimize_Alignment_Space (Flag241)
- -- Optimize_Alignment_Time (Flag242)
- -- SPARK_Pragma_Inherited (Flag265)
- -- Suppress_Initialization (Flag105)
- -- Treat_As_Volatile (Flag41)
- -- Address_Clause (synth)
- -- Alignment_Clause (synth)
- -- Is_Elaboration_Target (synth)
- -- Is_Full_Access (synth)
- -- Size_Clause (synth)
+ -- Hiding_Loop_Variable
+ -- Current_Value
+ -- Part_Of_Constituents
+ -- Part_Of_References
+ -- Esize
+ -- Extra_Accessibility
+ -- Alignment
+ -- Status_Flag_Or_Transient_Decl (transient object only)
+ -- Unset_Reference
+ -- Actual_Subtype
+ -- Renamed_Object
+ -- Renamed_Entity $$$
+ -- Discriminal_Link $$$
+ -- Size_Check_Code
+ -- Prival_Link
+ -- Interface_Name
+ -- Shared_Var_Procs_Instance
+ -- Extra_Constrained
+ -- Related_Expression
+ -- Debug_Renaming_Link
+ -- Last_Assignment
+ -- Related_Type
+ -- Initialization_Statements
+ -- BIP_Initialization_Call
+ -- Last_Aggregate_Assignment
+ -- Activation_Record_Component
+ -- Encapsulating_State
+ -- Linker_Section_Pragma
+ -- Contract
+ -- Anonymous_Designated_Type
+ -- Validated_Object
+ -- SPARK_Pragma
+ -- Has_Alignment_Clause
+ -- Has_Atomic_Components
+ -- Has_Biased_Representation
+ -- Has_Independent_Components
+ -- Has_Initial_Value
+ -- Has_Size_Clause
+ -- Has_Volatile_Components
+ -- Is_Atomic
+ -- Is_Elaboration_Checks_OK_Id
+ -- Is_Elaboration_Warnings_OK_Id
+ -- Is_Eliminated
+ -- Is_Finalized_Transient
+ -- Is_Ignored_Transient
+ -- Is_Independent
+ -- Is_Return_Object
+ -- Is_Safe_To_Reevaluate
+ -- Is_Shared_Passive
+ -- Is_True_Constant
+ -- Is_Uplevel_Referenced_Entity
+ -- Is_Volatile
+ -- Is_Volatile_Full_Access
+ -- OK_To_Rename
+ -- Optimize_Alignment_Space
+ -- Optimize_Alignment_Time
+ -- SPARK_Pragma_Inherited
+ -- Suppress_Initialization
+ -- Treat_As_Volatile
+ -- Address_Clause (synth)
+ -- Alignment_Clause (synth)
+ -- Is_Elaboration_Target (synth)
+ -- Is_Full_Access (synth)
+ -- Size_Clause (synth)
-- E_Void
-- Since E_Void is the initial Ekind value of an entity when it is first
@@ -6892,31 +6206,26 @@ package Einfo is
-- type checking, since there is no assurance that the eventual Ekind
-- value will be appropriate for the attributes set, and the consequence
-- is that the dynamic type checking in the Einfo body is unnecessarily
- -- weak. To be looked at systematically some time ???
-
- ---------------------------------
- -- Component_Alignment Control --
- ---------------------------------
-
- -- There are four types of alignment possible for array and record
- -- types, and a field in the type entities contains a value of the
- -- following type indicating which alignment choice applies. For full
- -- details of the meaning of these alignment types, see description
- -- of the Component_Alignment pragma.
-
- type Component_Alignment_Kind is (
- Calign_Default, -- default alignment
- Calign_Component_Size, -- natural alignment for component size
- Calign_Component_Size_4, -- natural for size <= 4, 4 for size >= 4
- Calign_Storage_Unit); -- all components byte aligned
-
- -----------------------------------
- -- Floating Point Representation --
- -----------------------------------
-
- type Float_Rep_Kind is (
- IEEE_Binary, -- IEEE 754p conforming binary format
- AAMP); -- AAMP format
+ -- weak.
+ --
+ -- The following are examples of getters and setters called with E_Void:
+ -- Entry_Formal $$$
+ -- Esize $$$
+ -- First_Entity $$$
+ -- Handler_Records $$$
+ -- Interface_Name $$$
+ -- Last_Entity $$$
+ -- Renamed_Entity $$$
+ -- Renamed_Object $$$
+ -- Scalar_Range $$$
+ -- Set_Associated_Node_For_Itype $$$
+ -- Set_Debug_Renaming_Link $$$
+ -- Set_Entry_Cancel_Parameter $$$
+ -- Set_First_Entity $$$
+ -- Set_Inner_Instances $$$
+ -- Set_Last_Entity $$$
+ -- Set_Scalar_Range $$$
+ -- Set_Entry_Cancel_Parameter $$$
---------------
-- Iterators --
@@ -7085,2704 +6394,4 @@ package Einfo is
-- example), the expansion mechanism uses the placeholder of the component
-- to correct the Entity and Etype of the reference.
- -------------------
- -- Type Synonyms --
- -------------------
-
- -- The following type synonyms are used to tidy up the function and
- -- procedure declarations that follow, and also to make it possible to meet
- -- the requirement for the XEINFO utility that all function specs must fit
- -- on a single source line.
-
- subtype B is Boolean;
- subtype C is Component_Alignment_Kind;
- subtype E is Entity_Id;
- subtype F is Float_Rep_Kind;
- subtype M is Mechanism_Type;
- subtype N is Node_Id;
- subtype U is Uint;
- subtype R is Ureal;
- subtype L is Elist_Id;
- subtype S is List_Id;
-
- --------------------------------
- -- Attribute Access Functions --
- --------------------------------
-
- -- All attributes are manipulated through a procedural interface. This
- -- section contains the functions used to obtain attribute values which
- -- correspond to values in fields or flags in the entity itself.
-
- function Abstract_States (Id : E) return L;
- 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;
- function Alias (Id : E) return E;
- function Alignment (Id : E) return U;
- function Anonymous_Designated_Type (Id : E) return E;
- function Anonymous_Masters (Id : E) return L;
- function Anonymous_Object (Id : E) return E;
- function Associated_Entity (Id : E) return E;
- function Associated_Formal_Package (Id : E) return E;
- function Associated_Node_For_Itype (Id : E) return N;
- function Associated_Storage_Pool (Id : E) return E;
- function Barrier_Function (Id : E) return N;
- function BIP_Initialization_Call (Id : E) return N;
- function Block_Node (Id : E) return N;
- function Body_Entity (Id : E) return E;
- function Body_Needed_For_SAL (Id : E) return B;
- function Body_Needed_For_Inlining (Id : E) return B;
- function Body_References (Id : E) return L;
- function C_Pass_By_Copy (Id : E) return B;
- function Can_Never_Be_Null (Id : E) return B;
- function Can_Use_Internal_Rep (Id : E) return B;
- function Checks_May_Be_Suppressed (Id : E) return B;
- 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_Bit_Offset (Id : E) return U;
- function Component_Clause (Id : E) return N;
- function Component_Size (Id : E) return U;
- function Component_Type (Id : E) return E;
- function Contains_Ignored_Ghost_Code (Id : E) return B;
- function Contract (Id : E) return N;
- function Contract_Wrapper (Id : E) return E;
- function Corresponding_Concurrent_Type (Id : E) return E;
- function Corresponding_Discriminant (Id : E) return E;
- function Corresponding_Equality (Id : E) return E;
- function Corresponding_Function (Id : E) return E;
- function Corresponding_Procedure (Id : E) return E;
- function Corresponding_Protected_Entry (Id : E) return E;
- function Corresponding_Record_Component (Id : E) return E;
- function Corresponding_Record_Type (Id : E) return E;
- function Corresponding_Remote_Type (Id : E) return E;
- function CR_Discriminant (Id : E) return E;
- function Current_Use_Clause (Id : E) return E;
- function Current_Value (Id : E) return N;
- function Debug_Info_Off (Id : E) return B;
- function Debug_Renaming_Link (Id : E) return E;
- function Default_Aspect_Component_Value (Id : E) return N;
- function Default_Aspect_Value (Id : E) return N;
- function Default_Expr_Function (Id : E) return E;
- function Default_Expressions_Processed (Id : E) return B;
- function Default_Value (Id : E) return N;
- function Delay_Cleanups (Id : E) return B;
- function Delay_Subprogram_Descriptors (Id : E) return B;
- function Delta_Value (Id : E) return R;
- function Dependent_Instances (Id : E) return L;
- function Depends_On_Private (Id : E) return B;
- function Derived_Type_Link (Id : E) return E;
- function Digits_Value (Id : E) return U;
- function Direct_Primitive_Operations (Id : E) return L;
- function Directly_Designated_Type (Id : E) return E;
- function Disable_Controlled (Id : E) return B;
- function Discard_Names (Id : E) return B;
- function Discriminal (Id : E) return E;
- function Discriminal_Link (Id : E) return E;
- function Discriminant_Checking_Func (Id : E) return E;
- function Discriminant_Constraint (Id : E) return L;
- function Discriminant_Default_Value (Id : E) return N;
- function Discriminant_Number (Id : E) return U;
- function Dispatch_Table_Wrappers (Id : E) return L;
- function DT_Entry_Count (Id : E) return U;
- function DT_Offset_To_Top_Func (Id : E) return E;
- function DT_Position (Id : E) return U;
- function DTC_Entity (Id : E) return E;
- function Elaborate_Body_Desirable (Id : E) return B;
- function Elaboration_Entity (Id : E) return E;
- function Elaboration_Entity_Required (Id : E) return B;
- function Encapsulating_State (Id : E) return E;
- function Enclosing_Scope (Id : E) return E;
- function Entry_Accepted (Id : E) return B;
- function Entry_Bodies_Array (Id : E) return E;
- function Entry_Cancel_Parameter (Id : E) return E;
- function Entry_Component (Id : E) return E;
- function Entry_Formal (Id : E) return E;
- function Entry_Index_Constant (Id : E) return E;
- function Entry_Index_Type (Id : E) return E;
- function Entry_Max_Queue_Lengths_Array (Id : E) return E;
- function Entry_Parameters_Type (Id : E) return E;
- function Enum_Pos_To_Rep (Id : E) return E;
- function Enumeration_Pos (Id : E) return U;
- function Enumeration_Rep (Id : E) return U;
- function Enumeration_Rep_Expr (Id : E) return N;
- function Equivalent_Type (Id : E) return E;
- function Esize (Id : E) return U;
- function Extra_Accessibility (Id : E) return E;
- function Extra_Accessibility_Of_Result (Id : E) return E;
- function Extra_Constrained (Id : E) return E;
- function Extra_Formal (Id : E) return E;
- function Extra_Formals (Id : E) return E;
- function Finalization_Master (Id : E) return E;
- function Finalize_Storage_Only (Id : E) return B;
- function Finalizer (Id : E) return E;
- function First_Entity (Id : E) return E;
- function First_Exit_Statement (Id : E) return N;
- function First_Index (Id : E) return N;
- function First_Literal (Id : E) return E;
- function First_Private_Entity (Id : E) return E;
- function First_Rep_Item (Id : E) return N;
- function Float_Rep (Id : E) return F;
- function Freeze_Node (Id : E) return N;
- function From_Limited_With (Id : E) return B;
- function Full_View (Id : E) return E;
- function Generic_Homonym (Id : E) return E;
- function Generic_Renamings (Id : E) return L;
- function Handler_Records (Id : E) return S;
- function Has_Aliased_Components (Id : E) return B;
- function Has_Alignment_Clause (Id : E) return B;
- function Has_All_Calls_Remote (Id : E) return B;
- function Has_Atomic_Components (Id : E) return B;
- function Has_Biased_Representation (Id : E) return B;
- function Has_Completion (Id : E) return B;
- function Has_Completion_In_Body (Id : E) return B;
- function Has_Complex_Representation (Id : E) return B;
- function Has_Component_Size_Clause (Id : E) return B;
- function Has_Constrained_Partial_View (Id : E) return B;
- function Has_Contiguous_Rep (Id : E) return B;
- function Has_Controlled_Component (Id : E) return B;
- function Has_Controlling_Result (Id : E) return B;
- function Has_Convention_Pragma (Id : E) return B;
- function Has_Default_Aspect (Id : E) return B;
- 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_Discriminants (Id : E) return B;
- function Has_Dispatch_Table (Id : E) return B;
- function Has_Dynamic_Predicate_Aspect (Id : E) return B;
- function Has_Enumeration_Rep_Clause (Id : E) return B;
- function Has_Exit (Id : E) return B;
- function Has_Expanded_Contract (Id : E) return B;
- function Has_Forward_Instantiation (Id : E) return B;
- function Has_Fully_Qualified_Name (Id : E) return B;
- function Has_Gigi_Rep_Item (Id : E) return B;
- function Has_Homonym (Id : E) return B;
- function Has_Implicit_Dereference (Id : E) return B;
- function Has_Independent_Components (Id : E) return B;
- function Has_Inheritable_Invariants (Id : E) return B;
- 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_Loop_Entry_Attributes (Id : E) return B;
- function Has_Machine_Radix_Clause (Id : E) return B;
- function Has_Master_Entity (Id : E) return B;
- function Has_Missing_Return (Id : E) return B;
- function Has_Nested_Block_With_Handler (Id : E) return B;
- function Has_Nested_Subprogram (Id : E) return B;
- function Has_Non_Standard_Rep (Id : E) return B;
- function Has_Object_Size_Clause (Id : E) return B;
- function Has_Out_Or_In_Out_Parameter (Id : E) return B;
- function Has_Own_DIC (Id : E) return B;
- function Has_Own_Invariants (Id : E) return B;
- function Has_Partial_Visible_Refinement (Id : E) return B;
- function Has_Per_Object_Constraint (Id : E) return B;
- function Has_Pragma_Controlled (Id : E) return B;
- function Has_Pragma_Elaborate_Body (Id : E) return B;
- function Has_Pragma_Inline (Id : E) return B;
- function Has_Pragma_Inline_Always (Id : E) return B;
- function Has_Pragma_No_Inline (Id : E) return B;
- function Has_Pragma_Ordered (Id : E) return B;
- function Has_Pragma_Pack (Id : E) return B;
- function Has_Pragma_Preelab_Init (Id : E) return B;
- function Has_Pragma_Pure (Id : E) return B;
- function Has_Pragma_Pure_Function (Id : E) return B;
- function Has_Pragma_Thread_Local_Storage (Id : E) return B;
- function Has_Pragma_Unmodified (Id : E) return B;
- function Has_Pragma_Unreferenced (Id : E) return B;
- function Has_Pragma_Unreferenced_Objects (Id : E) return B;
- function Has_Pragma_Unused (Id : E) return B;
- function Has_Predicates (Id : E) return B;
- function Has_Primitive_Operations (Id : E) return B;
- function Has_Private_Ancestor (Id : E) return B;
- function Has_Private_Declaration (Id : E) return B;
- function Has_Private_Extension (Id : E) return B;
- function Has_Protected (Id : E) return B;
- function Has_Qualified_Name (Id : E) return B;
- function Has_RACW (Id : E) return B;
- function Has_Record_Rep_Clause (Id : E) return B;
- function Has_Recursive_Call (Id : E) return B;
- function Has_Shift_Operator (Id : E) return B;
- function Has_Size_Clause (Id : E) return B;
- function Has_Small_Clause (Id : E) return B;
- function Has_Specified_Layout (Id : E) return B;
- function Has_Specified_Stream_Input (Id : E) return B;
- function Has_Specified_Stream_Output (Id : E) return B;
- function Has_Specified_Stream_Read (Id : E) return B;
- function Has_Specified_Stream_Write (Id : E) return B;
- function Has_Static_Discriminants (Id : E) return B;
- function Has_Static_Predicate (Id : E) return B;
- function Has_Static_Predicate_Aspect (Id : E) return B;
- function Has_Storage_Size_Clause (Id : E) return B;
- function Has_Stream_Size_Clause (Id : E) return B;
- function Has_Task (Id : E) return B;
- function Has_Timing_Event (Id : E) return B;
- function Has_Thunks (Id : E) return B;
- function Has_Unchecked_Union (Id : E) return B;
- function Has_Unknown_Discriminants (Id : E) return B;
- 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;
- function Ignore_SPARK_Mode_Pragmas (Id : E) return B;
- function Import_Pragma (Id : E) return E;
- function Incomplete_Actuals (Id : E) return L;
- function In_Package_Body (Id : E) return B;
- function In_Private_Part (Id : E) return B;
- function In_Use (Id : E) return B;
- function Initialization_Statements (Id : E) return N;
- function Inner_Instances (Id : E) return L;
- function Interface_Alias (Id : E) return E;
- function Interface_Name (Id : E) return N;
- function Interfaces (Id : E) return L;
- function Is_Abstract_Subprogram (Id : E) return B;
- function Is_Abstract_Type (Id : E) return B;
- function Is_Access_Constant (Id : E) return B;
- function Is_Activation_Record (Id : E) return B;
- function Is_Actual_Subtype (Id : E) return B;
- function Is_Ada_2005_Only (Id : E) return B;
- function Is_Ada_2012_Only (Id : E) return B;
- function Is_Aliased (Id : E) return B;
- function Is_Asynchronous (Id : E) return B;
- function Is_Atomic (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;
- function Is_Checked_Ghost_Entity (Id : E) return B;
- function Is_Child_Unit (Id : E) return B;
- function Is_Class_Wide_Clone (Id : E) return B;
- function Is_Class_Wide_Equivalent_Type (Id : E) return B;
- function Is_Compilation_Unit (Id : E) return B;
- function Is_Completely_Hidden (Id : E) return B;
- function Is_Constr_Subt_For_U_Nominal (Id : E) return B;
- function Is_Constr_Subt_For_UN_Aliased (Id : E) return B;
- function Is_Constrained (Id : E) return B;
- function Is_Constructor (Id : E) return B;
- 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;
- function Is_Discriminant_Check_Function (Id : E) return B;
- function Is_Dispatch_Table_Entity (Id : E) return B;
- function Is_Dispatching_Operation (Id : E) return B;
- function Is_Elaboration_Checks_OK_Id (Id : E) return B;
- function Is_Elaboration_Warnings_OK_Id (Id : E) return B;
- function Is_Eliminated (Id : E) return B;
- function Is_Entry_Formal (Id : E) return B;
- function Is_Entry_Wrapper (Id : E) return B;
- function Is_Exception_Handler (Id : E) return B;
- function Is_Exported (Id : E) return B;
- function Is_Finalized_Transient (Id : E) return B;
- function Is_First_Subtype (Id : E) return B;
- function Is_Frozen (Id : E) return B;
- function Is_Generic_Instance (Id : E) return B;
- function Is_Hidden (Id : E) return B;
- function Is_Hidden_Non_Overridden_Subpgm (Id : E) return B;
- function Is_Hidden_Open_Scope (Id : E) return B;
- function Is_Ignored_Ghost_Entity (Id : E) return B;
- function Is_Ignored_Transient (Id : E) return B;
- function Is_Immediately_Visible (Id : E) return B;
- function Is_Implementation_Defined (Id : E) return B;
- function Is_Imported (Id : E) return B;
- function Is_Independent (Id : E) return B;
- function Is_Initial_Condition_Procedure (Id : E) return B;
- function Is_Inlined (Id : E) return B;
- function Is_Inlined_Always (Id : E) return B;
- function Is_Instantiated (Id : E) return B;
- function Is_Interface (Id : E) return B;
- function Is_Internal (Id : E) return B;
- function Is_Interrupt_Handler (Id : E) return B;
- function Is_Intrinsic_Subprogram (Id : E) return B;
- function Is_Invariant_Procedure (Id : E) return B;
- function Is_Itype (Id : E) return B;
- function Is_Known_Non_Null (Id : E) return B;
- function Is_Known_Null (Id : E) return B;
- function Is_Known_Valid (Id : E) return B;
- function Is_Limited_Composite (Id : E) return B;
- function Is_Limited_Interface (Id : E) return B;
- function Is_Local_Anonymous_Access (Id : E) return B;
- function Is_Loop_Parameter (Id : E) return B;
- function Is_Machine_Code_Subprogram (Id : E) return B;
- function Is_Non_Static_Subtype (Id : E) return B;
- function Is_Null_Init_Proc (Id : E) return B;
- function Is_Obsolescent (Id : E) return B;
- function Is_Only_Out_Parameter (Id : E) return B;
- function Is_Package_Body_Entity (Id : E) return B;
- function Is_Packed (Id : E) return B;
- function Is_Packed_Array_Impl_Type (Id : E) return B;
- function Is_Potentially_Use_Visible (Id : E) return B;
- function Is_Param_Block_Component_Type (Id : E) return B;
- function Is_Partial_DIC_Procedure (Id : E) return B;
- function Is_Partial_Invariant_Procedure (Id : E) return B;
- function Is_Predicate_Function (Id : E) return B;
- function Is_Predicate_Function_M (Id : E) return B;
- function Is_Preelaborated (Id : E) return B;
- function Is_Primitive (Id : E) return B;
- function Is_Primitive_Wrapper (Id : E) return B;
- function Is_Private_Composite (Id : E) return B;
- function Is_Private_Descendant (Id : E) return B;
- function Is_Private_Primitive (Id : E) return B;
- function Is_Public (Id : E) return B;
- function Is_Pure (Id : E) return B;
- function Is_Pure_Unit_Access_Type (Id : E) return B;
- function Is_RACW_Stub_Type (Id : E) return B;
- function Is_Raised (Id : E) return B;
- function Is_Remote_Call_Interface (Id : E) return B;
- function Is_Remote_Types (Id : E) return B;
- function Is_Renaming_Of_Object (Id : E) return B;
- function Is_Return_Object (Id : E) return B;
- function Is_Safe_To_Reevaluate (Id : E) return B;
- function Is_Shared_Passive (Id : E) return B;
- function Is_Static_Type (Id : E) return B;
- function Is_Statically_Allocated (Id : E) return B;
- function Is_Tag (Id : E) return B;
- function Is_Tagged_Type (Id : E) return B;
- function Is_Thunk (Id : E) return B;
- function Is_Trivial_Subprogram (Id : E) return B;
- function Is_True_Constant (Id : E) return B;
- function Is_Unchecked_Union (Id : E) return B;
- function Is_Underlying_Full_View (Id : E) return B;
- function Is_Underlying_Record_View (Id : E) return B;
- function Is_Unimplemented (Id : E) return B;
- function Is_Unsigned_Type (Id : E) return B;
- function Is_Uplevel_Referenced_Entity (Id : E) return B;
- function Is_Valued_Procedure (Id : E) return B;
- function Is_Visible_Formal (Id : E) return B;
- function Is_Visible_Lib_Unit (Id : E) return B;
- function Is_Volatile (Id : E) return B;
- function Is_Volatile_Full_Access (Id : E) return B;
- function Itype_Printed (Id : E) return B;
- function Kill_Elaboration_Checks (Id : E) return B;
- function Kill_Range_Checks (Id : E) return B;
- function Known_To_Have_Preelab_Init (Id : E) return B;
- function Last_Aggregate_Assignment (Id : E) return N;
- function Last_Assignment (Id : E) return N;
- function Last_Entity (Id : E) return E;
- function Limited_View (Id : E) return E;
- function Linker_Section_Pragma (Id : E) return N;
- function Lit_Indexes (Id : E) return E;
- function Lit_Strings (Id : E) return E;
- function Low_Bound_Tested (Id : E) return B;
- function Machine_Radix_10 (Id : E) return B;
- function Master_Id (Id : E) return E;
- function Materialize_Entity (Id : E) return B;
- function May_Inherit_Delayed_Rep_Aspects (Id : E) return B;
- function Mechanism (Id : E) return M;
- function Minimum_Accessibility (Id : E) return E;
- function Modulus (Id : E) return U;
- function Must_Be_On_Byte_Boundary (Id : E) return B;
- function Must_Have_Preelab_Init (Id : E) return B;
- function Needs_Activation_Record (Id : E) return B;
- function Needs_Debug_Info (Id : E) return B;
- function Needs_No_Actuals (Id : E) return B;
- function Never_Set_In_Source (Id : E) return B;
- function Next_Inlined_Subprogram (Id : E) return E;
- function No_Dynamic_Predicate_On_Actual (Id : E) return B;
- function No_Pool_Assigned (Id : E) return B;
- function No_Predicate_On_Actual (Id : E) return B;
- function No_Reordering (Id : E) return B;
- function No_Return (Id : E) return B;
- function No_Strict_Aliasing (Id : E) return B;
- function No_Tagged_Streams_Pragma (Id : E) return N;
- function Non_Binary_Modulus (Id : E) return B;
- function Non_Limited_View (Id : E) return E;
- function Nonzero_Is_True (Id : E) return B;
- function Normalized_First_Bit (Id : E) return U;
- function Normalized_Position (Id : E) return U;
- function Normalized_Position_Max (Id : E) return U;
- function OK_To_Rename (Id : E) return B;
- function Optimize_Alignment_Space (Id : E) return B;
- function Optimize_Alignment_Time (Id : E) return B;
- function Original_Access_Type (Id : E) return E;
- function Original_Array_Type (Id : E) return E;
- function Original_Protected_Subprogram (Id : E) return N;
- function Original_Record_Component (Id : E) return E;
- function Overlays_Constant (Id : E) return B;
- function Overridden_Operation (Id : E) return E;
- function Package_Instantiation (Id : E) return N;
- function Packed_Array_Impl_Type (Id : E) return E;
- function Parent_Subtype (Id : E) return E;
- function Part_Of_Constituents (Id : E) return L;
- function Part_Of_References (Id : E) return L;
- function Partial_View_Has_Unknown_Discr (Id : E) return B;
- function Pending_Access_Types (Id : E) return L;
- function Postconditions_Proc (Id : E) return E;
- function Predicated_Parent (Id : E) return E;
- function Predicates_Ignored (Id : E) return B;
- function Prev_Entity (Id : E) return E;
- function Prival (Id : E) return E;
- function Prival_Link (Id : E) return E;
- function Private_Dependents (Id : E) return L;
- function Protected_Body_Subprogram (Id : E) return E;
- function Protected_Formal (Id : E) return E;
- function Protected_Subprogram (Id : E) return N;
- function Protection_Object (Id : E) return E;
- function Reachable (Id : E) return B;
- function Receiving_Entry (Id : E) return E;
- function Referenced (Id : E) return B;
- function Referenced_As_LHS (Id : E) return B;
- function Referenced_As_Out_Parameter (Id : E) return B;
- function Refinement_Constituents (Id : E) return L;
- function Register_Exception_Call (Id : E) return N;
- function Related_Array_Object (Id : E) return E;
- function Related_Expression (Id : E) return N;
- function Related_Instance (Id : E) return E;
- function Related_Type (Id : E) return E;
- function Relative_Deadline_Variable (Id : E) return E;
- function Renamed_Entity (Id : E) return N;
- function Renamed_In_Spec (Id : E) return B;
- function Renamed_Object (Id : E) return N;
- function Renaming_Map (Id : E) return U;
- function Requires_Overriding (Id : E) return B;
- function Return_Applies_To (Id : E) return N;
- function Return_Present (Id : E) return B;
- function Returns_By_Ref (Id : E) return B;
- function Reverse_Bit_Order (Id : E) return B;
- function Reverse_Storage_Order (Id : E) return B;
- function Rewritten_For_C (Id : E) return B;
- function RM_Size (Id : E) return U;
- function Scalar_Range (Id : E) return N;
- function Scale_Value (Id : E) return U;
- function Scope_Depth_Value (Id : E) return U;
- function Sec_Stack_Needed_For_Return (Id : E) return B;
- function Shared_Var_Procs_Instance (Id : E) return E;
- function Size_Check_Code (Id : E) return N;
- function Size_Depends_On_Discriminant (Id : E) return B;
- function Size_Known_At_Compile_Time (Id : E) return B;
- function Small_Value (Id : E) return R;
- function SPARK_Aux_Pragma (Id : E) return N;
- function SPARK_Aux_Pragma_Inherited (Id : E) return B;
- function SPARK_Pragma (Id : E) return N;
- function SPARK_Pragma_Inherited (Id : E) return B;
- function Spec_Entity (Id : E) return E;
- function SSO_Set_High_By_Default (Id : E) return B;
- function SSO_Set_Low_By_Default (Id : E) return B;
- function Static_Discrete_Predicate (Id : E) return S;
- function Static_Elaboration_Desired (Id : E) return B;
- function Static_Initialization (Id : E) return N;
- function Static_Real_Or_String_Predicate (Id : E) return N;
- function Status_Flag_Or_Transient_Decl (Id : E) return E;
- function Storage_Size_Variable (Id : E) return E;
- function Stored_Constraint (Id : E) return L;
- function Stores_Attribute_Old_Prefix (Id : E) return B;
- function Strict_Alignment (Id : E) return B;
- function String_Literal_Length (Id : E) return U;
- function String_Literal_Low_Bound (Id : E) return N;
- function Subprograms_For_Type (Id : E) return L;
- function Subps_Index (Id : E) return U;
- function Suppress_Elaboration_Warnings (Id : E) return B;
- function Suppress_Initialization (Id : E) return B;
- function Suppress_Style_Checks (Id : E) return B;
- function Suppress_Value_Tracking_On_Call (Id : E) return B;
- function Task_Body_Procedure (Id : E) return N;
- function Thunk_Entity (Id : E) return E;
- function Treat_As_Volatile (Id : E) return B;
- function Underlying_Full_View (Id : E) return E;
- function Underlying_Record_View (Id : E) return E;
- function Universal_Aliasing (Id : E) return B;
- function Unset_Reference (Id : E) return N;
- function Used_As_Generic_Actual (Id : E) return B;
- function Uses_Lock_Free (Id : E) return B;
- function Uses_Sec_Stack (Id : E) return B;
- function Validated_Object (Id : E) return N;
- function Warnings_Off (Id : E) return B;
- function Warnings_Off_Used (Id : E) return B;
- function Warnings_Off_Used_Unmodified (Id : E) return B;
- function Warnings_Off_Used_Unreferenced (Id : E) return B;
- function Was_Hidden (Id : E) return B;
- function Wrapped_Entity (Id : E) return E;
-
- -------------------------------
- -- Classification Attributes --
- -------------------------------
-
- -- These functions provide a convenient functional notation for testing
- -- whether an Ekind value belongs to a specified kind, for example the
- -- function Is_Elementary_Type tests if its argument is in Elementary_Kind.
- -- In some cases, the test is of an entity attribute (e.g. in the case of
- -- 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;
- function Is_Aggregate_Type (Id : E) return B;
- function Is_Anonymous_Access_Type (Id : E) return B;
- function Is_Array_Type (Id : E) return B;
- function Is_Assignable (Id : E) return B;
- function Is_Class_Wide_Type (Id : E) return B;
- function Is_Composite_Type (Id : E) return B;
- function Is_Concurrent_Body (Id : E) return B;
- function Is_Concurrent_Record_Type (Id : E) return B;
- function Is_Concurrent_Type (Id : E) return B;
- function Is_Decimal_Fixed_Point_Type (Id : E) return B;
- function Is_Digits_Type (Id : E) return B;
- function Is_Discrete_Or_Fixed_Point_Type (Id : E) return B;
- function Is_Discrete_Type (Id : E) return B;
- function Is_Elementary_Type (Id : E) return B;
- function Is_Entry (Id : E) return B;
- function Is_Enumeration_Type (Id : E) return B;
- function Is_Fixed_Point_Type (Id : E) return B;
- function Is_Floating_Point_Type (Id : E) return B;
- function Is_Formal (Id : E) return B;
- function Is_Formal_Object (Id : E) return B;
- function Is_Formal_Subprogram (Id : E) return B;
- function Is_Generic_Actual_Subprogram (Id : E) return B;
- function Is_Generic_Actual_Type (Id : E) return B;
- function Is_Generic_Subprogram (Id : E) return B;
- function Is_Generic_Type (Id : E) return B;
- function Is_Generic_Unit (Id : E) return B;
- function Is_Ghost_Entity (Id : E) return B;
- function Is_Incomplete_Or_Private_Type (Id : E) return B;
- function Is_Incomplete_Type (Id : E) return B;
- 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;
- function Is_Ordinary_Fixed_Point_Type (Id : E) return B;
- function Is_Overloadable (Id : E) return B;
- function Is_Private_Type (Id : E) return B;
- function Is_Protected_Type (Id : E) return B;
- function Is_Real_Type (Id : E) return B;
- function Is_Record_Type (Id : E) return B;
- function Is_Scalar_Type (Id : E) return B;
- function Is_Signed_Integer_Type (Id : E) return B;
- function Is_Subprogram (Id : E) return B;
- function Is_Subprogram_Or_Entry (Id : E) return B;
- function Is_Subprogram_Or_Generic_Subprogram (Id : E) return B;
- function Is_Task_Type (Id : E) return B;
- function Is_Type (Id : E) return B;
-
- -------------------------------------
- -- Synthesized Attribute Functions --
- -------------------------------------
-
- -- The functions in this section synthesize attributes from the tree,
- -- so they do not correspond to defined fields in the entity itself.
-
- function Address_Clause (Id : E) return N;
- 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;
- function First_Component_Or_Discriminant (Id : E) return E;
- 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_Limited_View (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_Base_Type (Id : E) return B;
- function Is_Boolean_Type (Id : E) return B;
- function Is_Constant_Object (Id : E) return B;
- function Is_Controlled (Id : E) return B;
- function Is_Discriminal (Id : E) return B;
- function Is_Dynamic_Scope (Id : E) return B;
- function Is_Elaboration_Target (Id : E) return B;
- function Is_External_State (Id : E) return B;
- function Is_Finalizer (Id : E) return B;
- function Is_Full_Access (Id : E) return B;
- function Is_Null_State (Id : E) return B;
- function Is_Package_Or_Generic_Package (Id : E) return B;
- function Is_Packed_Array (Id : E) return B;
- function Is_Prival (Id : E) return B;
- 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;
- function Is_Synchronized_Interface (Id : E) return B;
- function Is_Synchronized_State (Id : E) return B;
- function Is_Task_Interface (Id : E) return B;
- function Is_Task_Record_Type (Id : E) return B;
- function Is_Wrapper_Package (Id : E) return B;
- function Last_Formal (Id : E) return E;
- function Machine_Emax_Value (Id : E) return U;
- function Machine_Emin_Value (Id : E) return U;
- function Machine_Mantissa_Value (Id : E) return U;
- function Machine_Radix_Value (Id : E) return U;
- function Model_Emin_Value (Id : E) return U;
- function Model_Epsilon_Value (Id : E) return R;
- function Model_Mantissa_Value (Id : E) return U;
- function Model_Small_Value (Id : E) return R;
- function Next_Component (Id : E) return E;
- function Next_Component_Or_Discriminant (Id : E) return E;
- 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;
- function Number_Entries (Id : E) return Nat;
- function Number_Formals (Id : E) return Pos;
- function Object_Size_Clause (Id : E) return N;
- function Parameter_Mode (Id : E) return Formal_Kind;
- function Partial_Refinement_Constituents (Id : E) return L;
- function Primitive_Operations (Id : E) return L;
- function Root_Type (Id : E) return E;
- 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;
- function Type_High_Bound (Id : E) return N;
- function Type_Low_Bound (Id : E) return N;
- function Underlying_Type (Id : E) return E;
-
- ----------------------------------------------
- -- Type Representation Attribute Predicates --
- ----------------------------------------------
-
- -- These predicates test the setting of the indicated attribute. If the
- -- value has been set, then Known is True, and Unknown is False. If no
- -- value is set, then Known is False and Unknown is True. The Known_Static
- -- predicate is true only if the value is set (Known) and is set to a
- -- compile time known value. Note that in the case of Alignment and
- -- Normalized_First_Bit, dynamic values are not possible, so we do not
- -- need a separate Known_Static calls in these cases. The not set (unknown)
- -- values are as follows:
-
- -- Alignment Uint_0 or No_Uint
- -- Component_Size Uint_0 or No_Uint
- -- Component_Bit_Offset No_Uint
- -- Digits_Value Uint_0 or No_Uint
- -- Esize Uint_0 or No_Uint
- -- Normalized_First_Bit No_Uint
- -- Normalized_Position No_Uint
- -- Normalized_Position_Max No_Uint
- -- RM_Size Uint_0 or No_Uint
-
- -- It would be cleaner to use No_Uint in all these cases, but historically
- -- we chose to use Uint_0 at first, and the change over will take time ???
- -- This is particularly true for the RM_Size field, where a value of zero
- -- is legitimate. We deal with this by a considering that the value is
- -- always known static for discrete types (and no other types can have
- -- an RM_Size value of zero).
-
- -- In two cases, Known_Static_Esize and Known_Static_RM_Size, there is one
- -- more consideration, which is that we always return False for generic
- -- types. Within a template, the size can look known, because of the fake
- -- size values we put in template types, but they are not really known and
- -- anyone testing if they are known within the template should get False as
- -- a result to prevent incorrect assumptions.
-
- function Known_Alignment (E : Entity_Id) return B;
- function Known_Component_Bit_Offset (E : Entity_Id) return B;
- function Known_Component_Size (E : Entity_Id) return B;
- function Known_Esize (E : Entity_Id) return B;
- function Known_Normalized_First_Bit (E : Entity_Id) return B;
- function Known_Normalized_Position (E : Entity_Id) return B;
- function Known_Normalized_Position_Max (E : Entity_Id) return B;
- function Known_RM_Size (E : Entity_Id) return B;
-
- function Known_Static_Component_Bit_Offset (E : Entity_Id) return B;
- function Known_Static_Component_Size (E : Entity_Id) return B;
- function Known_Static_Esize (E : Entity_Id) return B;
- function Known_Static_Normalized_First_Bit (E : Entity_Id) return B;
- function Known_Static_Normalized_Position (E : Entity_Id) return B;
- function Known_Static_Normalized_Position_Max (E : Entity_Id) return B;
- function Known_Static_RM_Size (E : Entity_Id) return B;
-
- function Unknown_Alignment (E : Entity_Id) return B;
- function Unknown_Component_Bit_Offset (E : Entity_Id) return B;
- function Unknown_Component_Size (E : Entity_Id) return B;
- function Unknown_Esize (E : Entity_Id) return B;
- function Unknown_Normalized_First_Bit (E : Entity_Id) return B;
- function Unknown_Normalized_Position (E : Entity_Id) return B;
- function Unknown_Normalized_Position_Max (E : Entity_Id) return B;
- function Unknown_RM_Size (E : Entity_Id) return B;
-
- ------------------------------
- -- Attribute Set Procedures --
- ------------------------------
-
- -- WARNING: There is a matching C declaration of a few subprograms in fe.h
-
- procedure Set_Abstract_States (Id : E; V : L);
- 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);
- procedure Set_Alias (Id : E; V : E);
- procedure Set_Alignment (Id : E; V : U);
- procedure Set_Anonymous_Designated_Type (Id : E; V : E);
- procedure Set_Anonymous_Masters (Id : E; V : L);
- procedure Set_Anonymous_Object (Id : E; V : E);
- procedure Set_Associated_Entity (Id : E; V : E);
- procedure Set_Associated_Formal_Package (Id : E; V : E);
- procedure Set_Associated_Node_For_Itype (Id : E; V : N);
- procedure Set_Associated_Storage_Pool (Id : E; V : E);
- procedure Set_Barrier_Function (Id : E; V : N);
- procedure Set_BIP_Initialization_Call (Id : E; V : N);
- procedure Set_Block_Node (Id : E; V : N);
- procedure Set_Body_Entity (Id : E; V : E);
- procedure Set_Body_Needed_For_Inlining (Id : E; V : B := True);
- procedure Set_Body_Needed_For_SAL (Id : E; V : B := True);
- procedure Set_Body_References (Id : E; V : L);
- procedure Set_C_Pass_By_Copy (Id : E; V : B := True);
- procedure Set_Can_Never_Be_Null (Id : E; V : B := True);
- procedure Set_Can_Use_Internal_Rep (Id : E; V : B := True);
- procedure Set_Checks_May_Be_Suppressed (Id : E; V : B := True);
- procedure Set_Class_Wide_Clone (Id : E; V : E);
- procedure Set_Class_Wide_Type (Id : E; V : E);
- procedure Set_Cloned_Subtype (Id : E; V : E);
- procedure Set_Component_Alignment (Id : E; V : C);
- procedure Set_Component_Bit_Offset (Id : E; V : U);
- procedure Set_Component_Clause (Id : E; V : N);
- procedure Set_Component_Size (Id : E; V : U);
- procedure Set_Component_Type (Id : E; V : E);
- procedure Set_Contains_Ignored_Ghost_Code (Id : E; V : B := True);
- procedure Set_Contract (Id : E; V : N);
- procedure Set_Contract_Wrapper (Id : E; V : E);
- procedure Set_Corresponding_Concurrent_Type (Id : E; V : E);
- procedure Set_Corresponding_Discriminant (Id : E; V : E);
- procedure Set_Corresponding_Equality (Id : E; V : E);
- procedure Set_Corresponding_Function (Id : E; V : E);
- procedure Set_Corresponding_Procedure (Id : E; V : E);
- procedure Set_Corresponding_Protected_Entry (Id : E; V : E);
- procedure Set_Corresponding_Record_Component (Id : E; V : E);
- procedure Set_Corresponding_Record_Type (Id : E; V : E);
- procedure Set_Corresponding_Remote_Type (Id : E; V : E);
- procedure Set_CR_Discriminant (Id : E; V : E);
- procedure Set_Current_Use_Clause (Id : E; V : E);
- procedure Set_Current_Value (Id : E; V : N);
- procedure Set_Debug_Info_Off (Id : E; V : B := True);
- procedure Set_Debug_Renaming_Link (Id : E; V : E);
- procedure Set_Default_Aspect_Component_Value (Id : E; V : N);
- procedure Set_Default_Aspect_Value (Id : E; V : N);
- procedure Set_Default_Expr_Function (Id : E; V : E);
- procedure Set_Default_Expressions_Processed (Id : E; V : B := True);
- procedure Set_Default_Value (Id : E; V : N);
- procedure Set_Delay_Cleanups (Id : E; V : B := True);
- procedure Set_Delay_Subprogram_Descriptors (Id : E; V : B := True);
- procedure Set_Delta_Value (Id : E; V : R);
- procedure Set_Dependent_Instances (Id : E; V : L);
- procedure Set_Depends_On_Private (Id : E; V : B := True);
- procedure Set_Derived_Type_Link (Id : E; V : E);
- procedure Set_Digits_Value (Id : E; V : U);
- procedure Set_Predicated_Parent (Id : E; V : E);
- procedure Set_Predicates_Ignored (Id : E; V : B);
- procedure Set_Direct_Primitive_Operations (Id : E; V : L);
- procedure Set_Directly_Designated_Type (Id : E; V : E);
- procedure Set_Disable_Controlled (Id : E; V : B := True);
- procedure Set_Discard_Names (Id : E; V : B := True);
- procedure Set_Discriminal (Id : E; V : E);
- procedure Set_Discriminal_Link (Id : E; V : E);
- procedure Set_Discriminant_Checking_Func (Id : E; V : E);
- procedure Set_Discriminant_Constraint (Id : E; V : L);
- procedure Set_Discriminant_Default_Value (Id : E; V : N);
- procedure Set_Discriminant_Number (Id : E; V : U);
- procedure Set_Dispatch_Table_Wrappers (Id : E; V : L);
- procedure Set_DT_Entry_Count (Id : E; V : U);
- procedure Set_DT_Offset_To_Top_Func (Id : E; V : E);
- procedure Set_DT_Position (Id : E; V : U);
- procedure Set_DTC_Entity (Id : E; V : E);
- procedure Set_Elaborate_Body_Desirable (Id : E; V : B := True);
- procedure Set_Elaboration_Entity (Id : E; V : E);
- procedure Set_Elaboration_Entity_Required (Id : E; V : B := True);
- procedure Set_Encapsulating_State (Id : E; V : E);
- procedure Set_Enclosing_Scope (Id : E; V : E);
- procedure Set_Entry_Accepted (Id : E; V : B := True);
- procedure Set_Entry_Bodies_Array (Id : E; V : E);
- procedure Set_Entry_Cancel_Parameter (Id : E; V : E);
- procedure Set_Entry_Component (Id : E; V : E);
- procedure Set_Entry_Formal (Id : E; V : E);
- procedure Set_Entry_Index_Constant (Id : E; V : E);
- procedure Set_Entry_Max_Queue_Lengths_Array (Id : E; V : E);
- procedure Set_Entry_Parameters_Type (Id : E; V : E);
- procedure Set_Enum_Pos_To_Rep (Id : E; V : E);
- procedure Set_Enumeration_Pos (Id : E; V : U);
- procedure Set_Enumeration_Rep (Id : E; V : U);
- procedure Set_Enumeration_Rep_Expr (Id : E; V : N);
- procedure Set_Equivalent_Type (Id : E; V : E);
- procedure Set_Esize (Id : E; V : U);
- procedure Set_Extra_Accessibility (Id : E; V : E);
- procedure Set_Extra_Accessibility_Of_Result (Id : E; V : E);
- procedure Set_Extra_Constrained (Id : E; V : E);
- procedure Set_Extra_Formal (Id : E; V : E);
- procedure Set_Extra_Formals (Id : E; V : E);
- procedure Set_Finalization_Master (Id : E; V : E);
- procedure Set_Finalize_Storage_Only (Id : E; V : B := True);
- procedure Set_Finalizer (Id : E; V : E);
- procedure Set_First_Entity (Id : E; V : E);
- procedure Set_First_Exit_Statement (Id : E; V : N);
- procedure Set_First_Index (Id : E; V : N);
- procedure Set_First_Literal (Id : E; V : E);
- procedure Set_First_Private_Entity (Id : E; V : E);
- procedure Set_First_Rep_Item (Id : E; V : N);
- procedure Set_Float_Rep (Id : E; V : F);
- procedure Set_Freeze_Node (Id : E; V : N);
- procedure Set_From_Limited_With (Id : E; V : B := True);
- procedure Set_Full_View (Id : E; V : E);
- procedure Set_Generic_Homonym (Id : E; V : E);
- procedure Set_Generic_Renamings (Id : E; V : L);
- procedure Set_Handler_Records (Id : E; V : S);
- procedure Set_Has_Aliased_Components (Id : E; V : B := True);
- procedure Set_Has_Alignment_Clause (Id : E; V : B := True);
- procedure Set_Has_All_Calls_Remote (Id : E; V : B := True);
- procedure Set_Has_Atomic_Components (Id : E; V : B := True);
- procedure Set_Has_Biased_Representation (Id : E; V : B := True);
- procedure Set_Has_Completion (Id : E; V : B := True);
- procedure Set_Has_Completion_In_Body (Id : E; V : B := True);
- procedure Set_Has_Complex_Representation (Id : E; V : B := True);
- procedure Set_Has_Component_Size_Clause (Id : E; V : B := True);
- procedure Set_Has_Constrained_Partial_View (Id : E; V : B := True);
- procedure Set_Has_Contiguous_Rep (Id : E; V : B := True);
- procedure Set_Has_Controlled_Component (Id : E; V : B := True);
- procedure Set_Has_Controlling_Result (Id : E; V : B := True);
- procedure Set_Has_Convention_Pragma (Id : E; V : B := True);
- procedure Set_Has_Default_Aspect (Id : E; V : B := True);
- procedure Set_Has_Delayed_Aspects (Id : E; V : B := True);
- procedure Set_Has_Delayed_Freeze (Id : E; V : B := True);
- procedure Set_Has_Delayed_Rep_Aspects (Id : E; V : B := True);
- procedure Set_Has_Discriminants (Id : E; V : B := True);
- procedure Set_Has_Dispatch_Table (Id : E; V : B := True);
- procedure Set_Has_Dynamic_Predicate_Aspect (Id : E; V : B := True);
- procedure Set_Has_Enumeration_Rep_Clause (Id : E; V : B := True);
- procedure Set_Has_Exit (Id : E; V : B := True);
- procedure Set_Has_Expanded_Contract (Id : E; V : B := True);
- procedure Set_Has_Forward_Instantiation (Id : E; V : B := True);
- procedure Set_Has_Fully_Qualified_Name (Id : E; V : B := True);
- procedure Set_Has_Gigi_Rep_Item (Id : E; V : B := True);
- procedure Set_Has_Homonym (Id : E; V : B := True);
- procedure Set_Has_Implicit_Dereference (Id : E; V : B := True);
- procedure Set_Has_Independent_Components (Id : E; V : B := True);
- procedure Set_Has_Inheritable_Invariants (Id : E; V : B := True);
- procedure Set_Has_Inherited_DIC (Id : E; V : B := True);
- procedure Set_Has_Inherited_Invariants (Id : E; V : B := True);
- procedure Set_Has_Initial_Value (Id : E; V : B := True);
- procedure Set_Has_Loop_Entry_Attributes (Id : E; V : B := True);
- procedure Set_Has_Machine_Radix_Clause (Id : E; V : B := True);
- procedure Set_Has_Master_Entity (Id : E; V : B := True);
- procedure Set_Has_Missing_Return (Id : E; V : B := True);
- procedure Set_Has_Nested_Block_With_Handler (Id : E; V : B := True);
- procedure Set_Has_Nested_Subprogram (Id : E; V : B := True);
- procedure Set_Has_Non_Standard_Rep (Id : E; V : B := True);
- procedure Set_Has_Object_Size_Clause (Id : E; V : B := True);
- procedure Set_Has_Out_Or_In_Out_Parameter (Id : E; V : B := True);
- procedure Set_Has_Own_DIC (Id : E; V : B := True);
- procedure Set_Has_Own_Invariants (Id : E; V : B := True);
- procedure Set_Has_Partial_Visible_Refinement (Id : E; V : B := True);
- procedure Set_Has_Per_Object_Constraint (Id : E; V : B := True);
- procedure Set_Has_Pragma_Controlled (Id : E; V : B := True);
- procedure Set_Has_Pragma_Elaborate_Body (Id : E; V : B := True);
- procedure Set_Has_Pragma_Inline (Id : E; V : B := True);
- procedure Set_Has_Pragma_Inline_Always (Id : E; V : B := True);
- procedure Set_Has_Pragma_No_Inline (Id : E; V : B := True);
- procedure Set_Has_Pragma_Ordered (Id : E; V : B := True);
- procedure Set_Has_Pragma_Pack (Id : E; V : B := True);
- procedure Set_Has_Pragma_Preelab_Init (Id : E; V : B := True);
- procedure Set_Has_Pragma_Pure (Id : E; V : B := True);
- procedure Set_Has_Pragma_Pure_Function (Id : E; V : B := True);
- procedure Set_Has_Pragma_Thread_Local_Storage (Id : E; V : B := True);
- procedure Set_Has_Pragma_Unmodified (Id : E; V : B := True);
- procedure Set_Has_Pragma_Unreferenced (Id : E; V : B := True);
- procedure Set_Has_Pragma_Unreferenced_Objects (Id : E; V : B := True);
- procedure Set_Has_Pragma_Unused (Id : E; V : B := True);
- procedure Set_Has_Predicates (Id : E; V : B := True);
- procedure Set_Has_Primitive_Operations (Id : E; V : B := True);
- procedure Set_Has_Private_Ancestor (Id : E; V : B := True);
- procedure Set_Has_Private_Declaration (Id : E; V : B := True);
- procedure Set_Has_Private_Extension (Id : E; V : B := True);
- procedure Set_Has_Protected (Id : E; V : B := True);
- procedure Set_Has_Qualified_Name (Id : E; V : B := True);
- procedure Set_Has_RACW (Id : E; V : B := True);
- procedure Set_Has_Record_Rep_Clause (Id : E; V : B := True);
- procedure Set_Has_Recursive_Call (Id : E; V : B := True);
- procedure Set_Has_Shift_Operator (Id : E; V : B := True);
- procedure Set_Has_Size_Clause (Id : E; V : B := True);
- procedure Set_Has_Small_Clause (Id : E; V : B := True);
- procedure Set_Has_Specified_Layout (Id : E; V : B := True);
- procedure Set_Has_Specified_Stream_Input (Id : E; V : B := True);
- procedure Set_Has_Specified_Stream_Output (Id : E; V : B := True);
- procedure Set_Has_Specified_Stream_Read (Id : E; V : B := True);
- procedure Set_Has_Specified_Stream_Write (Id : E; V : B := True);
- procedure Set_Has_Static_Discriminants (Id : E; V : B := True);
- procedure Set_Has_Static_Predicate (Id : E; V : B := True);
- procedure Set_Has_Static_Predicate_Aspect (Id : E; V : B := True);
- procedure Set_Has_Storage_Size_Clause (Id : E; V : B := True);
- procedure Set_Has_Stream_Size_Clause (Id : E; V : B := True);
- procedure Set_Has_Task (Id : E; V : B := True);
- procedure Set_Has_Timing_Event (Id : E; V : B := True);
- procedure Set_Has_Thunks (Id : E; V : B := True);
- procedure Set_Has_Unchecked_Union (Id : E; V : B := True);
- procedure Set_Has_Unknown_Discriminants (Id : E; V : B := True);
- 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);
- procedure Set_Ignore_SPARK_Mode_Pragmas (Id : E; V : B := True);
- procedure Set_Import_Pragma (Id : E; V : E);
- procedure Set_Incomplete_Actuals (Id : E; V : L);
- procedure Set_In_Package_Body (Id : E; V : B := True);
- procedure Set_In_Private_Part (Id : E; V : B := True);
- procedure Set_In_Use (Id : E; V : B := True);
- procedure Set_Initialization_Statements (Id : E; V : N);
- procedure Set_Inner_Instances (Id : E; V : L);
- 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_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);
- procedure Set_Is_Activation_Record (Id : E; V : B := True);
- procedure Set_Is_Actual_Subtype (Id : E; V : B := True);
- procedure Set_Is_Ada_2005_Only (Id : E; V : B := True);
- procedure Set_Is_Ada_2012_Only (Id : E; V : B := True);
- procedure Set_Is_Aliased (Id : E; V : B := True);
- procedure Set_Is_Asynchronous (Id : E; V : B := True);
- procedure Set_Is_Atomic (Id : E; V : B := True);
- procedure Set_Is_Bit_Packed_Array (Id : E; V : B := True);
- procedure Set_Is_Called (Id : E; V : B := True);
- procedure Set_Is_Character_Type (Id : E; V : B := True);
- procedure Set_Is_Checked_Ghost_Entity (Id : E; V : B := True);
- procedure Set_Is_Child_Unit (Id : E; V : B := True);
- procedure Set_Is_Class_Wide_Clone (Id : E; V : B := True);
- procedure Set_Is_Class_Wide_Equivalent_Type (Id : E; V : B := True);
- procedure Set_Is_Compilation_Unit (Id : E; V : B := True);
- procedure Set_Is_Completely_Hidden (Id : E; V : B := True);
- procedure Set_Is_Concurrent_Record_Type (Id : E; V : B := True);
- procedure Set_Is_Constr_Subt_For_U_Nominal (Id : E; V : B := True);
- procedure Set_Is_Constr_Subt_For_UN_Aliased (Id : E; V : B := True);
- procedure Set_Is_Constrained (Id : E; V : B := True);
- procedure Set_Is_Constructor (Id : E; V : B := True);
- 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);
- procedure Set_Is_Discriminant_Check_Function (Id : E; V : B := True);
- procedure Set_Is_Dispatch_Table_Entity (Id : E; V : B := True);
- procedure Set_Is_Dispatching_Operation (Id : E; V : B := True);
- procedure Set_Is_Elaboration_Checks_OK_Id (Id : E; V : B := True);
- procedure Set_Is_Elaboration_Warnings_OK_Id (Id : E; V : B := True);
- procedure Set_Is_Eliminated (Id : E; V : B := True);
- procedure Set_Is_Entry_Formal (Id : E; V : B := True);
- procedure Set_Is_Entry_Wrapper (Id : E; V : B := True);
- procedure Set_Is_Exception_Handler (Id : E; V : B := True);
- procedure Set_Is_Exported (Id : E; V : B := True);
- procedure Set_Is_Finalized_Transient (Id : E; V : B := True);
- procedure Set_Is_First_Subtype (Id : E; V : B := True);
- procedure Set_Is_Formal_Subprogram (Id : E; V : B := True);
- procedure Set_Is_Frozen (Id : E; V : B := True);
- procedure Set_Is_Generic_Actual_Subprogram (Id : E; V : B := True);
- procedure Set_Is_Generic_Actual_Type (Id : E; V : B := True);
- procedure Set_Is_Generic_Instance (Id : E; V : B := True);
- procedure Set_Is_Generic_Type (Id : E; V : B := True);
- procedure Set_Is_Hidden (Id : E; V : B := True);
- procedure Set_Is_Hidden_Non_Overridden_Subpgm (Id : E; V : B := True);
- procedure Set_Is_Hidden_Open_Scope (Id : E; V : B := True);
- procedure Set_Is_Ignored_Ghost_Entity (Id : E; V : B := True);
- procedure Set_Is_Ignored_Transient (Id : E; V : B := True);
- procedure Set_Is_Immediately_Visible (Id : E; V : B := True);
- procedure Set_Is_Implementation_Defined (Id : E; V : B := True);
- procedure Set_Is_Imported (Id : E; V : B := True);
- procedure Set_Is_Independent (Id : E; V : B := True);
- procedure Set_Is_Initial_Condition_Procedure (Id : E; V : B := True);
- procedure Set_Is_Inlined (Id : E; V : B := True);
- procedure Set_Is_Inlined_Always (Id : E; V : B := True);
- procedure Set_Is_Instantiated (Id : E; V : B := True);
- procedure Set_Is_Interface (Id : E; V : B := True);
- procedure Set_Is_Internal (Id : E; V : B := True);
- procedure Set_Is_Interrupt_Handler (Id : E; V : B := True);
- procedure Set_Is_Intrinsic_Subprogram (Id : E; V : B := True);
- procedure Set_Is_Invariant_Procedure (Id : E; V : B := True);
- procedure Set_Is_Itype (Id : E; V : B := True);
- procedure Set_Is_Known_Non_Null (Id : E; V : B := True);
- procedure Set_Is_Known_Null (Id : E; V : B := True);
- procedure Set_Is_Known_Valid (Id : E; V : B := True);
- procedure Set_Is_Limited_Composite (Id : E; V : B := True);
- procedure Set_Is_Limited_Interface (Id : E; V : B := True);
- procedure Set_Is_Limited_Record (Id : E; V : B := True);
- procedure Set_Is_Local_Anonymous_Access (Id : E; V : B := True);
- procedure Set_Is_Loop_Parameter (Id : E; V : B := True);
- procedure Set_Is_Machine_Code_Subprogram (Id : E; V : B := True);
- procedure Set_Is_Non_Static_Subtype (Id : E; V : B := True);
- procedure Set_Is_Null_Init_Proc (Id : E; V : B := True);
- procedure Set_Is_Obsolescent (Id : E; V : B := True);
- procedure Set_Is_Only_Out_Parameter (Id : E; V : B := True);
- procedure Set_Is_Package_Body_Entity (Id : E; V : B := True);
- procedure Set_Is_Packed (Id : E; V : B := True);
- procedure Set_Is_Packed_Array_Impl_Type (Id : E; V : B := True);
- procedure Set_Is_Param_Block_Component_Type (Id : E; V : B := True);
- procedure Set_Is_Partial_Invariant_Procedure (Id : E; V : B := True);
- procedure Set_Is_Potentially_Use_Visible (Id : E; V : B := True);
- procedure Set_Is_Predicate_Function (Id : E; V : B := True);
- procedure Set_Is_Predicate_Function_M (Id : E; V : B := True);
- procedure Set_Is_Preelaborated (Id : E; V : B := True);
- procedure Set_Is_Primitive (Id : E; V : B := True);
- procedure Set_Is_Primitive_Wrapper (Id : E; V : B := True);
- procedure Set_Is_Private_Composite (Id : E; V : B := True);
- procedure Set_Is_Private_Descendant (Id : E; V : B := True);
- procedure Set_Is_Private_Primitive (Id : E; V : B := True);
- procedure Set_Is_Public (Id : E; V : B := True);
- procedure Set_Is_Pure (Id : E; V : B := True);
- procedure Set_Is_Pure_Unit_Access_Type (Id : E; V : B := True);
- procedure Set_Is_RACW_Stub_Type (Id : E; V : B := True);
- procedure Set_Is_Raised (Id : E; V : B := True);
- procedure Set_Is_Remote_Call_Interface (Id : E; V : B := True);
- procedure Set_Is_Remote_Types (Id : E; V : B := True);
- procedure Set_Is_Renaming_Of_Object (Id : E; V : B := True);
- procedure Set_Is_Return_Object (Id : E; V : B := True);
- procedure Set_Is_Safe_To_Reevaluate (Id : E; V : B := True);
- procedure Set_Is_Shared_Passive (Id : E; V : B := True);
- procedure Set_Is_Static_Type (Id : E; V : B := True);
- procedure Set_Is_Statically_Allocated (Id : E; V : B := True);
- procedure Set_Is_Tag (Id : E; V : B := True);
- procedure Set_Is_Tagged_Type (Id : E; V : B := True);
- procedure Set_Is_Thunk (Id : E; V : B := True);
- procedure Set_Is_Trivial_Subprogram (Id : E; V : B := True);
- procedure Set_Is_True_Constant (Id : E; V : B := True);
- procedure Set_Is_Unchecked_Union (Id : E; V : B := True);
- procedure Set_Is_Underlying_Full_View (Id : E; V : B := True);
- procedure Set_Is_Underlying_Record_View (Id : E; V : B := True);
- procedure Set_Is_Unimplemented (Id : E; V : B := True);
- procedure Set_Is_Unsigned_Type (Id : E; V : B := True);
- procedure Set_Is_Uplevel_Referenced_Entity (Id : E; V : B := True);
- procedure Set_Is_Valued_Procedure (Id : E; V : B := True);
- procedure Set_Is_Visible_Formal (Id : E; V : B := True);
- procedure Set_Is_Visible_Lib_Unit (Id : E; V : B := True);
- procedure Set_Is_Volatile (Id : E; V : B := True);
- procedure Set_Is_Volatile_Full_Access (Id : E; V : B := True);
- procedure Set_Itype_Printed (Id : E; V : B := True);
- procedure Set_Kill_Elaboration_Checks (Id : E; V : B := True);
- procedure Set_Kill_Range_Checks (Id : E; V : B := True);
- procedure Set_Known_To_Have_Preelab_Init (Id : E; V : B := True);
- procedure Set_Last_Aggregate_Assignment (Id : E; V : N);
- procedure Set_Last_Assignment (Id : E; V : N);
- procedure Set_Last_Entity (Id : E; V : E);
- procedure Set_Limited_View (Id : E; V : E);
- procedure Set_Linker_Section_Pragma (Id : E; V : N);
- procedure Set_Lit_Indexes (Id : E; V : E);
- procedure Set_Lit_Strings (Id : E; V : E);
- procedure Set_Low_Bound_Tested (Id : E; V : B := True);
- procedure Set_Machine_Radix_10 (Id : E; V : B := True);
- procedure Set_Master_Id (Id : E; V : E);
- procedure Set_Materialize_Entity (Id : E; V : B := True);
- procedure Set_May_Inherit_Delayed_Rep_Aspects (Id : E; V : B := True);
- procedure Set_Mechanism (Id : E; V : M);
- procedure Set_Minimum_Accessibility (Id : E; V : E);
- procedure Set_Modulus (Id : E; V : U);
- procedure Set_Must_Be_On_Byte_Boundary (Id : E; V : B := True);
- procedure Set_Must_Have_Preelab_Init (Id : E; V : B := True);
- procedure Set_Needs_Activation_Record (Id : E; V : B := True);
- procedure Set_Needs_Debug_Info (Id : E; V : B := True);
- procedure Set_Needs_No_Actuals (Id : E; V : B := True);
- procedure Set_Never_Set_In_Source (Id : E; V : B := True);
- procedure Set_Next_Inlined_Subprogram (Id : E; V : E);
- procedure Set_No_Dynamic_Predicate_On_Actual (Id : E; V : B := True);
- procedure Set_No_Pool_Assigned (Id : E; V : B := True);
- procedure Set_No_Predicate_On_Actual (Id : E; V : B := True);
- procedure Set_No_Reordering (Id : E; V : B := True);
- procedure Set_No_Return (Id : E; V : B := True);
- procedure Set_No_Strict_Aliasing (Id : E; V : B := True);
- procedure Set_No_Tagged_Streams_Pragma (Id : E; V : N);
- procedure Set_Non_Binary_Modulus (Id : E; V : B := True);
- procedure Set_Non_Limited_View (Id : E; V : E);
- procedure Set_Nonzero_Is_True (Id : E; V : B := True);
- procedure Set_Normalized_First_Bit (Id : E; V : U);
- procedure Set_Normalized_Position (Id : E; V : U);
- procedure Set_Normalized_Position_Max (Id : E; V : U);
- procedure Set_OK_To_Rename (Id : E; V : B := True);
- procedure Set_Optimize_Alignment_Space (Id : E; V : B := True);
- procedure Set_Optimize_Alignment_Time (Id : E; V : B := True);
- procedure Set_Original_Access_Type (Id : E; V : E);
- procedure Set_Original_Array_Type (Id : E; V : E);
- procedure Set_Original_Protected_Subprogram (Id : E; V : N);
- procedure Set_Original_Record_Component (Id : E; V : E);
- procedure Set_Overlays_Constant (Id : E; V : B := True);
- procedure Set_Overridden_Operation (Id : E; V : E);
- procedure Set_Package_Instantiation (Id : E; V : N);
- procedure Set_Packed_Array_Impl_Type (Id : E; V : E);
- procedure Set_Parent_Subtype (Id : E; V : E);
- procedure Set_Part_Of_Constituents (Id : E; V : L);
- procedure Set_Part_Of_References (Id : E; V : L);
- procedure Set_Partial_View_Has_Unknown_Discr (Id : E; V : B := True);
- procedure Set_Pending_Access_Types (Id : E; V : L);
- procedure Set_Postconditions_Proc (Id : E; V : E);
- procedure Set_Prev_Entity (Id : E; V : E);
- procedure Set_Prival (Id : E; V : E);
- procedure Set_Prival_Link (Id : E; V : E);
- procedure Set_Private_Dependents (Id : E; V : L);
- procedure Set_Protected_Body_Subprogram (Id : E; V : E);
- procedure Set_Protected_Formal (Id : E; V : E);
- procedure Set_Protected_Subprogram (Id : E; V : N);
- procedure Set_Protection_Object (Id : E; V : E);
- procedure Set_Reachable (Id : E; V : B := True);
- procedure Set_Receiving_Entry (Id : E; V : E);
- procedure Set_Referenced (Id : E; V : B := True);
- procedure Set_Referenced_As_LHS (Id : E; V : B := True);
- procedure Set_Referenced_As_Out_Parameter (Id : E; V : B := True);
- procedure Set_Refinement_Constituents (Id : E; V : L);
- procedure Set_Register_Exception_Call (Id : E; V : N);
- procedure Set_Related_Array_Object (Id : E; V : E);
- procedure Set_Related_Expression (Id : E; V : N);
- procedure Set_Related_Instance (Id : E; V : E);
- procedure Set_Related_Type (Id : E; V : E);
- procedure Set_Relative_Deadline_Variable (Id : E; V : E);
- procedure Set_Renamed_Entity (Id : E; V : N);
- procedure Set_Renamed_In_Spec (Id : E; V : B := True);
- procedure Set_Renamed_Object (Id : E; V : N);
- procedure Set_Renaming_Map (Id : E; V : U);
- procedure Set_Requires_Overriding (Id : E; V : B := True);
- procedure Set_Return_Applies_To (Id : E; V : N);
- procedure Set_Return_Present (Id : E; V : B := True);
- procedure Set_Returns_By_Ref (Id : E; V : B := True);
- procedure Set_Reverse_Bit_Order (Id : E; V : B := True);
- procedure Set_Reverse_Storage_Order (Id : E; V : B := True);
- procedure Set_Rewritten_For_C (Id : E; V : B := True);
- procedure Set_RM_Size (Id : E; V : U);
- procedure Set_Scalar_Range (Id : E; V : N);
- procedure Set_Scale_Value (Id : E; V : U);
- procedure Set_Scope_Depth_Value (Id : E; V : U);
- procedure Set_Sec_Stack_Needed_For_Return (Id : E; V : B := True);
- procedure Set_Shared_Var_Procs_Instance (Id : E; V : E);
- procedure Set_Size_Check_Code (Id : E; V : N);
- procedure Set_Size_Depends_On_Discriminant (Id : E; V : B := True);
- procedure Set_Size_Known_At_Compile_Time (Id : E; V : B := True);
- procedure Set_Small_Value (Id : E; V : R);
- procedure Set_SPARK_Aux_Pragma (Id : E; V : N);
- procedure Set_SPARK_Aux_Pragma_Inherited (Id : E; V : B := True);
- procedure Set_SPARK_Pragma (Id : E; V : N);
- procedure Set_SPARK_Pragma_Inherited (Id : E; V : B := True);
- procedure Set_Spec_Entity (Id : E; V : E);
- procedure Set_SSO_Set_High_By_Default (Id : E; V : B := True);
- procedure Set_SSO_Set_Low_By_Default (Id : E; V : B := True);
- procedure Set_Static_Discrete_Predicate (Id : E; V : S);
- procedure Set_Static_Elaboration_Desired (Id : E; V : B);
- procedure Set_Static_Initialization (Id : E; V : N);
- procedure Set_Static_Real_Or_String_Predicate (Id : E; V : N);
- procedure Set_Status_Flag_Or_Transient_Decl (Id : E; V : E);
- procedure Set_Storage_Size_Variable (Id : E; V : E);
- procedure Set_Stored_Constraint (Id : E; V : L);
- procedure Set_Stores_Attribute_Old_Prefix (Id : E; V : B := True);
- procedure Set_Strict_Alignment (Id : E; V : B := True);
- procedure Set_String_Literal_Length (Id : E; V : U);
- procedure Set_String_Literal_Low_Bound (Id : E; V : N);
- procedure Set_Subprograms_For_Type (Id : E; V : L);
- procedure Set_Subps_Index (Id : E; V : U);
- procedure Set_Suppress_Elaboration_Warnings (Id : E; V : B := True);
- procedure Set_Suppress_Initialization (Id : E; V : B := True);
- procedure Set_Suppress_Style_Checks (Id : E; V : B := True);
- procedure Set_Suppress_Value_Tracking_On_Call (Id : E; V : B := True);
- procedure Set_Task_Body_Procedure (Id : E; V : N);
- procedure Set_Thunk_Entity (Id : E; V : E);
- procedure Set_Treat_As_Volatile (Id : E; V : B := True);
- procedure Set_Underlying_Full_View (Id : E; V : E);
- procedure Set_Underlying_Record_View (Id : E; V : E);
- procedure Set_Universal_Aliasing (Id : E; V : B := True);
- procedure Set_Unset_Reference (Id : E; V : N);
- procedure Set_Used_As_Generic_Actual (Id : E; V : B := True);
- procedure Set_Uses_Lock_Free (Id : E; V : B := True);
- procedure Set_Uses_Sec_Stack (Id : E; V : B := True);
- procedure Set_Validated_Object (Id : E; V : N);
- procedure Set_Warnings_Off (Id : E; V : B := True);
- procedure Set_Warnings_Off_Used (Id : E; V : B := True);
- procedure Set_Warnings_Off_Used_Unmodified (Id : E; V : B := True);
- procedure Set_Warnings_Off_Used_Unreferenced (Id : E; V : B := True);
- procedure Set_Was_Hidden (Id : E; V : B := True);
- procedure Set_Wrapped_Entity (Id : E; V : E);
-
- ---------------------------------------------------
- -- Access to Subprograms in Subprograms_For_Type --
- ---------------------------------------------------
-
- function DIC_Procedure (Id : E) return E;
- function Partial_DIC_Procedure (Id : E) return E;
- function Invariant_Procedure (Id : E) return E;
- function Partial_Invariant_Procedure (Id : E) return E;
- function Predicate_Function (Id : E) return E;
- function Predicate_Function_M (Id : E) return E;
-
- procedure Set_DIC_Procedure (Id : E; V : E);
- procedure Set_Partial_DIC_Procedure (Id : E; V : E);
- procedure Set_Invariant_Procedure (Id : E; V : E);
- procedure Set_Partial_Invariant_Procedure (Id : E; V : E);
- procedure Set_Predicate_Function (Id : E; V : E);
- procedure Set_Predicate_Function_M (Id : E; V : E);
-
- -----------------------------------
- -- Field Initialization Routines --
- -----------------------------------
-
- -- These routines are overloadings of some of the above Set procedures
- -- where the argument is normally a Uint. The overloadings take an Int
- -- parameter instead, and appropriately convert it. There are also
- -- versions that implicitly initialize to the appropriate "not set"
- -- value. The not set (unknown) values are as follows:
-
- -- Alignment Uint_0
- -- Component_Size Uint_0
- -- Component_Bit_Offset No_Uint
- -- Digits_Value Uint_0
- -- Esize Uint_0
- -- Normalized_First_Bit No_Uint
- -- Normalized_Position No_Uint
- -- Normalized_Position_Max No_Uint
- -- RM_Size Uint_0
-
- -- It would be cleaner to use No_Uint in all these cases, but historically
- -- we chose to use Uint_0 at first, and the change over will take time ???
- -- This is particularly true for the RM_Size field, where a value of zero
- -- is legitimate and causes some special tests around the code.
-
- -- Contrary to the corresponding Set procedures above, these routines
- -- do NOT check the entity kind of their argument, instead they set the
- -- underlying Uint fields directly (this allows them to be used for
- -- entities whose Ekind has not been set yet).
-
- procedure Init_Alignment (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);
- procedure Init_Normalized_Position (Id : E; V : Int);
- procedure Init_Normalized_Position_Max (Id : E; V : Int);
- procedure Init_RM_Size (Id : E; V : Int);
-
- procedure Init_Alignment (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);
- procedure Init_Normalized_Position (Id : E);
- 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.
-
- procedure Init_Object_Size_Align (Id : E);
- -- Same as Init_Size_Align except RM_Size field (which is only for types)
- -- is unaffected.
-
- ---------------
- -- Iterators --
- ---------------
-
- -- The call to Next_xxx (obj) is equivalent to obj := Next_xxx (obj)
- -- We define the set of Proc_Next_xxx routines simply for the purposes
- -- of inlining them without necessarily inlining the function.
-
- procedure Proc_Next_Component (N : in out Node_Id);
- procedure Proc_Next_Component_Or_Discriminant (N : in out Node_Id);
- procedure Proc_Next_Discriminant (N : in out Node_Id);
- procedure Proc_Next_Formal (N : in out Node_Id);
- procedure Proc_Next_Formal_With_Extras (N : in out Node_Id);
- procedure Proc_Next_Index (N : in out Node_Id);
- procedure Proc_Next_Inlined_Subprogram (N : in out Node_Id);
- procedure Proc_Next_Literal (N : in out Node_Id);
- procedure Proc_Next_Stored_Discriminant (N : in out Node_Id);
-
- pragma Inline (Proc_Next_Component);
- pragma Inline (Proc_Next_Component_Or_Discriminant);
- pragma Inline (Proc_Next_Discriminant);
- pragma Inline (Proc_Next_Formal);
- pragma Inline (Proc_Next_Formal_With_Extras);
- pragma Inline (Proc_Next_Index);
- pragma Inline (Proc_Next_Inlined_Subprogram);
- pragma Inline (Proc_Next_Literal);
- pragma Inline (Proc_Next_Stored_Discriminant);
-
- procedure Next_Component (N : in out Node_Id)
- renames Proc_Next_Component;
-
- procedure Next_Component_Or_Discriminant (N : in out Node_Id)
- renames Proc_Next_Component_Or_Discriminant;
-
- procedure Next_Discriminant (N : in out Node_Id)
- renames Proc_Next_Discriminant;
-
- procedure Next_Formal (N : in out Node_Id)
- renames Proc_Next_Formal;
-
- procedure Next_Formal_With_Extras (N : in out Node_Id)
- renames Proc_Next_Formal_With_Extras;
-
- procedure Next_Index (N : in out Node_Id)
- renames Proc_Next_Index;
-
- procedure Next_Inlined_Subprogram (N : in out Node_Id)
- renames Proc_Next_Inlined_Subprogram;
-
- procedure Next_Literal (N : in out Node_Id)
- renames Proc_Next_Literal;
-
- procedure Next_Stored_Discriminant (N : in out Node_Id)
- renames Proc_Next_Stored_Discriminant;
-
- ---------------------------
- -- Testing Warning Flags --
- ---------------------------
-
- -- These routines are to be used rather than testing flags Warnings_Off,
- -- Has_Pragma_Unmodified, Has_Pragma_Unreferenced. They deal with setting
- -- the flags Warnings_Off_Used[_Unmodified|Unreferenced] for later access.
-
- function Has_Warnings_Off (E : Entity_Id) return Boolean;
- -- If Warnings_Off is set on E, then returns True and also sets the flag
- -- Warnings_Off_Used on E. If Warnings_Off is not set on E, returns False
- -- and has no side effect.
-
- function Has_Unmodified (E : Entity_Id) return Boolean;
- -- If flag Has_Pragma_Unmodified is set on E, returns True with no side
- -- effects. Otherwise if Warnings_Off is set on E, returns True and also
- -- sets the flag Warnings_Off_Used_Unmodified on E. If neither of the flags
- -- Warnings_Off nor Has_Pragma_Unmodified is set, returns False with no
- -- side effects.
-
- function Has_Unreferenced (E : Entity_Id) return Boolean;
- -- If flag Has_Pragma_Unreferenced is set on E, returns True with no side
- -- effects. Otherwise if Warnings_Off is set on E, returns True and also
- -- sets the flag Warnings_Off_Used_Unreferenced on E. If neither of the
- -- flags Warnings_Off nor Has_Pragma_Unreferenced is set, returns False
- -- with no side effects.
-
- ----------------------------------------------
- -- Subprograms for Accessing Rep Item Chain --
- ----------------------------------------------
-
- -- The First_Rep_Item field of every entity points to a linked list (linked
- -- through Next_Rep_Item) of representation pragmas, attribute definition
- -- clauses, representation clauses, and aspect specifications that apply to
- -- the item. Note that in the case of types, it is assumed that any such
- -- rep items for a base type also apply to all subtypes. This is achieved
- -- by having the chain for subtypes link onto the chain for the base type,
- -- so that new entries for the subtype are added at the start of the chain.
- --
- -- Note: aspect specification nodes are linked only when evaluation of the
- -- expression is deferred to the freeze point. For further details see
- -- Sem_Ch13.Analyze_Aspect_Specifications.
-
- function Get_Attribute_Definition_Clause
- (E : Entity_Id;
- Id : Attribute_Id) return Node_Id;
- -- Searches the Rep_Item chain for a given entity E, for an instance of an
- -- attribute definition clause with the given attribute Id. If found, the
- -- value returned is the N_Attribute_Definition_Clause node, otherwise
- -- Empty is returned.
-
- -- WARNING: There is a matching C declaration of this subprogram in fe.h
-
- function Get_Pragma (E : Entity_Id; Id : Pragma_Id) return Node_Id;
- -- Searches the Rep_Item chain of entity E, for an instance of a pragma
- -- with the given pragma Id. If found, the value returned is the N_Pragma
- -- node, otherwise Empty is returned. The following contract pragmas that
- -- appear in N_Contract nodes are also handled by this routine:
- -- Abstract_State
- -- Async_Readers
- -- Async_Writers
- -- Attach_Handler
- -- Constant_After_Elaboration
- -- Contract_Cases
- -- Depends
- -- Effective_Reads
- -- Effective_Writes
- -- Global
- -- Initial_Condition
- -- Initializes
- -- Interrupt_Handler
- -- No_Caching
- -- Part_Of
- -- Precondition
- -- Postcondition
- -- Refined_Depends
- -- Refined_Global
- -- Refined_Post
- -- Refined_State
- -- Subprogram_Variant
- -- Test_Case
- -- Volatile_Function
-
- function Get_Class_Wide_Pragma
- (E : Entity_Id;
- Id : Pragma_Id) return Node_Id;
- -- Examine Rep_Item chain to locate a classwide pre- or postcondition of a
- -- primitive operation. Returns Empty if not present.
-
- function Get_Record_Representation_Clause (E : Entity_Id) return Node_Id;
- -- Searches the Rep_Item chain for a given entity E, for a record
- -- representation clause, and if found, returns it. Returns Empty
- -- if no such clause is found.
-
- function Present_In_Rep_Item (E : Entity_Id; N : Node_Id) return Boolean;
- -- Return True if N is present in the Rep_Item chain for a given entity E
-
- procedure Record_Rep_Item (E : Entity_Id; N : Node_Id);
- -- N is the node for a representation pragma, representation clause, an
- -- attribute definition clause, or an aspect specification that applies to
- -- entity E. This procedure links the node N onto the Rep_Item chain for
- -- entity E. Note that it is an error to call this procedure with E being
- -- overloadable, and N being a pragma that applies to multiple overloadable
- -- entities (Convention, Interface, Inline, Inline_Always, Import, Export,
- -- External). This is not allowed even in the case where the entity is not
- -- overloaded, since we can't rely on it being present in the overloaded
- -- case, it is not useful to have it present in the non-overloaded case.
-
- -------------------------------
- -- Miscellaneous Subprograms --
- -------------------------------
-
- procedure Append_Entity (Id : Entity_Id; Scop : Entity_Id);
- -- Add an entity to the list of entities declared in the scope Scop
-
- function Get_Full_View (T : Entity_Id) return Entity_Id;
- -- If T is an incomplete type and the full declaration has been seen, or
- -- is the name of a class_wide type whose root is incomplete, return the
- -- corresponding full declaration, else return T itself.
-
- function Is_Entity_Name (N : Node_Id) return Boolean;
- -- Test if the node N is the name of an entity (i.e. is an identifier,
- -- expanded name, or an attribute reference that returns an entity).
-
- -- WARNING: There is a matching C declaration of this subprogram in fe.h
-
- procedure Link_Entities (First : Entity_Id; Second : Entity_Id);
- -- Link entities First and Second in one entity chain.
- --
- -- NOTE: No updates are done to the First_Entity and Last_Entity fields
- -- of the scope.
-
- procedure Remove_Entity (Id : Entity_Id);
- -- Remove entity Id from the entity chain of its 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
- -- example if K is E_Signed_Integer_Type then E_Signed_Integer_Subtype
- -- is returned. If K is already a subtype kind it itself is returned. An
- -- internal error is generated if no such correspondence exists for K.
-
- procedure Unlink_Next_Entity (Id : Entity_Id);
- -- Unchain entity Id's forward link within the entity chain of its scope
-
- ----------------------------------
- -- Debugging Output Subprograms --
- ----------------------------------
-
- procedure Write_Entity_Flags (Id : Entity_Id; Prefix : String);
- -- Writes a series of entries giving a line for each flag that is
- -- set to True. Each line is prefixed by the given string.
-
- procedure Write_Entity_Info (Id : Entity_Id; Prefix : String);
- -- A debugging procedure to write out information about an entity
-
- procedure Write_Field6_Name (Id : Entity_Id);
- procedure Write_Field7_Name (Id : Entity_Id);
- procedure Write_Field8_Name (Id : Entity_Id);
- procedure Write_Field9_Name (Id : Entity_Id);
- procedure Write_Field10_Name (Id : Entity_Id);
- procedure Write_Field11_Name (Id : Entity_Id);
- procedure Write_Field12_Name (Id : Entity_Id);
- procedure Write_Field13_Name (Id : Entity_Id);
- procedure Write_Field14_Name (Id : Entity_Id);
- procedure Write_Field15_Name (Id : Entity_Id);
- procedure Write_Field16_Name (Id : Entity_Id);
- procedure Write_Field17_Name (Id : Entity_Id);
- procedure Write_Field18_Name (Id : Entity_Id);
- procedure Write_Field19_Name (Id : Entity_Id);
- procedure Write_Field20_Name (Id : Entity_Id);
- procedure Write_Field21_Name (Id : Entity_Id);
- procedure Write_Field22_Name (Id : Entity_Id);
- procedure Write_Field23_Name (Id : Entity_Id);
- procedure Write_Field24_Name (Id : Entity_Id);
- procedure Write_Field25_Name (Id : Entity_Id);
- procedure Write_Field26_Name (Id : Entity_Id);
- procedure Write_Field27_Name (Id : Entity_Id);
- procedure Write_Field28_Name (Id : Entity_Id);
- procedure Write_Field29_Name (Id : Entity_Id);
- procedure Write_Field30_Name (Id : Entity_Id);
- procedure Write_Field31_Name (Id : Entity_Id);
- procedure Write_Field32_Name (Id : Entity_Id);
- procedure Write_Field33_Name (Id : Entity_Id);
- procedure Write_Field34_Name (Id : Entity_Id);
- procedure Write_Field35_Name (Id : Entity_Id);
- procedure Write_Field36_Name (Id : Entity_Id);
- procedure Write_Field37_Name (Id : Entity_Id);
- procedure Write_Field38_Name (Id : Entity_Id);
- procedure Write_Field39_Name (Id : Entity_Id);
- procedure Write_Field40_Name (Id : Entity_Id);
- procedure Write_Field41_Name (Id : Entity_Id);
- -- These routines are used in Treepr to output a nice symbolic name for
- -- the given field, depending on the Ekind. No blanks or end of lines are
- -- output, just the characters of the field name.
-
- ----------------------------------
- -- 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
- -- subprograms meeting the requirements documented in the section on
- -- XEINFO may be referenced in this section.
-
- pragma Inline (Abstract_States);
- 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);
- pragma Inline (Alias);
- pragma Inline (Alignment);
- pragma Inline (Anonymous_Designated_Type);
- pragma Inline (Anonymous_Masters);
- pragma Inline (Anonymous_Object);
- pragma Inline (Associated_Entity);
- pragma Inline (Associated_Formal_Package);
- pragma Inline (Associated_Node_For_Itype);
- pragma Inline (Associated_Storage_Pool);
- pragma Inline (Barrier_Function);
- pragma Inline (BIP_Initialization_Call);
- pragma Inline (Block_Node);
- pragma Inline (Body_Entity);
- pragma Inline (Body_Needed_For_Inlining);
- pragma Inline (Body_Needed_For_SAL);
- pragma Inline (Body_References);
- pragma Inline (C_Pass_By_Copy);
- pragma Inline (Can_Never_Be_Null);
- pragma Inline (Can_Use_Internal_Rep);
- pragma Inline (Checks_May_Be_Suppressed);
- pragma Inline (Class_Wide_Clone);
- pragma Inline (Class_Wide_Type);
- pragma Inline (Cloned_Subtype);
- pragma Inline (Component_Bit_Offset);
- pragma Inline (Component_Clause);
- pragma Inline (Component_Size);
- pragma Inline (Component_Type);
- pragma Inline (Contains_Ignored_Ghost_Code);
- pragma Inline (Contract);
- pragma Inline (Contract_Wrapper);
- 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);
- pragma Inline (Corresponding_Remote_Type);
- pragma Inline (CR_Discriminant);
- pragma Inline (Current_Use_Clause);
- pragma Inline (Current_Value);
- pragma Inline (Debug_Info_Off);
- pragma Inline (Debug_Renaming_Link);
- pragma Inline (Default_Aspect_Component_Value);
- pragma Inline (Default_Aspect_Value);
- pragma Inline (Default_Expr_Function);
- pragma Inline (Default_Expressions_Processed);
- pragma Inline (Default_Value);
- pragma Inline (Delay_Cleanups);
- pragma Inline (Delay_Subprogram_Descriptors);
- pragma Inline (Delta_Value);
- pragma Inline (Dependent_Instances);
- pragma Inline (Depends_On_Private);
- pragma Inline (Derived_Type_Link);
- pragma Inline (Digits_Value);
- pragma Inline (Direct_Primitive_Operations);
- pragma Inline (Directly_Designated_Type);
- pragma Inline (Disable_Controlled);
- pragma Inline (Discard_Names);
- pragma Inline (Discriminal);
- pragma Inline (Discriminal_Link);
- pragma Inline (Discriminant_Checking_Func);
- pragma Inline (Discriminant_Constraint);
- pragma Inline (Discriminant_Default_Value);
- pragma Inline (Discriminant_Number);
- pragma Inline (Dispatch_Table_Wrappers);
- pragma Inline (DT_Entry_Count);
- pragma Inline (DT_Offset_To_Top_Func);
- pragma Inline (DT_Position);
- pragma Inline (DTC_Entity);
- pragma Inline (Elaborate_Body_Desirable);
- pragma Inline (Elaboration_Entity);
- pragma Inline (Elaboration_Entity_Required);
- pragma Inline (Encapsulating_State);
- pragma Inline (Enclosing_Scope);
- pragma Inline (Entry_Accepted);
- pragma Inline (Entry_Bodies_Array);
- pragma Inline (Entry_Cancel_Parameter);
- pragma Inline (Entry_Component);
- 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);
- pragma Inline (Enumeration_Rep);
- pragma Inline (Enumeration_Rep_Expr);
- pragma Inline (Equivalent_Type);
- pragma Inline (Esize);
- pragma Inline (Extra_Accessibility);
- pragma Inline (Extra_Accessibility_Of_Result);
- 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);
- pragma Inline (First_Exit_Statement);
- pragma Inline (First_Index);
- pragma Inline (First_Literal);
- pragma Inline (First_Private_Entity);
- pragma Inline (First_Rep_Item);
- pragma Inline (Freeze_Node);
- pragma Inline (From_Limited_With);
- pragma Inline (Full_View);
- pragma Inline (Generic_Homonym);
- pragma Inline (Generic_Renamings);
- pragma Inline (Handler_Records);
- pragma Inline (Has_Aliased_Components);
- pragma Inline (Has_Alignment_Clause);
- pragma Inline (Has_All_Calls_Remote);
- pragma Inline (Has_Atomic_Components);
- pragma Inline (Has_Biased_Representation);
- pragma Inline (Has_Completion);
- pragma Inline (Has_Completion_In_Body);
- pragma Inline (Has_Complex_Representation);
- pragma Inline (Has_Component_Size_Clause);
- pragma Inline (Has_Constrained_Partial_View);
- pragma Inline (Has_Contiguous_Rep);
- pragma Inline (Has_Controlled_Component);
- pragma Inline (Has_Controlling_Result);
- pragma Inline (Has_Convention_Pragma);
- pragma Inline (Has_Default_Aspect);
- 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);
- pragma Inline (Has_Enumeration_Rep_Clause);
- pragma Inline (Has_Exit);
- pragma Inline (Has_Expanded_Contract);
- pragma Inline (Has_Forward_Instantiation);
- pragma Inline (Has_Fully_Qualified_Name);
- pragma Inline (Has_Gigi_Rep_Item);
- pragma Inline (Has_Homonym);
- pragma Inline (Has_Implicit_Dereference);
- pragma Inline (Has_Independent_Components);
- pragma Inline (Has_Inheritable_Invariants);
- 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);
- pragma Inline (Has_Missing_Return);
- pragma Inline (Has_Nested_Block_With_Handler);
- pragma Inline (Has_Nested_Subprogram);
- pragma Inline (Has_Non_Standard_Rep);
- pragma Inline (Has_Object_Size_Clause);
- pragma Inline (Has_Out_Or_In_Out_Parameter);
- pragma Inline (Has_Own_DIC);
- pragma Inline (Has_Own_Invariants);
- pragma Inline (Has_Partial_Visible_Refinement);
- pragma Inline (Has_Per_Object_Constraint);
- pragma Inline (Has_Pragma_Controlled);
- pragma Inline (Has_Pragma_Elaborate_Body);
- pragma Inline (Has_Pragma_Inline);
- pragma Inline (Has_Pragma_Inline_Always);
- pragma Inline (Has_Pragma_No_Inline);
- pragma Inline (Has_Pragma_Ordered);
- pragma Inline (Has_Pragma_Pack);
- pragma Inline (Has_Pragma_Preelab_Init);
- pragma Inline (Has_Pragma_Pure);
- pragma Inline (Has_Pragma_Pure_Function);
- pragma Inline (Has_Pragma_Thread_Local_Storage);
- pragma Inline (Has_Pragma_Unmodified);
- pragma Inline (Has_Pragma_Unreferenced);
- pragma Inline (Has_Pragma_Unreferenced_Objects);
- pragma Inline (Has_Pragma_Unused);
- pragma Inline (Has_Predicates);
- pragma Inline (Has_Primitive_Operations);
- pragma Inline (Has_Private_Ancestor);
- pragma Inline (Has_Private_Declaration);
- pragma Inline (Has_Private_Extension);
- pragma Inline (Has_Protected);
- pragma Inline (Has_Qualified_Name);
- pragma Inline (Has_RACW);
- pragma Inline (Has_Record_Rep_Clause);
- pragma Inline (Has_Recursive_Call);
- pragma Inline (Has_Shift_Operator);
- pragma Inline (Has_Size_Clause);
- pragma Inline (Has_Small_Clause);
- pragma Inline (Has_Specified_Layout);
- pragma Inline (Has_Specified_Stream_Input);
- pragma Inline (Has_Specified_Stream_Output);
- pragma Inline (Has_Specified_Stream_Read);
- pragma Inline (Has_Specified_Stream_Write);
- pragma Inline (Has_Static_Discriminants);
- pragma Inline (Has_Static_Predicate);
- pragma Inline (Has_Static_Predicate_Aspect);
- pragma Inline (Has_Storage_Size_Clause);
- pragma Inline (Has_Stream_Size_Clause);
- pragma Inline (Has_Task);
- pragma Inline (Has_Timing_Event);
- pragma Inline (Has_Thunks);
- pragma Inline (Has_Unchecked_Union);
- pragma Inline (Has_Unknown_Discriminants);
- 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);
- pragma Inline (Ignore_SPARK_Mode_Pragmas);
- pragma Inline (Import_Pragma);
- pragma Inline (Incomplete_Actuals);
- 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 (Is_Abstract_Subprogram);
- pragma Inline (Is_Abstract_Type);
- pragma Inline (Is_Access_Constant);
- pragma Inline (Is_Activation_Record);
- pragma Inline (Is_Actual_Subtype);
- pragma Inline (Is_Access_Protected_Subprogram_Type);
- pragma Inline (Is_Access_Subprogram_Type);
- pragma Inline (Is_Access_Type);
- pragma Inline (Is_Ada_2005_Only);
- 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);
- pragma Inline (Is_Atomic);
- pragma Inline (Is_Bit_Packed_Array);
- pragma Inline (Is_Called);
- pragma Inline (Is_Character_Type);
- pragma Inline (Is_Checked_Ghost_Entity);
- pragma Inline (Is_Child_Unit);
- pragma Inline (Is_Class_Wide_Clone);
- pragma Inline (Is_Class_Wide_Equivalent_Type);
- pragma Inline (Is_Class_Wide_Type);
- pragma Inline (Is_Compilation_Unit);
- pragma Inline (Is_Completely_Hidden);
- pragma Inline (Is_Composite_Type);
- pragma Inline (Is_Concurrent_Body);
- pragma Inline (Is_Concurrent_Record_Type);
- pragma Inline (Is_Concurrent_Type);
- pragma Inline (Is_Constr_Subt_For_U_Nominal);
- pragma Inline (Is_Constr_Subt_For_UN_Aliased);
- pragma Inline (Is_Constrained);
- pragma Inline (Is_Constructor);
- 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);
- pragma Inline (Is_Digits_Type);
- pragma Inline (Is_Discrete_Or_Fixed_Point_Type);
- pragma Inline (Is_Discrete_Type);
- pragma Inline (Is_Discrim_SO_Function);
- pragma Inline (Is_Discriminant_Check_Function);
- pragma Inline (Is_Dispatch_Table_Entity);
- pragma Inline (Is_Dispatching_Operation);
- pragma Inline (Is_Elaboration_Checks_OK_Id);
- pragma Inline (Is_Elaboration_Warnings_OK_Id);
- pragma Inline (Is_Elementary_Type);
- pragma Inline (Is_Eliminated);
- pragma Inline (Is_Entry);
- pragma Inline (Is_Entry_Formal);
- pragma Inline (Is_Entry_Wrapper);
- pragma Inline (Is_Enumeration_Type);
- pragma Inline (Is_Exception_Handler);
- pragma Inline (Is_Exported);
- pragma Inline (Is_Finalized_Transient);
- pragma Inline (Is_First_Subtype);
- pragma Inline (Is_Fixed_Point_Type);
- pragma Inline (Is_Floating_Point_Type);
- pragma Inline (Is_Formal);
- pragma Inline (Is_Formal_Object);
- pragma Inline (Is_Formal_Subprogram);
- pragma Inline (Is_Frozen);
- pragma Inline (Is_Full_Access);
- pragma Inline (Is_Generic_Actual_Subprogram);
- pragma Inline (Is_Generic_Actual_Type);
- pragma Inline (Is_Generic_Instance);
- pragma Inline (Is_Generic_Subprogram);
- pragma Inline (Is_Generic_Type);
- pragma Inline (Is_Generic_Unit);
- pragma Inline (Is_Ghost_Entity);
- pragma Inline (Is_Hidden);
- pragma Inline (Is_Hidden_Non_Overridden_Subpgm);
- pragma Inline (Is_Hidden_Open_Scope);
- pragma Inline (Is_Ignored_Ghost_Entity);
- pragma Inline (Is_Ignored_Transient);
- pragma Inline (Is_Immediately_Visible);
- pragma Inline (Is_Implementation_Defined);
- pragma Inline (Is_Imported);
- pragma Inline (Is_Incomplete_Or_Private_Type);
- pragma Inline (Is_Incomplete_Type);
- pragma Inline (Is_Independent);
- pragma Inline (Is_Initial_Condition_Procedure);
- pragma Inline (Is_Inlined);
- pragma Inline (Is_Inlined_Always);
- pragma Inline (Is_Instantiated);
- pragma Inline (Is_Integer_Type);
- pragma Inline (Is_Interface);
- pragma Inline (Is_Internal);
- pragma Inline (Is_Interrupt_Handler);
- pragma Inline (Is_Intrinsic_Subprogram);
- pragma Inline (Is_Invariant_Procedure);
- pragma Inline (Is_Itype);
- pragma Inline (Is_Known_Non_Null);
- pragma Inline (Is_Known_Null);
- pragma Inline (Is_Known_Valid);
- pragma Inline (Is_Limited_Composite);
- pragma Inline (Is_Limited_Interface);
- pragma Inline (Is_Limited_Record);
- pragma Inline (Is_Local_Anonymous_Access);
- pragma Inline (Is_Loop_Parameter);
- pragma Inline (Is_Machine_Code_Subprogram);
- pragma Inline (Is_Modular_Integer_Type);
- pragma Inline (Is_Named_Number);
- pragma Inline (Is_Non_Static_Subtype);
- pragma Inline (Is_Null_Init_Proc);
- pragma Inline (Is_Numeric_Type);
- pragma Inline (Is_Object);
- pragma Inline (Is_Obsolescent);
- pragma Inline (Is_Only_Out_Parameter);
- pragma Inline (Is_Ordinary_Fixed_Point_Type);
- pragma Inline (Is_Overloadable);
- pragma Inline (Is_Package_Body_Entity);
- pragma Inline (Is_Packed);
- pragma Inline (Is_Packed_Array_Impl_Type);
- pragma Inline (Is_Param_Block_Component_Type);
- pragma Inline (Is_Partial_Invariant_Procedure);
- pragma Inline (Is_Potentially_Use_Visible);
- pragma Inline (Is_Predicate_Function);
- pragma Inline (Is_Predicate_Function_M);
- pragma Inline (Is_Preelaborated);
- pragma Inline (Is_Primitive);
- pragma Inline (Is_Primitive_Wrapper);
- pragma Inline (Is_Private_Composite);
- pragma Inline (Is_Private_Descendant);
- pragma Inline (Is_Private_Primitive);
- pragma Inline (Is_Private_Type);
- pragma Inline (Is_Protected_Type);
- pragma Inline (Is_Public);
- pragma Inline (Is_Pure);
- pragma Inline (Is_Pure_Unit_Access_Type);
- pragma Inline (Is_RACW_Stub_Type);
- pragma Inline (Is_Raised);
- pragma Inline (Is_Real_Type);
- pragma Inline (Is_Record_Type);
- pragma Inline (Is_Remote_Call_Interface);
- pragma Inline (Is_Remote_Types);
- pragma Inline (Is_Renaming_Of_Object);
- pragma Inline (Is_Return_Object);
- pragma Inline (Is_Safe_To_Reevaluate);
- pragma Inline (Is_Scalar_Type);
- pragma Inline (Is_Shared_Passive);
- pragma Inline (Is_Signed_Integer_Type);
- 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);
- pragma Inline (Is_Thunk);
- pragma Inline (Is_Trivial_Subprogram);
- pragma Inline (Is_True_Constant);
- pragma Inline (Is_Type);
- pragma Inline (Is_Unchecked_Union);
- pragma Inline (Is_Underlying_Full_View);
- pragma Inline (Is_Underlying_Record_View);
- pragma Inline (Is_Unimplemented);
- pragma Inline (Is_Unsigned_Type);
- pragma Inline (Is_Uplevel_Referenced_Entity);
- pragma Inline (Is_Valued_Procedure);
- pragma Inline (Is_Visible_Formal);
- pragma Inline (Is_Visible_Lib_Unit);
- pragma Inline (Is_Volatile_Full_Access);
- pragma Inline (Itype_Printed);
- pragma Inline (Kill_Elaboration_Checks);
- pragma Inline (Kill_Range_Checks);
- pragma Inline (Known_To_Have_Preelab_Init);
- pragma Inline (Last_Aggregate_Assignment);
- pragma Inline (Last_Assignment);
- pragma Inline (Last_Entity);
- pragma Inline (Limited_View);
- pragma Inline (Link_Entities);
- pragma Inline (Linker_Section_Pragma);
- pragma Inline (Lit_Indexes);
- pragma Inline (Lit_Strings);
- pragma Inline (Low_Bound_Tested);
- pragma Inline (Machine_Radix_10);
- pragma Inline (Master_Id);
- pragma Inline (Materialize_Entity);
- pragma Inline (May_Inherit_Delayed_Rep_Aspects);
- pragma Inline (Mechanism);
- pragma Inline (Minimum_Accessibility);
- pragma Inline (Modulus);
- pragma Inline (Must_Be_On_Byte_Boundary);
- pragma Inline (Must_Have_Preelab_Init);
- pragma Inline (Needs_Activation_Record);
- pragma Inline (Needs_Debug_Info);
- pragma Inline (Needs_No_Actuals);
- pragma Inline (Never_Set_In_Source);
- 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);
- pragma Inline (No_Reordering);
- pragma Inline (No_Return);
- pragma Inline (No_Strict_Aliasing);
- pragma Inline (No_Tagged_Streams_Pragma);
- pragma Inline (Non_Binary_Modulus);
- pragma Inline (Non_Limited_View);
- pragma Inline (Nonzero_Is_True);
- pragma Inline (Normalized_First_Bit);
- pragma Inline (Normalized_Position);
- pragma Inline (Normalized_Position_Max);
- pragma Inline (OK_To_Rename);
- pragma Inline (Optimize_Alignment_Space);
- pragma Inline (Optimize_Alignment_Time);
- pragma Inline (Original_Access_Type);
- pragma Inline (Original_Array_Type);
- pragma Inline (Original_Protected_Subprogram);
- pragma Inline (Original_Record_Component);
- pragma Inline (Overlays_Constant);
- pragma Inline (Overridden_Operation);
- pragma Inline (Package_Instantiation);
- pragma Inline (Packed_Array_Impl_Type);
- pragma Inline (Parameter_Mode);
- pragma Inline (Parent_Subtype);
- pragma Inline (Part_Of_Constituents);
- pragma Inline (Part_Of_References);
- pragma Inline (Partial_View_Has_Unknown_Discr);
- pragma Inline (Pending_Access_Types);
- pragma Inline (Postconditions_Proc);
- pragma Inline (Predicated_Parent);
- pragma Inline (Predicates_Ignored);
- pragma Inline (Prev_Entity);
- pragma Inline (Prival);
- pragma Inline (Prival_Link);
- pragma Inline (Private_Dependents);
- pragma Inline (Protected_Body_Subprogram);
- pragma Inline (Protected_Formal);
- pragma Inline (Protected_Subprogram);
- pragma Inline (Protection_Object);
- pragma Inline (Reachable);
- pragma Inline (Receiving_Entry);
- pragma Inline (Referenced);
- pragma Inline (Referenced_As_LHS);
- pragma Inline (Referenced_As_Out_Parameter);
- pragma Inline (Refinement_Constituents);
- pragma Inline (Register_Exception_Call);
- pragma Inline (Related_Array_Object);
- pragma Inline (Related_Expression);
- pragma Inline (Related_Instance);
- pragma Inline (Related_Type);
- pragma Inline (Relative_Deadline_Variable);
- pragma Inline (Remove_Entity);
- pragma Inline (Renamed_Entity);
- pragma Inline (Renamed_In_Spec);
- pragma Inline (Renamed_Object);
- pragma Inline (Renaming_Map);
- pragma Inline (Requires_Overriding);
- pragma Inline (Return_Applies_To);
- pragma Inline (Return_Present);
- pragma Inline (Returns_By_Ref);
- pragma Inline (Reverse_Bit_Order);
- pragma Inline (Reverse_Storage_Order);
- pragma Inline (Rewritten_For_C);
- pragma Inline (RM_Size);
- pragma Inline (Scalar_Range);
- pragma Inline (Scale_Value);
- pragma Inline (Scope_Depth_Value);
- pragma Inline (Sec_Stack_Needed_For_Return);
- pragma Inline (Shared_Var_Procs_Instance);
- pragma Inline (Size_Check_Code);
- pragma Inline (Size_Depends_On_Discriminant);
- pragma Inline (Size_Known_At_Compile_Time);
- pragma Inline (Small_Value);
- pragma Inline (SPARK_Aux_Pragma);
- pragma Inline (SPARK_Aux_Pragma_Inherited);
- pragma Inline (SPARK_Pragma);
- pragma Inline (SPARK_Pragma_Inherited);
- pragma Inline (Spec_Entity);
- pragma Inline (SSO_Set_High_By_Default);
- pragma Inline (SSO_Set_Low_By_Default);
- pragma Inline (Static_Discrete_Predicate);
- pragma Inline (Static_Elaboration_Desired);
- pragma Inline (Static_Initialization);
- pragma Inline (Static_Real_Or_String_Predicate);
- pragma Inline (Status_Flag_Or_Transient_Decl);
- pragma Inline (Storage_Size_Variable);
- pragma Inline (Stored_Constraint);
- pragma Inline (Stores_Attribute_Old_Prefix);
- pragma Inline (Strict_Alignment);
- pragma Inline (String_Literal_Length);
- pragma Inline (String_Literal_Low_Bound);
- pragma Inline (Subprograms_For_Type);
- pragma Inline (Subps_Index);
- pragma Inline (Suppress_Elaboration_Warnings);
- pragma Inline (Suppress_Initialization);
- pragma Inline (Suppress_Style_Checks);
- pragma Inline (Suppress_Value_Tracking_On_Call);
- pragma Inline (Task_Body_Procedure);
- pragma Inline (Thunk_Entity);
- pragma Inline (Treat_As_Volatile);
- pragma Inline (Underlying_Full_View);
- pragma Inline (Underlying_Record_View);
- pragma Inline (Universal_Aliasing);
- pragma Inline (Unlink_Next_Entity);
- pragma Inline (Unset_Reference);
- pragma Inline (Used_As_Generic_Actual);
- pragma Inline (Uses_Lock_Free);
- pragma Inline (Uses_Sec_Stack);
- pragma Inline (Validated_Object);
- pragma Inline (Warnings_Off);
- pragma Inline (Warnings_Off_Used);
- pragma Inline (Warnings_Off_Used_Unmodified);
- pragma Inline (Warnings_Off_Used_Unreferenced);
- pragma Inline (Was_Hidden);
- pragma Inline (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 (Address_Clause);
- pragma Inline (Alignment_Clause);
- pragma Inline (Base_Type);
- pragma Inline (Float_Rep);
- pragma Inline (Has_Foreign_Convention);
- pragma Inline (Has_Limited_View);
- 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);
- pragma Inline (Set_Alias);
- pragma Inline (Set_Alignment);
- pragma Inline (Set_Anonymous_Designated_Type);
- pragma Inline (Set_Anonymous_Masters);
- pragma Inline (Set_Anonymous_Object);
- pragma Inline (Set_Associated_Entity);
- pragma Inline (Set_Associated_Formal_Package);
- pragma Inline (Set_Associated_Node_For_Itype);
- pragma Inline (Set_Associated_Storage_Pool);
- pragma Inline (Set_Barrier_Function);
- pragma Inline (Set_BIP_Initialization_Call);
- pragma Inline (Set_Block_Node);
- pragma Inline (Set_Body_Entity);
- pragma Inline (Set_Body_Needed_For_Inlining);
- pragma Inline (Set_Body_Needed_For_SAL);
- pragma Inline (Set_Body_References);
- pragma Inline (Set_C_Pass_By_Copy);
- pragma Inline (Set_Can_Never_Be_Null);
- pragma Inline (Set_Can_Use_Internal_Rep);
- pragma Inline (Set_Checks_May_Be_Suppressed);
- pragma Inline (Set_Class_Wide_Clone);
- pragma Inline (Set_Class_Wide_Type);
- pragma Inline (Set_Cloned_Subtype);
- pragma Inline (Set_Component_Bit_Offset);
- pragma Inline (Set_Component_Clause);
- pragma Inline (Set_Component_Size);
- pragma Inline (Set_Component_Type);
- pragma Inline (Set_Contains_Ignored_Ghost_Code);
- pragma Inline (Set_Contract);
- pragma Inline (Set_Contract_Wrapper);
- 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);
- pragma Inline (Set_Corresponding_Remote_Type);
- pragma Inline (Set_CR_Discriminant);
- pragma Inline (Set_Current_Use_Clause);
- pragma Inline (Set_Current_Value);
- pragma Inline (Set_Debug_Info_Off);
- pragma Inline (Set_Debug_Renaming_Link);
- pragma Inline (Set_Default_Aspect_Component_Value);
- pragma Inline (Set_Default_Aspect_Value);
- pragma Inline (Set_Default_Expr_Function);
- pragma Inline (Set_Default_Expressions_Processed);
- pragma Inline (Set_Default_Value);
- pragma Inline (Set_Delay_Cleanups);
- pragma Inline (Set_Delay_Subprogram_Descriptors);
- pragma Inline (Set_Delta_Value);
- pragma Inline (Set_Dependent_Instances);
- pragma Inline (Set_Depends_On_Private);
- pragma Inline (Set_Derived_Type_Link);
- pragma Inline (Set_Digits_Value);
- pragma Inline (Set_Direct_Primitive_Operations);
- pragma Inline (Set_Directly_Designated_Type);
- pragma Inline (Set_Disable_Controlled);
- pragma Inline (Set_Discard_Names);
- pragma Inline (Set_Discriminal);
- pragma Inline (Set_Discriminal_Link);
- pragma Inline (Set_Discriminant_Checking_Func);
- pragma Inline (Set_Discriminant_Constraint);
- pragma Inline (Set_Discriminant_Default_Value);
- pragma Inline (Set_Discriminant_Number);
- pragma Inline (Set_Dispatch_Table_Wrappers);
- pragma Inline (Set_DT_Entry_Count);
- pragma Inline (Set_DT_Offset_To_Top_Func);
- pragma Inline (Set_DT_Position);
- pragma Inline (Set_DTC_Entity);
- pragma Inline (Set_Elaborate_Body_Desirable);
- pragma Inline (Set_Elaboration_Entity);
- pragma Inline (Set_Elaboration_Entity_Required);
- pragma Inline (Set_Encapsulating_State);
- pragma Inline (Set_Enclosing_Scope);
- pragma Inline (Set_Entry_Accepted);
- pragma Inline (Set_Entry_Bodies_Array);
- pragma Inline (Set_Entry_Cancel_Parameter);
- pragma Inline (Set_Entry_Component);
- pragma Inline (Set_Entry_Formal);
- pragma Inline (Set_Entry_Max_Queue_Lengths_Array);
- pragma Inline (Set_Entry_Parameters_Type);
- pragma Inline (Set_Enum_Pos_To_Rep);
- pragma Inline (Set_Enumeration_Pos);
- pragma Inline (Set_Enumeration_Rep);
- pragma Inline (Set_Enumeration_Rep_Expr);
- pragma Inline (Set_Equivalent_Type);
- pragma Inline (Set_Esize);
- pragma Inline (Set_Extra_Accessibility);
- pragma Inline (Set_Extra_Accessibility_Of_Result);
- 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);
- pragma Inline (Set_First_Exit_Statement);
- pragma Inline (Set_First_Index);
- 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);
- pragma Inline (Set_Generic_Homonym);
- pragma Inline (Set_Generic_Renamings);
- pragma Inline (Set_Handler_Records);
- pragma Inline (Set_Has_Aliased_Components);
- pragma Inline (Set_Has_Alignment_Clause);
- pragma Inline (Set_Has_All_Calls_Remote);
- pragma Inline (Set_Has_Atomic_Components);
- pragma Inline (Set_Has_Biased_Representation);
- pragma Inline (Set_Has_Completion);
- pragma Inline (Set_Has_Completion_In_Body);
- pragma Inline (Set_Has_Complex_Representation);
- pragma Inline (Set_Has_Component_Size_Clause);
- pragma Inline (Set_Has_Constrained_Partial_View);
- pragma Inline (Set_Has_Contiguous_Rep);
- pragma Inline (Set_Has_Controlled_Component);
- pragma Inline (Set_Has_Controlling_Result);
- pragma Inline (Set_Has_Convention_Pragma);
- pragma Inline (Set_Has_Default_Aspect);
- pragma Inline (Set_Has_Delayed_Aspects);
- pragma Inline (Set_Has_Delayed_Freeze);
- pragma Inline (Set_Has_Delayed_Rep_Aspects);
- pragma Inline (Set_Has_Discriminants);
- pragma Inline (Set_Has_Dispatch_Table);
- pragma Inline (Set_Has_Dynamic_Predicate_Aspect);
- pragma Inline (Set_Has_Enumeration_Rep_Clause);
- pragma Inline (Set_Has_Exit);
- pragma Inline (Set_Has_Expanded_Contract);
- pragma Inline (Set_Has_Forward_Instantiation);
- pragma Inline (Set_Has_Fully_Qualified_Name);
- pragma Inline (Set_Has_Gigi_Rep_Item);
- pragma Inline (Set_Has_Homonym);
- pragma Inline (Set_Has_Implicit_Dereference);
- pragma Inline (Set_Has_Independent_Components);
- pragma Inline (Set_Has_Inheritable_Invariants);
- pragma Inline (Set_Has_Inherited_DIC);
- pragma Inline (Set_Has_Inherited_Invariants);
- pragma Inline (Set_Has_Initial_Value);
- pragma Inline (Set_Has_Loop_Entry_Attributes);
- pragma Inline (Set_Has_Machine_Radix_Clause);
- pragma Inline (Set_Has_Master_Entity);
- pragma Inline (Set_Has_Missing_Return);
- pragma Inline (Set_Has_Nested_Block_With_Handler);
- pragma Inline (Set_Has_Nested_Subprogram);
- pragma Inline (Set_Has_Non_Standard_Rep);
- pragma Inline (Set_Has_Object_Size_Clause);
- pragma Inline (Set_Has_Out_Or_In_Out_Parameter);
- pragma Inline (Set_Has_Own_DIC);
- pragma Inline (Set_Has_Own_Invariants);
- pragma Inline (Set_Has_Partial_Visible_Refinement);
- pragma Inline (Set_Has_Per_Object_Constraint);
- pragma Inline (Set_Has_Pragma_Controlled);
- pragma Inline (Set_Has_Pragma_Elaborate_Body);
- pragma Inline (Set_Has_Pragma_Inline);
- pragma Inline (Set_Has_Pragma_Inline_Always);
- pragma Inline (Set_Has_Pragma_No_Inline);
- pragma Inline (Set_Has_Pragma_Ordered);
- pragma Inline (Set_Has_Pragma_Pack);
- pragma Inline (Set_Has_Pragma_Preelab_Init);
- pragma Inline (Set_Has_Pragma_Pure);
- pragma Inline (Set_Has_Pragma_Pure_Function);
- pragma Inline (Set_Has_Pragma_Thread_Local_Storage);
- pragma Inline (Set_Has_Pragma_Unmodified);
- pragma Inline (Set_Has_Pragma_Unreferenced);
- pragma Inline (Set_Has_Pragma_Unreferenced_Objects);
- pragma Inline (Set_Has_Predicates);
- pragma Inline (Set_Has_Primitive_Operations);
- pragma Inline (Set_Has_Private_Ancestor);
- pragma Inline (Set_Has_Private_Declaration);
- pragma Inline (Set_Has_Private_Extension);
- pragma Inline (Set_Has_Protected);
- pragma Inline (Set_Has_Qualified_Name);
- pragma Inline (Set_Has_RACW);
- pragma Inline (Set_Has_Record_Rep_Clause);
- pragma Inline (Set_Has_Recursive_Call);
- pragma Inline (Set_Has_Shift_Operator);
- pragma Inline (Set_Has_Size_Clause);
- pragma Inline (Set_Has_Small_Clause);
- pragma Inline (Set_Has_Specified_Layout);
- pragma Inline (Set_Has_Specified_Stream_Input);
- pragma Inline (Set_Has_Specified_Stream_Output);
- pragma Inline (Set_Has_Specified_Stream_Read);
- pragma Inline (Set_Has_Specified_Stream_Write);
- pragma Inline (Set_Has_Static_Discriminants);
- pragma Inline (Set_Has_Static_Predicate);
- pragma Inline (Set_Has_Static_Predicate_Aspect);
- pragma Inline (Set_Has_Storage_Size_Clause);
- pragma Inline (Set_Has_Stream_Size_Clause);
- pragma Inline (Set_Has_Task);
- pragma Inline (Set_Has_Timing_Event);
- pragma Inline (Set_Has_Thunks);
- pragma Inline (Set_Has_Unchecked_Union);
- pragma Inline (Set_Has_Unknown_Discriminants);
- 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);
- pragma Inline (Set_Ignore_SPARK_Mode_Pragmas);
- pragma Inline (Set_Import_Pragma);
- pragma Inline (Set_Incomplete_Actuals);
- 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_Is_Abstract_Subprogram);
- pragma Inline (Set_Is_Abstract_Type);
- pragma Inline (Set_Is_Access_Constant);
- pragma Inline (Set_Is_Activation_Record);
- pragma Inline (Set_Is_Actual_Subtype);
- pragma Inline (Set_Is_Ada_2005_Only);
- pragma Inline (Set_Is_Ada_2012_Only);
- pragma Inline (Set_Is_Aliased);
- pragma Inline (Set_Is_Asynchronous);
- pragma Inline (Set_Is_Atomic);
- pragma Inline (Set_Is_Bit_Packed_Array);
- pragma Inline (Set_Is_Called);
- pragma Inline (Set_Is_Character_Type);
- pragma Inline (Set_Is_Checked_Ghost_Entity);
- pragma Inline (Set_Is_Child_Unit);
- pragma Inline (Set_Is_Class_Wide_Clone);
- pragma Inline (Set_Is_Class_Wide_Equivalent_Type);
- pragma Inline (Set_Is_Compilation_Unit);
- pragma Inline (Set_Is_Completely_Hidden);
- pragma Inline (Set_Is_Concurrent_Record_Type);
- pragma Inline (Set_Is_Constr_Subt_For_U_Nominal);
- pragma Inline (Set_Is_Constr_Subt_For_UN_Aliased);
- pragma Inline (Set_Is_Constrained);
- pragma Inline (Set_Is_Constructor);
- 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);
- pragma Inline (Set_Is_Discriminant_Check_Function);
- pragma Inline (Set_Is_Dispatch_Table_Entity);
- pragma Inline (Set_Is_Dispatching_Operation);
- pragma Inline (Set_Is_Elaboration_Checks_OK_Id);
- pragma Inline (Set_Is_Elaboration_Warnings_OK_Id);
- pragma Inline (Set_Is_Eliminated);
- pragma Inline (Set_Is_Entry_Formal);
- pragma Inline (Set_Is_Entry_Wrapper);
- pragma Inline (Set_Is_Exception_Handler);
- pragma Inline (Set_Is_Exported);
- pragma Inline (Set_Is_Finalized_Transient);
- pragma Inline (Set_Is_First_Subtype);
- pragma Inline (Set_Is_Formal_Subprogram);
- pragma Inline (Set_Is_Frozen);
- pragma Inline (Set_Is_Generic_Actual_Subprogram);
- pragma Inline (Set_Is_Generic_Actual_Type);
- pragma Inline (Set_Is_Generic_Instance);
- pragma Inline (Set_Is_Generic_Type);
- pragma Inline (Set_Is_Hidden);
- pragma Inline (Set_Is_Hidden_Non_Overridden_Subpgm);
- pragma Inline (Set_Is_Hidden_Open_Scope);
- pragma Inline (Set_Is_Ignored_Ghost_Entity);
- pragma Inline (Set_Is_Ignored_Transient);
- pragma Inline (Set_Is_Immediately_Visible);
- pragma Inline (Set_Is_Implementation_Defined);
- pragma Inline (Set_Is_Imported);
- pragma Inline (Set_Is_Independent);
- pragma Inline (Set_Is_Initial_Condition_Procedure);
- pragma Inline (Set_Is_Inlined);
- pragma Inline (Set_Is_Inlined_Always);
- pragma Inline (Set_Is_Instantiated);
- pragma Inline (Set_Is_Interface);
- pragma Inline (Set_Is_Internal);
- pragma Inline (Set_Is_Interrupt_Handler);
- pragma Inline (Set_Is_Intrinsic_Subprogram);
- pragma Inline (Set_Is_Invariant_Procedure);
- pragma Inline (Set_Is_Itype);
- pragma Inline (Set_Is_Known_Non_Null);
- pragma Inline (Set_Is_Known_Null);
- pragma Inline (Set_Is_Known_Valid);
- pragma Inline (Set_Is_Limited_Composite);
- pragma Inline (Set_Is_Limited_Interface);
- pragma Inline (Set_Is_Limited_Record);
- pragma Inline (Set_Is_Local_Anonymous_Access);
- pragma Inline (Set_Is_Loop_Parameter);
- pragma Inline (Set_Is_Machine_Code_Subprogram);
- pragma Inline (Set_Is_Non_Static_Subtype);
- pragma Inline (Set_Is_Null_Init_Proc);
- pragma Inline (Set_Is_Obsolescent);
- pragma Inline (Set_Is_Only_Out_Parameter);
- pragma Inline (Set_Is_Package_Body_Entity);
- pragma Inline (Set_Is_Packed);
- pragma Inline (Set_Is_Packed_Array_Impl_Type);
- pragma Inline (Set_Is_Param_Block_Component_Type);
- pragma Inline (Set_Is_Partial_Invariant_Procedure);
- pragma Inline (Set_Is_Potentially_Use_Visible);
- pragma Inline (Set_Is_Predicate_Function);
- pragma Inline (Set_Is_Predicate_Function_M);
- pragma Inline (Set_Is_Preelaborated);
- pragma Inline (Set_Is_Primitive);
- pragma Inline (Set_Is_Primitive_Wrapper);
- pragma Inline (Set_Is_Private_Composite);
- pragma Inline (Set_Is_Private_Descendant);
- pragma Inline (Set_Is_Private_Primitive);
- pragma Inline (Set_Is_Public);
- pragma Inline (Set_Is_Pure);
- pragma Inline (Set_Is_Pure_Unit_Access_Type);
- pragma Inline (Set_Is_RACW_Stub_Type);
- pragma Inline (Set_Is_Raised);
- pragma Inline (Set_Is_Remote_Call_Interface);
- pragma Inline (Set_Is_Remote_Types);
- pragma Inline (Set_Is_Renaming_Of_Object);
- pragma Inline (Set_Is_Return_Object);
- pragma Inline (Set_Is_Safe_To_Reevaluate);
- pragma Inline (Set_Is_Shared_Passive);
- pragma Inline (Set_Is_Static_Type);
- pragma Inline (Set_Is_Statically_Allocated);
- pragma Inline (Set_Is_Tag);
- pragma Inline (Set_Is_Tagged_Type);
- pragma Inline (Set_Is_Thunk);
- pragma Inline (Set_Is_Trivial_Subprogram);
- pragma Inline (Set_Is_True_Constant);
- pragma Inline (Set_Is_Unchecked_Union);
- pragma Inline (Set_Is_Underlying_Full_View);
- pragma Inline (Set_Is_Underlying_Record_View);
- pragma Inline (Set_Is_Unimplemented);
- pragma Inline (Set_Is_Unsigned_Type);
- pragma Inline (Set_Is_Uplevel_Referenced_Entity);
- pragma Inline (Set_Is_Valued_Procedure);
- pragma Inline (Set_Is_Visible_Formal);
- pragma Inline (Set_Is_Visible_Lib_Unit);
- pragma Inline (Set_Is_Volatile);
- pragma Inline (Set_Is_Volatile_Full_Access);
- pragma Inline (Set_Itype_Printed);
- pragma Inline (Set_Kill_Elaboration_Checks);
- pragma Inline (Set_Kill_Range_Checks);
- pragma Inline (Set_Known_To_Have_Preelab_Init);
- pragma Inline (Set_Last_Aggregate_Assignment);
- pragma Inline (Set_Last_Assignment);
- pragma Inline (Set_Last_Entity);
- pragma Inline (Set_Limited_View);
- pragma Inline (Set_Linker_Section_Pragma);
- pragma Inline (Set_Lit_Indexes);
- pragma Inline (Set_Lit_Strings);
- pragma Inline (Set_Low_Bound_Tested);
- pragma Inline (Set_Machine_Radix_10);
- pragma Inline (Set_Master_Id);
- pragma Inline (Set_Materialize_Entity);
- pragma Inline (Set_May_Inherit_Delayed_Rep_Aspects);
- pragma Inline (Set_Mechanism);
- pragma Inline (Set_Minimum_Accessibility);
- pragma Inline (Set_Modulus);
- pragma Inline (Set_Must_Be_On_Byte_Boundary);
- pragma Inline (Set_Must_Have_Preelab_Init);
- pragma Inline (Set_Needs_Activation_Record);
- pragma Inline (Set_Needs_Debug_Info);
- pragma Inline (Set_Needs_No_Actuals);
- pragma Inline (Set_Never_Set_In_Source);
- pragma Inline (Set_Next_Inlined_Subprogram);
- pragma Inline (Set_No_Dynamic_Predicate_On_Actual);
- pragma Inline (Set_No_Pool_Assigned);
- pragma Inline (Set_No_Predicate_On_Actual);
- pragma Inline (Set_No_Reordering);
- pragma Inline (Set_No_Return);
- pragma Inline (Set_No_Strict_Aliasing);
- pragma Inline (Set_No_Tagged_Streams_Pragma);
- pragma Inline (Set_Non_Binary_Modulus);
- pragma Inline (Set_Non_Limited_View);
- pragma Inline (Set_Nonzero_Is_True);
- pragma Inline (Set_Normalized_First_Bit);
- pragma Inline (Set_Normalized_Position);
- pragma Inline (Set_Normalized_Position_Max);
- pragma Inline (Set_OK_To_Rename);
- pragma Inline (Set_Optimize_Alignment_Space);
- pragma Inline (Set_Optimize_Alignment_Time);
- pragma Inline (Set_Original_Access_Type);
- pragma Inline (Set_Original_Array_Type);
- pragma Inline (Set_Original_Protected_Subprogram);
- pragma Inline (Set_Original_Record_Component);
- pragma Inline (Set_Overlays_Constant);
- pragma Inline (Set_Overridden_Operation);
- pragma Inline (Set_Package_Instantiation);
- pragma Inline (Set_Packed_Array_Impl_Type);
- pragma Inline (Set_Parent_Subtype);
- pragma Inline (Set_Part_Of_Constituents);
- pragma Inline (Set_Part_Of_References);
- pragma Inline (Set_Partial_View_Has_Unknown_Discr);
- pragma Inline (Set_Pending_Access_Types);
- pragma Inline (Set_Postconditions_Proc);
- pragma Inline (Set_Predicated_Parent);
- pragma Inline (Set_Predicates_Ignored);
- pragma Inline (Set_Prev_Entity);
- pragma Inline (Set_Prival);
- pragma Inline (Set_Prival_Link);
- pragma Inline (Set_Private_Dependents);
- pragma Inline (Set_Protected_Body_Subprogram);
- pragma Inline (Set_Protected_Formal);
- pragma Inline (Set_Protected_Subprogram);
- pragma Inline (Set_Protection_Object);
- pragma Inline (Set_Reachable);
- pragma Inline (Set_Receiving_Entry);
- pragma Inline (Set_Referenced);
- pragma Inline (Set_Referenced_As_LHS);
- pragma Inline (Set_Referenced_As_Out_Parameter);
- pragma Inline (Set_Refinement_Constituents);
- pragma Inline (Set_Register_Exception_Call);
- pragma Inline (Set_Related_Array_Object);
- pragma Inline (Set_Related_Expression);
- pragma Inline (Set_Related_Instance);
- pragma Inline (Set_Related_Type);
- pragma Inline (Set_Relative_Deadline_Variable);
- pragma Inline (Set_Renamed_Entity);
- pragma Inline (Set_Renamed_In_Spec);
- pragma Inline (Set_Renamed_Object);
- pragma Inline (Set_Renaming_Map);
- pragma Inline (Set_Requires_Overriding);
- pragma Inline (Set_Return_Applies_To);
- pragma Inline (Set_Return_Present);
- pragma Inline (Set_Returns_By_Ref);
- pragma Inline (Set_Reverse_Bit_Order);
- pragma Inline (Set_Reverse_Storage_Order);
- pragma Inline (Set_Rewritten_For_C);
- pragma Inline (Set_RM_Size);
- pragma Inline (Set_Scalar_Range);
- pragma Inline (Set_Scale_Value);
- pragma Inline (Set_Scope_Depth_Value);
- pragma Inline (Set_Sec_Stack_Needed_For_Return);
- pragma Inline (Set_Shared_Var_Procs_Instance);
- pragma Inline (Set_Size_Check_Code);
- pragma Inline (Set_Size_Depends_On_Discriminant);
- pragma Inline (Set_Size_Known_At_Compile_Time);
- pragma Inline (Set_Small_Value);
- pragma Inline (Set_SPARK_Aux_Pragma);
- pragma Inline (Set_SPARK_Aux_Pragma_Inherited);
- pragma Inline (Set_SPARK_Pragma);
- pragma Inline (Set_SPARK_Pragma_Inherited);
- pragma Inline (Set_Spec_Entity);
- pragma Inline (Set_SSO_Set_High_By_Default);
- pragma Inline (Set_SSO_Set_Low_By_Default);
- pragma Inline (Set_Static_Discrete_Predicate);
- pragma Inline (Set_Static_Elaboration_Desired);
- pragma Inline (Set_Static_Initialization);
- pragma Inline (Set_Static_Real_Or_String_Predicate);
- pragma Inline (Set_Status_Flag_Or_Transient_Decl);
- pragma Inline (Set_Storage_Size_Variable);
- pragma Inline (Set_Stored_Constraint);
- pragma Inline (Set_Stores_Attribute_Old_Prefix);
- pragma Inline (Set_Strict_Alignment);
- pragma Inline (Set_String_Literal_Length);
- pragma Inline (Set_String_Literal_Low_Bound);
- pragma Inline (Set_Subprograms_For_Type);
- pragma Inline (Set_Subps_Index);
- pragma Inline (Set_Suppress_Elaboration_Warnings);
- pragma Inline (Set_Suppress_Initialization);
- pragma Inline (Set_Suppress_Style_Checks);
- pragma Inline (Set_Suppress_Value_Tracking_On_Call);
- pragma Inline (Set_Task_Body_Procedure);
- pragma Inline (Set_Thunk_Entity);
- pragma Inline (Set_Treat_As_Volatile);
- pragma Inline (Set_Underlying_Full_View);
- pragma Inline (Set_Underlying_Record_View);
- pragma Inline (Set_Universal_Aliasing);
- pragma Inline (Set_Unset_Reference);
- pragma Inline (Set_Used_As_Generic_Actual);
- pragma Inline (Set_Uses_Lock_Free);
- pragma Inline (Set_Uses_Sec_Stack);
- pragma Inline (Set_Validated_Object);
- pragma Inline (Set_Warnings_Off);
- pragma Inline (Set_Warnings_Off_Used);
- pragma Inline (Set_Warnings_Off_Used_Unmodified);
- pragma Inline (Set_Warnings_Off_Used_Unreferenced);
- pragma Inline (Set_Was_Hidden);
- pragma Inline (Set_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_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 16e802d..165adb0 100644
--- a/gcc/ada/elists.adb
+++ b/gcc/ada/elists.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/elists.ads b/gcc/ada/elists.ads
index 92b74fc..2561d29 100644
--- a/gcc/ada/elists.ads
+++ b/gcc/ada/elists.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/elists.h b/gcc/ada/elists.h
index 75a009e..d7243fc 100644
--- a/gcc/ada/elists.h
+++ b/gcc/ada/elists.h
@@ -6,7 +6,7 @@
* *
* C Header File *
* *
- * Copyright (C) 1992-2020, Free Software Foundation, Inc. *
+ * Copyright (C) 1992-2021, Free Software Foundation, Inc. *
* *
* GNAT is free software; you can redistribute 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 0ee09f4..f542dcd 100644
--- a/gcc/ada/env.c
+++ b/gcc/ada/env.c
@@ -6,7 +6,7 @@
* *
* C Implementation File *
* *
- * Copyright (C) 2005-2020, Free Software Foundation, Inc. *
+ * Copyright (C) 2005-2021, Free Software Foundation, Inc. *
* *
* GNAT is free software; you can redistribute 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 d0a2ae1..b3f4767 100644
--- a/gcc/ada/env.h
+++ b/gcc/ada/env.h
@@ -6,7 +6,7 @@
* *
* C Header File *
* *
- * Copyright (C) 2009-2020, Free Software Foundation, Inc. *
+ * Copyright (C) 2009-2021, Free Software Foundation, Inc. *
* *
* GNAT is free software; you can redistribute 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 7afe705..366df62 100644
--- a/gcc/ada/err_vars.ads
+++ b/gcc/ada/err_vars.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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,7 +89,7 @@ package Err_Vars is
-- Source_Reference line, then this is initialized to No_Source_File,
-- to force an initial reference to the real source file name.
- Warning_Doc_Switch : Boolean := False;
+ Warning_Doc_Switch : Boolean := True;
-- If this is set True, then the ??/?x?/?x? sequences in error messages
-- are active (see errout.ads for details). If this switch is False, then
-- these sequences are ignored (i.e. simply equivalent to a single ?). The
diff --git a/gcc/ada/errno.c b/gcc/ada/errno.c
index 061d0f0..303134b 100644
--- a/gcc/ada/errno.c
+++ b/gcc/ada/errno.c
@@ -6,7 +6,7 @@
* *
* C Implementation File *
* *
- * Copyright (C) 1992-2020, Free Software Foundation, Inc. *
+ * Copyright (C) 1992-2021, Free Software Foundation, Inc. *
* *
* GNAT is free software; you can redistribute 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 cc291c6..0122304 100644
--- a/gcc/ada/errout.adb
+++ b/gcc/ada/errout.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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,25 +29,29 @@
-- environment, and that in particular, no disallowed table expansion is
-- allowed to occur.
-with Atree; use Atree;
-with Casing; use Casing;
-with Csets; use Csets;
-with Debug; use Debug;
-with Einfo; use Einfo;
-with Erroutc; use Erroutc;
-with Gnatvsn; use Gnatvsn;
-with Lib; use Lib;
-with Opt; use Opt;
-with Nlists; use Nlists;
-with Output; use Output;
-with Scans; use Scans;
-with Sem_Aux; use Sem_Aux;
-with Sinput; use Sinput;
-with Sinfo; use Sinfo;
-with Snames; use Snames;
-with Stand; use Stand;
-with Stylesw; use Stylesw;
-with Uname; use Uname;
+with Atree; use Atree;
+with Casing; use Casing;
+with Csets; use Csets;
+with Debug; use Debug;
+with Einfo; use Einfo;
+with Einfo.Entities; use Einfo.Entities;
+with Einfo.Utils; use Einfo.Utils;
+with Erroutc; use Erroutc;
+with Gnatvsn; use Gnatvsn;
+with Lib; use Lib;
+with Opt; use Opt;
+with Nlists; use Nlists;
+with Output; use Output;
+with Scans; use Scans;
+with Sem_Aux; use Sem_Aux;
+with Sinput; use Sinput;
+with Sinfo; use Sinfo;
+with Sinfo.Nodes; use Sinfo.Nodes;
+with Sinfo.Utils; use Sinfo.Utils;
+with Snames; use Snames;
+with Stand; use Stand;
+with Stylesw; use Stylesw;
+with Uname; use Uname;
package body Errout is
@@ -98,8 +102,8 @@ package body Errout is
procedure Error_Msg_Internal
(Msg : String;
- Sptr : Source_Ptr;
- Optr : Source_Ptr;
+ Span : Source_Span;
+ Opan : Source_Span;
Msg_Cont : Boolean;
Node : Node_Id);
-- This is the low level routine used to post messages after dealing with
@@ -126,6 +130,11 @@ package body Errout is
-- or if it refers to an Etype that has an error posted on it, or if
-- it references an Entity that has an error posted on it.
+ procedure Output_JSON_Message (Error_Id : Error_Msg_Id);
+ -- Output error message Error_Id and any subsequent continuation message
+ -- using a JSON format similar to the one GCC uses when passed
+ -- -fdiagnostics-format=json.
+
procedure Output_Source_Line
(L : Physical_Line_Number;
Sfile : Source_File_Index;
@@ -218,7 +227,7 @@ package body Errout is
Err_Id : Error_Msg_Id := Error_Id;
begin
- Set_Msg_Text (New_Msg, Errors.Table (Error_Id).Sptr);
+ Set_Msg_Text (New_Msg, Errors.Table (Error_Id).Sptr.Ptr);
Errors.Table (Error_Id).Text := new String'(Msg_Buffer (1 .. Msglen));
-- If in immediate error message mode, output modified error message now
@@ -300,14 +309,19 @@ package body Errout is
---------------
-- Error_Msg posts a flag at the given location, except that if the
- -- Flag_Location points within a generic template and corresponds to an
- -- instantiation of this generic template, then the actual message will be
- -- posted on the generic instantiation, along with additional messages
- -- referencing the generic declaration.
+ -- Flag_Location/Flag_Span points within a generic template and corresponds
+ -- to an instantiation of this generic template, then the actual message
+ -- will be posted on the generic instantiation, along with additional
+ -- messages referencing the generic declaration.
procedure Error_Msg (Msg : String; Flag_Location : Source_Ptr) is
begin
- Error_Msg (Msg, Flag_Location, Current_Node);
+ Error_Msg (Msg, To_Span (Flag_Location), Current_Node);
+ end Error_Msg;
+
+ procedure Error_Msg (Msg : String; Flag_Span : Source_Span) is
+ begin
+ Error_Msg (Msg, Flag_Span, Current_Node);
end Error_Msg;
procedure Error_Msg
@@ -318,7 +332,7 @@ package body Errout 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);
+ Error_Msg (Msg, To_Span (Flag_Location), Current_Node);
Is_Compile_Time_Msg := Save_Is_Compile_Time_Msg;
end Error_Msg;
@@ -327,6 +341,17 @@ package body Errout is
Flag_Location : Source_Ptr;
N : Node_Id)
is
+ begin
+ Error_Msg (Msg, To_Span (Flag_Location), N);
+ end Error_Msg;
+
+ procedure Error_Msg
+ (Msg : String;
+ Flag_Span : Source_Span;
+ N : Node_Id)
+ is
+ Flag_Location : constant Source_Ptr := Flag_Span.Ptr;
+
Sindex : Source_File_Index;
-- Source index for flag location
@@ -429,7 +454,7 @@ package body Errout is
-- Error_Msg_Internal to place the message in the requested location.
if Instantiation (Sindex) = No_Location then
- Error_Msg_Internal (Msg, Flag_Location, Flag_Location, False, N);
+ Error_Msg_Internal (Msg, Flag_Span, Flag_Span, False, N);
return;
end if;
@@ -525,32 +550,32 @@ package body Errout is
if Is_Info_Msg then
Error_Msg_Internal
(Msg => "info: in inlined body #",
- Sptr => Actual_Error_Loc,
- Optr => Flag_Location,
+ Span => To_Span (Actual_Error_Loc),
+ Opan => Flag_Span,
Msg_Cont => Msg_Cont_Status,
Node => N);
elsif Is_Warning_Msg then
Error_Msg_Internal
(Msg => Warn_Insertion & "in inlined body #",
- Sptr => Actual_Error_Loc,
- Optr => Flag_Location,
+ Span => To_Span (Actual_Error_Loc),
+ Opan => Flag_Span,
Msg_Cont => Msg_Cont_Status,
Node => N);
elsif Is_Style_Msg then
Error_Msg_Internal
(Msg => "style: in inlined body #",
- Sptr => Actual_Error_Loc,
- Optr => Flag_Location,
+ Span => To_Span (Actual_Error_Loc),
+ Opan => Flag_Span,
Msg_Cont => Msg_Cont_Status,
Node => N);
else
Error_Msg_Internal
(Msg => "error in inlined body #",
- Sptr => Actual_Error_Loc,
- Optr => Flag_Location,
+ Span => To_Span (Actual_Error_Loc),
+ Opan => Flag_Span,
Msg_Cont => Msg_Cont_Status,
Node => N);
end if;
@@ -561,32 +586,32 @@ package body Errout is
if Is_Info_Msg then
Error_Msg_Internal
(Msg => "info: in instantiation #",
- Sptr => Actual_Error_Loc,
- Optr => Flag_Location,
+ Span => To_Span (Actual_Error_Loc),
+ Opan => Flag_Span,
Msg_Cont => Msg_Cont_Status,
Node => N);
elsif Is_Warning_Msg then
Error_Msg_Internal
(Msg => Warn_Insertion & "in instantiation #",
- Sptr => Actual_Error_Loc,
- Optr => Flag_Location,
+ Span => To_Span (Actual_Error_Loc),
+ Opan => Flag_Span,
Msg_Cont => Msg_Cont_Status,
Node => N);
elsif Is_Style_Msg then
Error_Msg_Internal
(Msg => "style: in instantiation #",
- Sptr => Actual_Error_Loc,
- Optr => Flag_Location,
+ Span => To_Span (Actual_Error_Loc),
+ Opan => Flag_Span,
Msg_Cont => Msg_Cont_Status,
Node => N);
else
Error_Msg_Internal
(Msg => "instantiation error #",
- Sptr => Actual_Error_Loc,
- Optr => Flag_Location,
+ Span => To_Span (Actual_Error_Loc),
+ Opan => Flag_Span,
Msg_Cont => Msg_Cont_Status,
Node => N);
end if;
@@ -605,8 +630,8 @@ package body Errout is
Error_Msg_Internal
(Msg => Msg,
- Sptr => Actual_Error_Loc,
- Optr => Flag_Location,
+ Span => To_Span (Actual_Error_Loc),
+ Opan => Flag_Span,
Msg_Cont => Msg_Cont_Status,
Node => N);
end;
@@ -650,22 +675,22 @@ package body Errout is
end Error_Msg_Ada_2012_Feature;
--------------------------------
- -- Error_Msg_Ada_2020_Feature --
+ -- Error_Msg_Ada_2022_Feature --
--------------------------------
- procedure Error_Msg_Ada_2020_Feature (Feature : String; Loc : Source_Ptr) is
+ procedure Error_Msg_Ada_2022_Feature (Feature : String; Loc : Source_Ptr) is
begin
- if Ada_Version < Ada_2020 then
- Error_Msg (Feature & " is an Ada 2020 feature", Loc);
+ if Ada_Version < Ada_2022 then
+ Error_Msg (Feature & " is an Ada 2022 feature", Loc);
if No (Ada_Version_Pragma) then
- Error_Msg ("\unit must be compiled with -gnat2020 switch", Loc);
+ Error_Msg ("\unit must be compiled with -gnat2022 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;
+ end Error_Msg_Ada_2022_Feature;
------------------
-- Error_Msg_AP --
@@ -834,8 +859,13 @@ package body Errout is
-----------------
procedure Error_Msg_F (Msg : String; N : Node_Id) is
+ Fst, Lst : Node_Id;
begin
- Error_Msg_NEL (Msg, N, N, Sloc (First_Node (N)));
+ First_And_Last_Nodes (N, Fst, Lst);
+ Error_Msg_NEL (Msg, N, N,
+ To_Span (Ptr => Sloc (Fst),
+ First => First_Sloc (Fst),
+ Last => Last_Sloc (Lst)));
end Error_Msg_F;
------------------
@@ -847,21 +877,42 @@ package body Errout is
N : Node_Id;
E : Node_Or_Entity_Id)
is
+ Fst, Lst : Node_Id;
begin
- Error_Msg_NEL (Msg, N, E, Sloc (First_Node (N)));
+ First_And_Last_Nodes (N, Fst, Lst);
+ Error_Msg_NEL (Msg, N, E,
+ To_Span (Ptr => Sloc (Fst),
+ First => First_Sloc (Fst),
+ Last => Last_Sloc (Lst)));
end Error_Msg_FE;
+ ------------------------------
+ -- Error_Msg_GNAT_Extension --
+ ------------------------------
+
+ procedure Error_Msg_GNAT_Extension (Extension : String) is
+ Loc : constant Source_Ptr := Token_Ptr;
+ begin
+ if not Extensions_Allowed then
+ Error_Msg (Extension & " is a 'G'N'A'T specific extension", Loc);
+ Error_Msg ("\unit must be compiled with -gnatX switch", Loc);
+ end if;
+ end Error_Msg_GNAT_Extension;
+
------------------------
-- Error_Msg_Internal --
------------------------
procedure Error_Msg_Internal
(Msg : String;
- Sptr : Source_Ptr;
- Optr : Source_Ptr;
+ Span : Source_Span;
+ Opan : Source_Span;
Msg_Cont : Boolean;
Node : Node_Id)
is
+ Sptr : constant Source_Ptr := Span.Ptr;
+ Optr : constant Source_Ptr := Opan.Ptr;
+
Next_Msg : Error_Msg_Id;
-- Pointer to next message at insertion point
@@ -923,6 +974,11 @@ package body Errout is
-- Start of processing for Error_Msg_Internal
begin
+ -- Detect common mistake of prefixing or suffing the message with a
+ -- space character.
+
+ pragma Assert (Msg (Msg'First) /= ' ' and then Msg (Msg'Last) /= ' ');
+
if Raise_Exception_On_Error /= 0 then
raise Error_Msg_Exception;
end if;
@@ -989,7 +1045,7 @@ package body Errout is
if In_Extended_Main_Source_Unit (Sptr) then
null;
- -- If the main unit has not been read yet. the warning must be on
+ -- If the main unit has not been read yet. The warning must be on
-- a configuration file: gnat.adc or user-defined. This means we
-- are not parsing the main unit yet, so skip following checks.
@@ -1136,7 +1192,7 @@ package body Errout is
((Text => new String'(Msg_Buffer (1 .. Msglen)),
Next => No_Error_Msg,
Prev => No_Error_Msg,
- Sptr => Sptr,
+ Sptr => Span,
Optr => Optr,
Insertion_Sloc => (if Has_Insertion_Line then Error_Msg_Sloc
else No_Location),
@@ -1196,9 +1252,9 @@ package body Errout is
if Last_Error_Msg /= No_Error_Msg
and then Errors.Table (Cur_Msg).Sfile =
Errors.Table (Last_Error_Msg).Sfile
- and then (Sptr > Errors.Table (Last_Error_Msg).Sptr
+ and then (Sptr > Errors.Table (Last_Error_Msg).Sptr.Ptr
or else
- (Sptr = Errors.Table (Last_Error_Msg).Sptr
+ (Sptr = Errors.Table (Last_Error_Msg).Sptr.Ptr
and then
Optr > Errors.Table (Last_Error_Msg).Optr))
then
@@ -1216,8 +1272,8 @@ package body Errout is
if Errors.Table (Cur_Msg).Sfile = Errors.Table (Next_Msg).Sfile
then
- exit when Sptr < Errors.Table (Next_Msg).Sptr
- or else (Sptr = Errors.Table (Next_Msg).Sptr
+ exit when Sptr < Errors.Table (Next_Msg).Sptr.Ptr
+ or else (Sptr = Errors.Table (Next_Msg).Sptr.Ptr
and then Optr < Errors.Table (Next_Msg).Optr);
end if;
@@ -1364,8 +1420,13 @@ package body Errout is
-----------------
procedure Error_Msg_N (Msg : String; N : Node_Or_Entity_Id) is
+ Fst, Lst : Node_Id;
begin
- Error_Msg_NEL (Msg, N, N, Sloc (N));
+ First_And_Last_Nodes (N, Fst, Lst);
+ Error_Msg_NEL (Msg, N, N,
+ To_Span (Ptr => Sloc (N),
+ First => First_Sloc (Fst),
+ Last => Last_Sloc (Lst)));
end Error_Msg_N;
------------------
@@ -1377,8 +1438,13 @@ package body Errout is
N : Node_Or_Entity_Id;
E : Node_Or_Entity_Id)
is
+ Fst, Lst : Node_Id;
begin
- Error_Msg_NEL (Msg, N, E, Sloc (N));
+ First_And_Last_Nodes (N, Fst, Lst);
+ Error_Msg_NEL (Msg, N, E,
+ To_Span (Ptr => Sloc (N),
+ First => First_Sloc (Fst),
+ Last => Last_Sloc (Lst)));
end Error_Msg_NE;
-------------------
@@ -1391,6 +1457,22 @@ package body Errout is
E : Node_Or_Entity_Id;
Flag_Location : Source_Ptr)
is
+ Fst, Lst : Node_Id;
+ begin
+ First_And_Last_Nodes (N, Fst, Lst);
+ Error_Msg_NEL
+ (Msg, N, E,
+ To_Span (Ptr => Flag_Location,
+ First => Source_Ptr'Min (Flag_Location, First_Sloc (Fst)),
+ Last => Source_Ptr'Max (Flag_Location, Last_Sloc (Lst))));
+ end Error_Msg_NEL;
+
+ procedure Error_Msg_NEL
+ (Msg : String;
+ N : Node_Or_Entity_Id;
+ E : Node_Or_Entity_Id;
+ Flag_Span : Source_Span)
+ is
begin
if Special_Msg_Delete (Msg, N, E) then
return;
@@ -1443,7 +1525,7 @@ package body Errout is
then
Debug_Output (N);
Error_Msg_Node_1 := E;
- Error_Msg (Msg, Flag_Location, N);
+ Error_Msg (Msg, Flag_Span, N);
else
Last_Killed := True;
@@ -1463,12 +1545,17 @@ package body Errout is
Msg : String;
N : Node_Or_Entity_Id)
is
+ Fst, Lst : Node_Id;
begin
if Eflag
and then In_Extended_Main_Source_Unit (N)
and then Comes_From_Source (N)
then
- Error_Msg_NEL (Msg, N, N, Sloc (N));
+ First_And_Last_Nodes (N, Fst, Lst);
+ Error_Msg_NEL (Msg, N, N,
+ To_Span (Ptr => Sloc (N),
+ First => First_Sloc (Fst),
+ Last => Last_Sloc (Lst)));
end if;
end Error_Msg_NW;
@@ -1563,7 +1650,7 @@ package body Errout is
F := Nxt;
while F /= No_Error_Msg
- and then Errors.Table (F).Sptr = Errors.Table (Cur).Sptr
+ and then Errors.Table (F).Sptr.Ptr = Errors.Table (Cur).Sptr.Ptr
loop
Check_Duplicate_Message (Cur, F);
F := Errors.Table (F).Next;
@@ -1583,8 +1670,8 @@ package body Errout is
begin
if (CE.Warn and not CE.Deleted)
and then
- (Warning_Specifically_Suppressed (CE.Sptr, CE.Text, Tag) /=
- No_String
+ (Warning_Specifically_Suppressed (CE.Sptr.Ptr, CE.Text, Tag)
+ /= No_String
or else
Warning_Specifically_Suppressed (CE.Optr, CE.Text, Tag) /=
No_String)
@@ -1630,23 +1717,40 @@ package body Errout is
----------------
function First_Node (C : Node_Id) return Node_Id is
+ Fst, Lst : Node_Id;
+ begin
+ First_And_Last_Nodes (C, Fst, Lst);
+ return Fst;
+ end First_Node;
+
+ --------------------------
+ -- First_And_Last_Nodes --
+ --------------------------
+
+ procedure First_And_Last_Nodes
+ (C : Node_Id;
+ First_Node, Last_Node : out Node_Id)
+ is
Orig : constant Node_Id := Original_Node (C);
Loc : constant Source_Ptr := Sloc (Orig);
Sfile : constant Source_File_Index := Get_Source_File_Index (Loc);
Earliest : Node_Id;
+ Latest : Node_Id;
Eloc : Source_Ptr;
+ Lloc : Source_Ptr;
- function Test_Earlier (N : Node_Id) return Traverse_Result;
+ function Test_First_And_Last (N : Node_Id) return Traverse_Result;
-- Function applied to every node in the construct
- procedure Search_Tree_First is new Traverse_Proc (Test_Earlier);
+ procedure Search_Tree_First_And_Last is new
+ Traverse_Proc (Test_First_And_Last);
-- Create traversal procedure
- ------------------
- -- Test_Earlier --
- ------------------
+ -------------------------
+ -- Test_First_And_Last --
+ -------------------------
- function Test_Earlier (N : Node_Id) return Traverse_Result is
+ function Test_First_And_Last (N : Node_Id) return Traverse_Result is
Norig : constant Node_Id := Original_Node (N);
Loc : constant Source_Ptr := Sloc (Norig);
@@ -1670,22 +1774,63 @@ package body Errout is
Eloc := Loc;
end if;
+ -- Check for later
+
+ if Loc > Lloc
+
+ -- Ignore nodes with no useful location information
+
+ and then Loc /= Standard_Location
+ and then Loc /= No_Location
+
+ -- Ignore nodes from a different file. This ensures against cases
+ -- of strange foreign code somehow being present. We don't want
+ -- wild placement of messages if that happens.
+
+ and then Get_Source_File_Index (Loc) = Sfile
+ then
+ Latest := Norig;
+ Lloc := Loc;
+ end if;
+
return OK_Orig;
- end Test_Earlier;
+ end Test_First_And_Last;
- -- Start of processing for First_Node
+ -- Start of processing for First_And_Last_Nodes
begin
- if Nkind (Orig) in N_Subexpr then
+ if Nkind (Orig) in N_Subexpr
+ | N_Declaration
+ | N_Access_To_Subprogram_Definition
+ | N_Generic_Instantiation
+ | N_Later_Decl_Item
+ | N_Use_Package_Clause
+ | N_Array_Type_Definition
+ | N_Renaming_Declaration
+ | N_Generic_Renaming_Declaration
+ | N_Assignment_Statement
+ | N_Raise_Statement
+ | N_Simple_Return_Statement
+ | N_Exit_Statement
+ | N_Pragma
+ | N_Use_Type_Clause
+ | N_With_Clause
+ | N_Attribute_Definition_Clause
+ | N_Subtype_Indication
+ then
Earliest := Orig;
Eloc := Loc;
- Search_Tree_First (Orig);
- return Earliest;
+ Latest := Orig;
+ Lloc := Loc;
+ Search_Tree_First_And_Last (Orig);
+ First_Node := Earliest;
+ Last_Node := Latest;
else
- return Orig;
+ First_Node := Orig;
+ Last_Node := Orig;
end if;
- end First_Node;
+ end First_And_Last_Nodes;
----------------
-- First_Sloc --
@@ -1694,6 +1839,7 @@ package body Errout is
function First_Sloc (N : Node_Id) return Source_Ptr is
SI : constant Source_File_Index := Source_Index (Get_Source_Unit (N));
SF : constant Source_Ptr := Source_First (SI);
+ SL : constant Source_Ptr := Source_Last (SI);
F : Node_Id;
S : Source_Ptr;
@@ -1701,6 +1847,10 @@ package body Errout is
F := First_Node (N);
S := Sloc (F);
+ if S not in SF .. SL then
+ return S;
+ end if;
+
-- The following circuit is a bit subtle. When we have parenthesized
-- expressions, then the Sloc will not record the location of the paren,
-- but we would like to post the flag on the paren. So what we do is to
@@ -1786,6 +1936,88 @@ package body Errout is
-- True if S starts with Size_For
end Is_Size_Too_Small_Message;
+ ---------------
+ -- Last_Node --
+ ---------------
+
+ function Last_Node (C : Node_Id) return Node_Id is
+ Fst, Lst : Node_Id;
+ begin
+ First_And_Last_Nodes (C, Fst, Lst);
+ return Lst;
+ end Last_Node;
+
+ ---------------
+ -- Last_Sloc --
+ ---------------
+
+ function Last_Sloc (N : Node_Id) return Source_Ptr is
+ SI : constant Source_File_Index := Source_Index (Get_Source_Unit (N));
+ SF : constant Source_Ptr := Source_First (SI);
+ SL : constant Source_Ptr := Source_Last (SI);
+ F : Node_Id;
+ S : Source_Ptr;
+
+ begin
+ F := Last_Node (N);
+ S := Sloc (F);
+
+ if S not in SF .. SL then
+ return S;
+ end if;
+
+ -- Skip past an identifier
+
+ while S in SF .. SL - 1
+ and then Source_Text (SI) (S + 1)
+ in
+ '0' .. '9' | 'a' .. 'z' | 'A' .. 'Z' | '.' | '_'
+ loop
+ S := S + 1;
+ end loop;
+
+ -- The following circuit attempts at crawling up the tree from the
+ -- Last_Node, adjusting the Sloc value for any parentheses we know
+ -- are present, similarly to what is done in First_Sloc.
+
+ Node_Loop : loop
+ Paren_Loop : for J in 1 .. Paren_Count (F) loop
+
+ -- We don't look more than 12 characters after the current
+ -- location
+
+ Search_Loop : for K in 1 .. 12 loop
+ exit Node_Loop when S = SL;
+
+ if Source_Text (SI) (S + 1) = ')' then
+ S := S + 1;
+ exit Search_Loop;
+
+ elsif Source_Text (SI) (S + 1) <= ' ' then
+ S := S + 1;
+
+ else
+ exit Search_Loop;
+ end if;
+ end loop Search_Loop;
+ end loop Paren_Loop;
+
+ exit Node_Loop when F = N;
+ F := Parent (F);
+ exit Node_Loop when Nkind (F) not in N_Subexpr;
+ end loop Node_Loop;
+
+ -- Remove any trailing space
+
+ while S in SF + 1 .. SL
+ and then Source_Text (SI) (S) = ' '
+ loop
+ S := S - 1;
+ end loop;
+
+ return S;
+ end Last_Sloc;
+
-----------------
-- No_Warnings --
-----------------
@@ -1841,6 +2073,158 @@ package body Errout is
end if;
end OK_Node;
+ -------------------------
+ -- Output_JSON_Message --
+ -------------------------
+
+ procedure Output_JSON_Message (Error_Id : Error_Msg_Id) is
+
+ function Is_Continuation (E : Error_Msg_Id) return Boolean;
+ -- Return True if E is a continuation message.
+
+ procedure Write_JSON_Escaped_String (Str : String_Ptr);
+ -- Write each character of Str, taking care of preceding each quote and
+ -- backslash with a backslash. Note that this escaping differs from what
+ -- GCC does.
+ --
+ -- Indeed, the JSON specification mandates encoding wide characters
+ -- either as their direct UTF-8 representation or as their escaped
+ -- UTF-16 surrogate pairs representation. GCC seems to prefer escaping -
+ -- we choose to use the UTF-8 representation instead.
+
+ procedure Write_JSON_Location (Sptr : Source_Ptr);
+ -- Write Sptr as a JSON location, an object containing a file attribute,
+ -- a line number and a column number.
+
+ procedure Write_JSON_Span (Span : Source_Span);
+ -- Write Span as a JSON span, an object containing a "caret" attribute
+ -- whose value is the JSON location of Span.Ptr. If Span.First and
+ -- Span.Last are different from Span.Ptr, they will be printed as JSON
+ -- locations under the names "start" and "finish".
+
+ -----------------------
+ -- Is_Continuation --
+ -----------------------
+
+ function Is_Continuation (E : Error_Msg_Id) return Boolean is
+ begin
+ return E <= Last_Error_Msg and then Errors.Table (E).Msg_Cont;
+ end Is_Continuation;
+
+ -------------------------------
+ -- Write_JSON_Escaped_String --
+ -------------------------------
+
+ procedure Write_JSON_Escaped_String (Str : String_Ptr) is
+ begin
+ for C of Str.all loop
+ if C = '"' or else C = '\' then
+ Write_Char ('\');
+ end if;
+
+ Write_Char (C);
+ end loop;
+ end Write_JSON_Escaped_String;
+
+ -------------------------
+ -- Write_JSON_Location --
+ -------------------------
+
+ procedure Write_JSON_Location (Sptr : Source_Ptr) is
+ begin
+ Write_Str ("{""file"":""");
+ Write_Name (Full_Ref_Name (Get_Source_File_Index (Sptr)));
+ Write_Str (""",""line"":");
+ Write_Int (Pos (Get_Physical_Line_Number (Sptr)));
+ Write_Str (", ""column"":");
+ Write_Int (Nat (Get_Column_Number (Sptr)));
+ Write_Str ("}");
+ end Write_JSON_Location;
+
+ ---------------------
+ -- Write_JSON_Span --
+ ---------------------
+
+ procedure Write_JSON_Span (Span : Source_Span) is
+ begin
+ Write_Str ("{""caret"":");
+ Write_JSON_Location (Span.Ptr);
+
+ if Span.Ptr /= Span.First then
+ Write_Str (",""start"":");
+ Write_JSON_Location (Span.First);
+ end if;
+
+ if Span.Ptr /= Span.Last then
+ Write_Str (",""finish"":");
+ Write_JSON_Location (Span.Last);
+ end if;
+
+ Write_Str ("}");
+ end Write_JSON_Span;
+
+ -- Local Variables
+
+ E : Error_Msg_Id := Error_Id;
+
+ Print_Continuations : constant Boolean := not Is_Continuation (E);
+ -- Do not print continuations messages as children of the current
+ -- message if the current message is a continuation message.
+
+ -- Start of processing for Output_JSON_Message
+
+ begin
+
+ -- Print message kind
+
+ Write_Str ("{""kind"":");
+
+ if Errors.Table (E).Warn and then not Errors.Table (E).Warn_Err then
+ Write_Str ("""warning""");
+ elsif Errors.Table (E).Info or else Errors.Table (E).Check then
+ Write_Str ("""note""");
+ else
+ Write_Str ("""error""");
+ end if;
+
+ -- Print message location
+
+ Write_Str (",""locations"":[");
+ Write_JSON_Span (Errors.Table (E).Sptr);
+
+ if Errors.Table (E).Optr /= Errors.Table (E).Sptr.Ptr then
+ Write_Str (",{""caret"":");
+ Write_JSON_Location (Errors.Table (E).Optr);
+ Write_Str ("}");
+ end if;
+
+ -- Print message content
+
+ Write_Str ("],""message"":""");
+ Write_JSON_Escaped_String (Errors.Table (E).Text);
+ Write_Str ("""");
+
+ E := E + 1;
+
+ if Print_Continuations and then Is_Continuation (E) then
+
+ Write_Str (",""children"": [");
+ Output_JSON_Message (E);
+ E := E + 1;
+
+ while Is_Continuation (E) loop
+ Write_Str (", ");
+ Output_JSON_Message (E);
+ E := E + 1;
+ end loop;
+
+ Write_Str ("]");
+
+ end if;
+
+ Write_Str ("}");
+ end Output_JSON_Message;
+
---------------------
-- Output_Messages --
---------------------
@@ -1858,13 +2242,35 @@ package body Errout is
procedure Write_Max_Errors;
-- Write message if max errors reached
- procedure Write_Source_Code_Line (Loc : Source_Ptr);
- -- Write the source code line corresponding to Loc, as follows:
+ procedure Write_Source_Code_Lines
+ (Span : Source_Span;
+ SGR_Span : String);
+ -- Write the source code line corresponding to Span, as follows when
+ -- Span in on one line:
+ --
+ -- line | actual code line here with Span somewhere
+ -- | ~~~~~^~~~
+ --
+ -- where the caret on the line points to location Span.Ptr, and the
+ -- range Span.First..Span.Last is underlined.
+ --
+ -- or when the span is over multiple lines:
+ --
+ -- line | beginning of the Span on this line
+ -- ... | ...
+ -- line>| actual code line here with Span.Ptr somewhere
+ -- ... | ...
+ -- line | end of the Span on this line
--
- -- line | actual code line here with Loc somewhere
+ -- or when the span is a simple location, as follows:
+ --
+ -- line | actual code line here with Span somewhere
-- | ^ here
--
- -- where the carret on the last line points to location Loc.
+ -- where the caret on the line points to location Span.Ptr
+ --
+ -- SGR_Span is the SGR string to start the section of code in the span,
+ -- that should be closed with SGR_Reset.
-------------------------
-- Write_Error_Summary --
@@ -2056,17 +2462,89 @@ package body Errout is
end if;
end Write_Max_Errors;
- ----------------------------
- -- Write_Source_Code_Line --
- ----------------------------
+ -----------------------------
+ -- Write_Source_Code_Lines --
+ -----------------------------
- procedure Write_Source_Code_Line (Loc : Source_Ptr) is
+ procedure Write_Source_Code_Lines
+ (Span : Source_Span;
+ SGR_Span : String)
+ is
+ function Get_Line_End
+ (Buf : Source_Buffer_Ptr;
+ Loc : Source_Ptr) return Source_Ptr;
+ -- Get the source location for the end of the line in Buf for Loc
+
+ function Get_Line_Start
+ (Buf : Source_Buffer_Ptr;
+ Loc : Source_Ptr) return Source_Ptr;
+ -- Get the source location for the start of the line in Buf for Loc
function Image (X : Positive; Width : Positive) return String;
-- Output number X over Width characters, with whitespace padding.
-- Only output the low-order Width digits of X, if X is larger than
-- Width digits.
+ procedure Write_Buffer
+ (Buf : Source_Buffer_Ptr;
+ First : Source_Ptr;
+ Last : Source_Ptr);
+ -- Output the characters from First to Last position in Buf, using
+ -- Write_Buffer_Char.
+
+ procedure Write_Buffer_Char
+ (Buf : Source_Buffer_Ptr;
+ Loc : Source_Ptr);
+ -- Output the characters at position Loc in Buf, translating ASCII.HT
+ -- in a suitable number of spaces so that the output is not modified
+ -- by starting in a different column that 1.
+
+ procedure Write_Line_Marker
+ (Num : Pos;
+ Mark : Boolean;
+ Width : Positive);
+ -- Output the line number Num over Width characters, with possibly
+ -- a Mark to denote the line with the main location when reporting
+ -- a span over multiple lines.
+
+ ------------------
+ -- Get_Line_End --
+ ------------------
+
+ function Get_Line_End
+ (Buf : Source_Buffer_Ptr;
+ Loc : Source_Ptr) return Source_Ptr
+ is
+ Cur_Loc : Source_Ptr := Loc;
+ begin
+ while Cur_Loc <= Buf'Last
+ and then Buf (Cur_Loc) /= ASCII.LF
+ loop
+ Cur_Loc := Cur_Loc + 1;
+ end loop;
+
+ return Cur_Loc;
+ end Get_Line_End;
+
+ --------------------
+ -- Get_Line_Start --
+ --------------------
+
+ function Get_Line_Start
+ (Buf : Source_Buffer_Ptr;
+ Loc : Source_Ptr) return Source_Ptr
+ is
+ Cur_Loc : Source_Ptr := Loc;
+ begin
+ while Cur_Loc > Buf'First
+ and then Buf (Cur_Loc - 1) /= ASCII.LF
+ loop
+ Cur_Loc := Cur_Loc - 1;
+ end loop;
+
+ return Cur_Loc;
+ end Get_Line_Start;
+
-----------
-- Image --
-----------
@@ -2087,45 +2565,200 @@ package body Errout is
return Str;
end Image;
+ ------------------
+ -- Write_Buffer --
+ ------------------
+
+ procedure Write_Buffer
+ (Buf : Source_Buffer_Ptr;
+ First : Source_Ptr;
+ Last : Source_Ptr)
+ is
+ begin
+ for Loc in First .. Last loop
+ Write_Buffer_Char (Buf, Loc);
+ end loop;
+ end Write_Buffer;
+
+ -----------------------
+ -- Write_Buffer_Char --
+ -----------------------
+
+ procedure Write_Buffer_Char
+ (Buf : Source_Buffer_Ptr;
+ Loc : Source_Ptr)
+ is
+ begin
+ -- If the character ASCII.HT is not the last one in the file,
+ -- output as many spaces as the character represents in the
+ -- original source file.
+
+ if Buf (Loc) = ASCII.HT
+ and then Loc < Buf'Last
+ then
+ for X in Get_Column_Number (Loc) ..
+ Get_Column_Number (Loc + 1) - 1
+ loop
+ Write_Char (' ');
+ end loop;
+
+ -- Otherwise output the character itself
+
+ else
+ Write_Char (Buf (Loc));
+ end if;
+ end Write_Buffer_Char;
+
+ -----------------------
+ -- Write_Line_Marker --
+ -----------------------
+
+ procedure Write_Line_Marker
+ (Num : Pos;
+ Mark : Boolean;
+ Width : Positive)
+ is
+ begin
+ Write_Str (Image (Positive (Num), Width => Width));
+ Write_Str ((if Mark then ">" else " ") & "|");
+ end Write_Line_Marker;
+
-- Local variables
- Line : constant Pos := Pos (Get_Physical_Line_Number (Loc));
- Col : constant Natural := Natural (Get_Column_Number (Loc));
- Width : constant := 5;
+ Loc : constant Source_Ptr := Span.Ptr;
+ Line : constant Pos := Pos (Get_Physical_Line_Number (Loc));
+
+ Col : constant Natural := Natural (Get_Column_Number (Loc));
- Buf : Source_Buffer_Ptr;
- Cur_Loc : Source_Ptr := Loc;
+ Fst : constant Source_Ptr := Span.First;
+ Line_Fst : constant Pos :=
+ Pos (Get_Physical_Line_Number (Fst));
+ Col_Fst : constant Natural :=
+ Natural (Get_Column_Number (Fst));
+ Lst : constant Source_Ptr := Span.Last;
+ Line_Lst : constant Pos :=
+ Pos (Get_Physical_Line_Number (Lst));
+ Col_Lst : constant Natural :=
+ Natural (Get_Column_Number (Lst));
- -- Start of processing for Write_Source_Code_Line
+ Width : constant := 5;
+ Buf : Source_Buffer_Ptr;
+ Cur_Loc : Source_Ptr := Fst;
+ Cur_Line : Pos := Line_Fst;
+
+ -- Start of processing for Write_Source_Code_Lines
begin
if Loc >= First_Source_Ptr then
Buf := Source_Text (Get_Source_File_Index (Loc));
- -- First line with the actual source code line
+ -- First line of the span with actual source code. We retrieve
+ -- the beginning of the line instead of relying on Col_Fst, as
+ -- ASCII.HT characters change column numbers by possibly more
+ -- than one.
- Write_Str (Image (Positive (Line), Width => Width));
- Write_Str (" |");
- Write_Str (String (Buf (Loc - Source_Ptr (Col) + 1 .. Loc - 1)));
+ Write_Line_Marker
+ (Cur_Line,
+ Line_Fst /= Line_Lst and then Cur_Line = Line,
+ Width);
+ Write_Buffer (Buf, Get_Line_Start (Buf, Cur_Loc), Cur_Loc - 1);
- while Cur_Loc <= Buf'Last
- and then Buf (Cur_Loc) /= ASCII.LF
- loop
- Write_Char (Buf (Cur_Loc));
- Cur_Loc := Cur_Loc + 1;
- end loop;
+ -- Output the first/caret/last lines of the span, as well as
+ -- lines that are directly above/below the caret if they complete
+ -- the gap with first/last lines, otherwise use ... to denote
+ -- intermediate lines.
- Write_Eol;
+ -- If the span is on one line and not a simple source location,
+ -- color it appropriately.
- -- Second line with carret sign pointing to location Loc
+ if Line_Fst = Line_Lst
+ and then Col_Fst /= Col_Lst
+ then
+ Write_Str (SGR_Span);
+ end if;
- Write_Str (String'(1 .. Width => ' '));
- Write_Str (" |");
- Write_Str (String'(1 .. Col - 1 => ' '));
- Write_Str ("^ here");
- Write_Eol;
+ declare
+ function Do_Write_Line (Cur_Line : Pos) return Boolean is
+ (Cur_Line in Line_Fst | Line | Line_Lst
+ or else
+ (Cur_Line = Line_Fst + 1 and then Cur_Line = Line - 1)
+ or else
+ (Cur_Line = Line + 1 and then Cur_Line = Line_Lst - 1));
+ begin
+ while Cur_Loc <= Buf'Last
+ and then Cur_Loc <= Lst
+ loop
+ if Do_Write_Line (Cur_Line) then
+ Write_Buffer_Char (Buf, Cur_Loc);
+ end if;
+
+ Cur_Loc := Cur_Loc + 1;
+
+ if Buf (Cur_Loc - 1) = ASCII.LF then
+ Cur_Line := Cur_Line + 1;
+
+ -- Output ... for skipped lines
+
+ if (Cur_Line = Line
+ and then not Do_Write_Line (Cur_Line - 1))
+ or else
+ (Cur_Line = Line + 1
+ and then not Do_Write_Line (Cur_Line))
+ then
+ Write_Str ((1 .. Width - 3 => ' ') & "... | ...");
+ Write_Eol;
+ end if;
+
+ -- Display the line marker if the line should be
+ -- displayed.
+
+ if Do_Write_Line (Cur_Line) then
+ Write_Line_Marker
+ (Cur_Line,
+ Line_Fst /= Line_Lst and then Cur_Line = Line,
+ Width);
+ end if;
+ end if;
+ end loop;
+ end;
+
+ if Line_Fst = Line_Lst
+ and then Col_Fst /= Col_Lst
+ then
+ Write_Str (SGR_Reset);
+ end if;
+
+ -- Output the rest of the last line of the span
+
+ Write_Buffer (Buf, Cur_Loc, Get_Line_End (Buf, Cur_Loc));
+
+ -- If the span is on one line, output a second line with caret
+ -- sign pointing to location Loc
+
+ if Line_Fst = Line_Lst then
+ Write_Str (String'(1 .. Width => ' '));
+ Write_Str (" |");
+ Write_Str (String'(1 .. Col_Fst - 1 => ' '));
+
+ Write_Str (SGR_Span);
+
+ Write_Str (String'(Col_Fst .. Col - 1 => '~'));
+ Write_Str ("^");
+ Write_Str (String'(Col + 1 .. Col_Lst => '~'));
+
+ -- If the span is really just a location, add the word "here"
+ -- to clarify this is the location for the message.
+
+ if Col_Fst = Col_Lst then
+ Write_Str (" here");
+ end if;
+
+ Write_Str (SGR_Reset);
+
+ Write_Eol;
+ end if;
end if;
- end Write_Source_Code_Line;
+ end Write_Source_Code_Lines;
-- Local variables
@@ -2152,9 +2785,46 @@ package body Errout is
Current_Error_Source_File := No_Source_File;
end if;
+ if Opt.JSON_Output then
+ Set_Standard_Error;
+
+ E := First_Error_Msg;
+
+ -- Find first printable message
+
+ while E /= No_Error_Msg and then Errors.Table (E).Deleted loop
+ E := Errors.Table (E).Next;
+ end loop;
+
+ Write_Char ('[');
+
+ if E /= No_Error_Msg then
+
+ Output_JSON_Message (E);
+
+ E := Errors.Table (E).Next;
+
+ -- Skip deleted messages.
+ -- Also skip continuation messages, as they have already been
+ -- printed along the message they're attached to.
+
+ while E /= No_Error_Msg
+ and then not Errors.Table (E).Deleted
+ and then not Errors.Table (E).Msg_Cont
+ loop
+ Write_Char (',');
+ Output_JSON_Message (E);
+ E := Errors.Table (E).Next;
+ end loop;
+ end if;
+
+ Write_Char (']');
+
+ Set_Standard_Output;
+
-- Brief Error mode
- if Brief_Output or (not Full_List and not Verbose_Mode) then
+ elsif Brief_Output or (not Full_List and not Verbose_Mode) then
Set_Standard_Error;
E := First_Error_Msg;
@@ -2180,6 +2850,8 @@ package body Errout is
end if;
if Use_Prefix then
+ Write_Str (SGR_Locus);
+
if Full_Path_Name_For_Brief_Errors then
Write_Name (Full_Ref_Name (Errors.Table (E).Sfile));
else
@@ -2198,6 +2870,8 @@ package body Errout is
Write_Int (Int (Errors.Table (E).Col));
Write_Str (": ");
+
+ Write_Str (SGR_Reset);
end if;
Output_Msg_Text (E);
@@ -2217,12 +2891,23 @@ package body Errout is
Errors.Table (E).Insertion_Sloc;
begin
if Loc /= No_Location then
- Write_Source_Code_Line (Loc);
+ Write_Source_Code_Lines
+ (To_Span (Loc), SGR_Span => SGR_Note);
end if;
end;
else
- Write_Source_Code_Line (Errors.Table (E).Sptr);
+ declare
+ SGR_Span : constant String :=
+ (if Errors.Table (E).Info then SGR_Note
+ elsif Errors.Table (E).Warn
+ and then not Errors.Table (E).Warn_Err
+ then SGR_Warning
+ else SGR_Error);
+ begin
+ Write_Source_Code_Lines
+ (Errors.Table (E).Sptr, SGR_Span);
+ end;
end if;
end if;
end if;
@@ -2355,11 +3040,12 @@ package body Errout is
-- subunits for a body).
while E /= No_Error_Msg
- and then (not In_Extended_Main_Source_Unit (Errors.Table (E).Sptr)
+ and then (not In_Extended_Main_Source_Unit
+ (Errors.Table (E).Sptr.Ptr)
or else
(Debug_Flag_Dot_M
and then Get_Source_Unit
- (Errors.Table (E).Sptr) /= Main_Unit))
+ (Errors.Table (E).Sptr.Ptr) /= Main_Unit))
loop
if Errors.Table (E).Deleted then
E := Errors.Table (E).Next;
@@ -2420,7 +3106,9 @@ package body Errout is
Write_Error_Summary;
end if;
- Write_Max_Errors;
+ if not Opt.JSON_Output then
+ Write_Max_Errors;
+ end if;
-- Even though Warning_Info_Messages are a subclass of warnings, they
-- must not be treated as errors when -gnatwe is in effect.
@@ -2739,7 +3427,7 @@ package body Errout is
-- For standard locations, always use mixed case
if Loc <= No_Location then
- Set_Casing (Mixed_Case);
+ Set_Casing (Buf, Mixed_Case);
else
-- Determine if the reference we are dealing with corresponds to
@@ -2777,11 +3465,6 @@ package body Errout is
end;
end Adjust_Name_Case;
- procedure Adjust_Name_Case (Loc : Source_Ptr) is
- begin
- Adjust_Name_Case (Global_Name_Buffer, Loc);
- end Adjust_Name_Case;
-
---------------------------
-- Set_Identifier_Casing --
---------------------------
@@ -3535,7 +4218,8 @@ package body Errout is
-- other errors. The reason we eliminate unfrozen types is that
-- messages issued before the freeze type are for sure OK.
- elsif Is_Frozen (E)
+ elsif Nkind (N) in N_Entity
+ and then Is_Frozen (E)
and then Serious_Errors_Detected > 0
and then Nkind (N) /= N_Component_Clause
and then Nkind (Parent (N)) /= N_Component_Clause
diff --git a/gcc/ada/errout.ads b/gcc/ada/errout.ads
index 02cfdee..9b2e08d 100644
--- a/gcc/ada/errout.ads
+++ b/gcc/ada/errout.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -279,7 +279,7 @@ package Errout is
-- The character ? appearing anywhere in a message makes the message
-- warning instead of a normal error message, and the text of the
-- message will be preceded by "warning:" in the normal case. The
- -- handling of warnings if further controlled by the Warning_Mode
+ -- handling of warnings is further controlled by the Warning_Mode
-- option (-w switch), see package Opt for further details, and also by
-- the current setting from pragma Warnings. This pragma applies only
-- to warnings issued from the semantic phase (not the parser), but
@@ -519,7 +519,7 @@ package Errout is
-- The prefixes error and warning are supplied automatically (depending
-- on the use of the ? insertion character), and the call to the error
-- message routine supplies the text. The "error: " prefix is omitted
- -- in brief error message formats.
+ -- if -gnatd_U is among the options given to gnat.
-- Reserved Ada keywords in the message are in the default keyword case
-- (determined from the given source program), surrounded by quotation
@@ -703,10 +703,15 @@ package Errout is
procedure Error_Msg
(Msg : String; Flag_Location : Source_Ptr);
procedure Error_Msg
+ (Msg : String; Flag_Span : Source_Span);
+ procedure Error_Msg
(Msg : String; Flag_Location : Source_Ptr; N : Node_Id);
+ procedure Error_Msg
+ (Msg : String; Flag_Span : Source_Span; N : Node_Id);
-- Output a message at specified location. Can be called from the parser
-- or the semantic analyzer. If N is set, points to the relevant node for
- -- this message.
+ -- this message. The version with a span is preferred whenever possible,
+ -- in other cases the version with a location can still be used.
procedure Error_Msg
(Msg : String;
@@ -782,8 +787,13 @@ package Errout is
N : Node_Or_Entity_Id;
E : Node_Or_Entity_Id;
Flag_Location : Source_Ptr);
+ procedure Error_Msg_NEL
+ (Msg : String;
+ N : Node_Or_Entity_Id;
+ E : Node_Or_Entity_Id;
+ Flag_Span : Source_Span);
-- Exactly the same as Error_Msg_NE, except that the flag is placed at
- -- the specified Flag_Location instead of at Sloc (N).
+ -- the specified Flag_Location/Flag_Span instead of at Sloc (N).
procedure Error_Msg_NW
(Eflag : Boolean;
@@ -801,12 +811,17 @@ package Errout is
-- the given text. This text may contain insertion characters in the
-- usual manner, and need not be the same length as the original text.
+ procedure First_And_Last_Nodes
+ (C : Node_Id;
+ First_Node, Last_Node : out Node_Id);
+ -- Given a construct C, finds the first and last node in the construct,
+ -- i.e. the ones with the lowest and highest Sloc value. This is useful in
+ -- placing error msgs. Note that this procedure uses Original_Node to look
+ -- at the original source tree, since that's what we want for placing an
+ -- error message flag in the right place.
+
function First_Node (C : Node_Id) return Node_Id;
- -- Given a construct C, finds the first node in the construct, i.e. the one
- -- with the lowest Sloc value. This is useful in placing error msgs. Note
- -- that this procedure uses Original_Node to look at the original source
- -- tree, since that's what we want for placing an error message flag in
- -- the right place.
+ -- Return the first output of First_And_Last_Nodes
function First_Sloc (N : Node_Id) return Source_Ptr;
-- Given the node for an expression, return a source pointer value that
@@ -817,6 +832,15 @@ package Errout is
function Get_Ignore_Errors return Boolean;
-- Return True if all error calls are ignored.
+ function Last_Node (C : Node_Id) return Node_Id;
+ -- Return the last output of First_And_Last_Nodes
+
+ function Last_Sloc (N : Node_Id) return Source_Ptr;
+ -- Given the node for an expression, return a source pointer value that
+ -- points to the end of the last token in the expression. In the case
+ -- where the expression is parenthesized, an attempt is made to include
+ -- the parentheses (i.e. to return the location of the final paren).
+
procedure Purge_Messages (From : Source_Ptr; To : Source_Ptr)
renames Erroutc.Purge_Messages;
-- All error messages whose location is in the range From .. To (not
@@ -915,8 +939,13 @@ package Errout is
-- 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 Error_Msg_Ada_2022_Feature (Feature : String; Loc : Source_Ptr);
+ -- Analogous to Error_Msg_Ada_2012_Feature, for Ada 2022
+
+ procedure Error_Msg_GNAT_Extension (Extension : String);
+ -- If not operating with extensions allowed, posts errors complaining
+ -- that Extension is only supported when the -gnatX switch is enabled,
+ -- with appropriate suggestions to fix it.
procedure dmsg (Id : Error_Msg_Id) renames Erroutc.dmsg;
-- Debugging routine to dump an error message
@@ -956,13 +985,10 @@ package Errout is
-- the name at that source location, we copy the casing from the source,
-- otherwise we set appropriate default casing.
- procedure Adjust_Name_Case (Loc : Source_Ptr);
- -- Uses Buf => Global_Name_Buffer. There are no calls to this in the
- -- compiler, but it is called in SPARK 2014.
-
procedure Set_Identifier_Casing
(Identifier_Name : System.Address;
File_Name : System.Address);
+ pragma Convention (C, Set_Identifier_Casing);
-- This subprogram can be used by the back end for the purposes of
-- concocting error messages that are not output via Errout, e.g.
-- the messages generated by the gcc back end.
@@ -982,8 +1008,8 @@ package Errout is
Size_Too_Small_Message : constant String :=
"size for& too small, minimum allowed is ^";
-- This message is printed in Freeze and Sem_Ch13. We also test for it in
- -- the body of this package (see Special_Msg_Delete) ???which is somewhat
- -- questionable. The Is_Size_Too_Small_Message function tests for it by
- -- testing a prefix. The function and constant should be kept in synch.
+ -- the body of this package (see Special_Msg_Delete).
+ -- Function Is_Size_Too_Small_Message tests for it by testing a prefix.
+ -- The function and constant should be kept in synch.
end Errout;
diff --git a/gcc/ada/erroutc.adb b/gcc/ada/erroutc.adb
index d0cc6ff..a2cd3c3 100644
--- a/gcc/ada/erroutc.adb
+++ b/gcc/ada/erroutc.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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,6 @@ package body Erroutc is
-- Local Subprograms --
-----------------------
- function Matches (S : String; P : String) return Boolean;
- -- 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).
-
function Sloc_In_Range (Loc, Start, Stop : Source_Ptr) return Boolean;
-- Return whether Loc is in the range Start .. Stop, taking instantiation
-- locations of Loc into account. This is useful for suppressing warnings
@@ -321,7 +316,7 @@ package body Erroutc is
Write_Str
(" Sptr = ");
- Write_Location (E.Sptr);
+ Write_Location (E.Sptr.Ptr); -- ??? Do not write the full span for now
Write_Eol;
Write_Str
@@ -350,7 +345,7 @@ package body Erroutc is
function Get_Location (E : Error_Msg_Id) return Source_Ptr is
begin
- return Errors.Table (E).Sptr;
+ return Errors.Table (E).Sptr.Ptr;
end Get_Location;
----------------
@@ -477,7 +472,7 @@ package body Erroutc is
and then Errors.Table (T).Line = Errors.Table (E).Line
and then Errors.Table (T).Sfile = Errors.Table (E).Sfile
loop
- if Errors.Table (T).Sptr > Errors.Table (E).Sptr then
+ if Errors.Table (T).Sptr.Ptr > Errors.Table (E).Sptr.Ptr then
Mult_Flags := True;
end if;
@@ -490,7 +485,7 @@ package body Erroutc is
if not Debug_Flag_2 then
Write_Str (" ");
- P := Line_Start (Errors.Table (E).Sptr);
+ P := Line_Start (Errors.Table (E).Sptr.Ptr);
Flag_Num := 1;
-- Loop through error messages for this line to place flags
@@ -507,7 +502,7 @@ package body Erroutc is
begin
-- Loop to output blanks till current flag position
- while P < Errors.Table (T).Sptr loop
+ while P < Errors.Table (T).Sptr.Ptr loop
-- Horizontal tab case, just echo the tab
@@ -536,7 +531,7 @@ package body Erroutc is
-- Output flag (unless already output, this happens if more
-- than one error message occurs at the same flag position).
- if P = Errors.Table (T).Sptr then
+ if P = Errors.Table (T).Sptr.Ptr then
if (Flag_Num = 1 and then not Mult_Flags)
or else Flag_Num > 9
then
@@ -699,7 +694,7 @@ package body Erroutc is
-- For info messages, prefix message with "info: "
elsif E_Msg.Info then
- Txt := new String'("info: " & Txt.all);
+ Txt := new String'(SGR_Note & "info: " & SGR_Reset & Txt.all);
-- Warning treated as error
@@ -709,27 +704,58 @@ package body Erroutc is
-- [warning-as-error] at the end.
Warnings_Treated_As_Errors := Warnings_Treated_As_Errors + 1;
- Txt := new String'("error: " & Txt.all & " [warning-as-error]");
+ Txt := new String'(SGR_Error & "error: " & SGR_Reset
+ & Txt.all & " [warning-as-error]");
-- Normal warning, prefix with "warning: "
elsif E_Msg.Warn then
- Txt := new String'("warning: " & Txt.all);
+ Txt := new String'(SGR_Warning & "warning: " & SGR_Reset & Txt.all);
- -- No prefix needed for style message, "(style)" is there already
+ -- No prefix needed for style message, "(style)" is there already,
+ -- although not necessarily in first position if -gnatdJ is used.
elsif E_Msg.Style then
- null;
+ if Txt (Txt'First .. Txt'First + 6) = "(style)" then
+ Txt := new String'(SGR_Warning & "(style)" & SGR_Reset
+ & Txt (Txt'First + 7 .. Txt'Last));
+ end if;
-- No prefix needed for check message, severity is there already
elsif E_Msg.Check then
- null;
+
+ -- The message format is "severity: ..."
+ --
+ -- Enclose the severity with an SGR control string if requested
+
+ if Use_SGR_Control then
+ declare
+ Msg : String renames Text.all;
+ Colon : Natural := 0;
+ begin
+ -- Find first colon
+
+ for J in Msg'Range loop
+ if Msg (J) = ':' then
+ Colon := J;
+ exit;
+ end if;
+ end loop;
+
+ pragma Assert (Colon > 0);
+
+ Txt := new String'(SGR_Error
+ & Msg (Msg'First .. Colon)
+ & SGR_Reset
+ & Msg (Colon + 1 .. Msg'Last));
+ end;
+ end if;
-- All other cases, add "error: " if unique error tag set
elsif Opt.Unique_Error_Tag then
- Txt := new String'("error: " & Txt.all);
+ Txt := new String'(SGR_Error & "error: " & SGR_Reset & Txt.all);
end if;
-- Set error message line length and length of message
@@ -955,8 +981,8 @@ package body Erroutc is
function To_Be_Purged (E : Error_Msg_Id) return Boolean is
begin
if E /= No_Error_Msg
- and then Errors.Table (E).Sptr > From
- and then Errors.Table (E).Sptr < To
+ and then Errors.Table (E).Sptr.Ptr > From
+ and then Errors.Table (E).Sptr.Ptr < To
then
if Errors.Table (E).Warn or else Errors.Table (E).Style then
Warnings_Detected := Warnings_Detected - 1;
diff --git a/gcc/ada/erroutc.ads b/gcc/ada/erroutc.ads
index 4c0e68a..891391c 100644
--- a/gcc/ada/erroutc.ads
+++ b/gcc/ada/erroutc.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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,7 +197,7 @@ package Erroutc is
-- refers to a template, always references the original template
-- not an instantiation copy.
- Sptr : Source_Ptr;
+ Sptr : Source_Span;
-- Flag pointer. In the case of an error that refers to a template,
-- always references the original template, not an instantiation copy.
-- This value is the actual place in the source that the error message
@@ -390,6 +390,66 @@ package Erroutc is
-- find such an On entry, we cancel the indication of it being the
-- configuration case. This seems to handle all cases we run into ok.
+ -------------------
+ -- Color Control --
+ -------------------
+
+ Use_SGR_Control : Boolean := False;
+ -- Set to True for enabling colored output. This should only be done when
+ -- outputting messages to a terminal that supports it.
+
+ -- Colors in messages output to a terminal are controlled using SGR
+ -- (Select Graphic Rendition).
+
+ Color_Separator : constant String := ";";
+ Color_None : constant String := "00";
+ Color_Bold : constant String := "01";
+ Color_Underscore : constant String := "04";
+ Color_Blink : constant String := "05";
+ Color_Reverse : constant String := "07";
+ Color_Fg_Black : constant String := "30";
+ Color_Fg_Red : constant String := "31";
+ Color_Fg_Green : constant String := "32";
+ Color_Fg_Yellow : constant String := "33";
+ Color_Fg_Blue : constant String := "34";
+ Color_Fg_Magenta : constant String := "35";
+ Color_Fg_Cyan : constant String := "36";
+ Color_Fg_White : constant String := "37";
+ Color_Bg_Black : constant String := "40";
+ Color_Bg_Red : constant String := "41";
+ Color_Bg_Green : constant String := "42";
+ Color_Bg_Yellow : constant String := "43";
+ Color_Bg_Blue : constant String := "44";
+ Color_Bg_Magenta : constant String := "45";
+ Color_Bg_Cyan : constant String := "46";
+ Color_Bg_White : constant String := "47";
+
+ SGR_Start : constant String := ASCII.ESC & "[";
+ SGR_End : constant String := "m" & ASCII.ESC & "[K";
+
+ function SGR_Seq (Str : String) return String is
+ (if Use_SGR_Control then SGR_Start & Str & SGR_End else "");
+ -- Return the SGR control string for the commands in Str. It returns the
+ -- empty string if Use_SGR_Control is False, so that we can insert this
+ -- string unconditionally.
+
+ function SGR_Reset return String is (SGR_Seq (""));
+ -- This ends the current section of colored output
+
+ -- We're using the same colors as gcc/g++ for errors/warnings/notes/locus.
+ -- More colors are defined in gcc/g++ for other features of diagnostic
+ -- messages (e.g. inline types, fixit) and could be used in GNAT in the
+ -- future. The following functions start a section of colored output.
+
+ function SGR_Error return String is
+ (SGR_Seq (Color_Bold & Color_Separator & Color_Fg_Red));
+ function SGR_Warning return String is
+ (SGR_Seq (Color_Bold & Color_Separator & Color_Fg_Magenta));
+ function SGR_Note return String is
+ (SGR_Seq (Color_Bold & Color_Separator & Color_Fg_Cyan));
+ function SGR_Locus return String is
+ (SGR_Seq (Color_Bold));
+
-----------------
-- Subprograms --
-----------------
@@ -436,6 +496,11 @@ package Erroutc is
-- 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.
+ function Matches (S : String; P : String) return Boolean;
+ -- 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).
+
procedure Output_Error_Msgs (E : in out Error_Msg_Id);
-- Output source line, error flag, and text of stored error message and all
-- subsequent messages for the same line and unit. On return E is set to be
diff --git a/gcc/ada/errutil.adb b/gcc/ada/errutil.adb
index d4821fc..4e398d1 100644
--- a/gcc/ada/errutil.adb
+++ b/gcc/ada/errutil.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1991-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1991-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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,7 +207,7 @@ package body Errutil is
Next => No_Error_Msg,
Prev => No_Error_Msg,
Sfile => Get_Source_File_Index (Sptr),
- Sptr => Sptr,
+ Sptr => To_Span (Sptr),
Optr => Optr,
Insertion_Sloc => No_Location,
Line => Get_Physical_Line_Number (Sptr),
@@ -234,7 +234,7 @@ package body Errutil is
Errors.Table (Cur_Msg).Sfile < Errors.Table (Next_Msg).Sfile;
if Errors.Table (Cur_Msg).Sfile = Errors.Table (Next_Msg).Sfile then
- exit when Sptr < Errors.Table (Next_Msg).Sptr;
+ exit when Sptr < Errors.Table (Next_Msg).Sptr.Ptr;
end if;
Prev_Msg := Next_Msg;
diff --git a/gcc/ada/errutil.ads b/gcc/ada/errutil.ads
index 56bd242..9f7c1c2 100644
--- a/gcc/ada/errutil.ads
+++ b/gcc/ada/errutil.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2002-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2002-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute 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.adb b/gcc/ada/eval_fat.adb
index 8160cba..68a25d1 100644
--- a/gcc/ada/eval_fat.adb
+++ b/gcc/ada/eval_fat.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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,11 @@
-- --
------------------------------------------------------------------------------
-with Einfo; use Einfo;
-with Errout; use Errout;
-with Opt; use Opt;
-with Sem_Util; use Sem_Util;
+with Einfo; use Einfo;
+with Einfo.Utils; use Einfo.Utils;
+with Errout; use Errout;
+with Opt; use Opt;
+with Sem_Util; use Sem_Util;
package body Eval_Fat is
@@ -729,30 +730,40 @@ package body Eval_Fat is
New_Frac : T;
begin
+ -- Treat zero as a regular denormalized number if they are supported,
+ -- otherwise return the smallest normalized number.
+
if UR_Is_Zero (X) then
- Exp := Emin;
+ if Has_Denormals (RT) then
+ Exp := Emin;
+ else
+ return Scaling (RT, Ureal_Half, Emin);
+ end if;
end if;
- -- Set exponent such that the radix point will be directly following the
- -- mantissa after scaling.
-
- if Has_Denormals (RT) or Exp /= Emin then
- Exp := Exp - Mantissa;
- else
- Exp := Exp - 1;
- end if;
+ -- Multiply the number by 2.0**(Mantissa-Exp) so that the radix point
+ -- will be directly following the mantissa after scaling.
+ Exp := Exp - Mantissa;
Frac := Scaling (RT, X, -Exp);
+
+ -- Round to the neareast integer towards +Inf
+
New_Frac := Ceiling (RT, Frac);
+ -- If the rounding was a NOP, add one, except for -2.0**(Mantissa-1)
+ -- because the exponent is going to be reduced.
+
if New_Frac = Frac then
if New_Frac = Scaling (RT, -Ureal_1, Mantissa - 1) then
- New_Frac := New_Frac + Scaling (RT, Ureal_1, Uint_Minus_1);
+ New_Frac := New_Frac + Ureal_Half;
else
New_Frac := New_Frac + Ureal_1;
end if;
end if;
+ -- Divide back by 2.0**(Mantissa-Exp) to get the final result
+
return Scaling (RT, New_Frac, Exp);
end Succ;
diff --git a/gcc/ada/eval_fat.ads b/gcc/ada/eval_fat.ads
index d83c035..4947d74 100644
--- a/gcc/ada/eval_fat.ads
+++ b/gcc/ada/eval_fat.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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,8 +85,8 @@ package Eval_Fat is
type Rounding_Mode is (Floor, Ceiling, Round, Round_Even);
for Rounding_Mode use (0, 1, 2, 3);
+ pragma Convention (C, Rounding_Mode);
-- Used to indicate rounding mode for Machine attribute
- -- Note that C code in gigi knows that Round_Even is 3
-- The Machine attribute is special, in that it takes an extra argument
-- indicating the rounding mode, and also an argument Enode that is a
@@ -99,6 +99,8 @@ package Eval_Fat is
Mode : Rounding_Mode;
Enode : Node_Id) return T;
+ -- WARNING: There is a matching C declaration of this function in urealp.h
+
procedure Decompose_Int
(RT : R;
X : T;
diff --git a/gcc/ada/exit.c b/gcc/ada/exit.c
index adf503e..f107b17 100644
--- a/gcc/ada/exit.c
+++ b/gcc/ada/exit.c
@@ -6,7 +6,7 @@
* *
* C Implementation File *
* *
- * Copyright (C) 1992-2020, Free Software Foundation, Inc. *
+ * Copyright (C) 1992-2021, Free Software Foundation, Inc. *
* *
* GNAT is free software; you can redistribute 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 d7e5470..1b08436 100644
--- a/gcc/ada/exp_aggr.adb
+++ b/gcc/ada/exp_aggr.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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,49 +23,54 @@
-- --
------------------------------------------------------------------------------
-with Aspects; use Aspects;
-with Atree; use Atree;
-with Checks; use Checks;
-with Debug; use Debug;
-with Einfo; use Einfo;
-with Elists; use Elists;
-with Errout; use Errout;
-with Expander; use Expander;
-with Exp_Util; use Exp_Util;
-with Exp_Ch3; use Exp_Ch3;
-with Exp_Ch6; use Exp_Ch6;
-with Exp_Ch7; use Exp_Ch7;
-with Exp_Ch9; use Exp_Ch9;
-with Exp_Disp; use Exp_Disp;
-with Exp_Tss; use Exp_Tss;
-with Freeze; use Freeze;
-with Itypes; use Itypes;
-with Lib; use Lib;
-with Namet; use Namet;
-with Nmake; use Nmake;
-with Nlists; use Nlists;
-with Opt; use Opt;
-with Restrict; use Restrict;
-with Rident; use Rident;
-with Rtsfind; use Rtsfind;
-with Ttypes; use Ttypes;
-with Sem; use Sem;
-with Sem_Aggr; use Sem_Aggr;
-with Sem_Aux; use Sem_Aux;
-with Sem_Ch3; use Sem_Ch3;
-with Sem_Ch8; use Sem_Ch8;
-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;
-with Snames; use Snames;
-with Stand; use Stand;
-with Stringt; use Stringt;
-with Tbuild; use Tbuild;
-with Uintp; use Uintp;
-with Urealp; use Urealp;
+with Aspects; use Aspects;
+with Atree; use Atree;
+with Checks; use Checks;
+with Debug; use Debug;
+with Einfo; use Einfo;
+with Einfo.Entities; use Einfo.Entities;
+with Einfo.Utils; use Einfo.Utils;
+with Elists; use Elists;
+with Errout; use Errout;
+with Expander; use Expander;
+with Exp_Util; use Exp_Util;
+with Exp_Ch3; use Exp_Ch3;
+with Exp_Ch6; use Exp_Ch6;
+with Exp_Ch7; use Exp_Ch7;
+with Exp_Ch9; use Exp_Ch9;
+with Exp_Disp; use Exp_Disp;
+with Exp_Tss; use Exp_Tss;
+with Freeze; use Freeze;
+with Itypes; use Itypes;
+with Lib; use Lib;
+with Namet; use Namet;
+with Nmake; use Nmake;
+with Nlists; use Nlists;
+with Opt; use Opt;
+with Restrict; use Restrict;
+with Rident; use Rident;
+with Rtsfind; use Rtsfind;
+with Ttypes; use Ttypes;
+with Sem; use Sem;
+with Sem_Aggr; use Sem_Aggr;
+with Sem_Aux; use Sem_Aux;
+with Sem_Case; use Sem_Case;
+with Sem_Ch3; use Sem_Ch3;
+with Sem_Ch8; use Sem_Ch8;
+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;
+with Sinfo.Nodes; use Sinfo.Nodes;
+with Sinfo.Utils; use Sinfo.Utils;
+with Snames; use Snames;
+with Stand; use Stand;
+with Stringt; use Stringt;
+with Tbuild; use Tbuild;
+with Uintp; use Uintp;
+with Urealp; use Urealp;
package body Exp_Aggr is
@@ -78,15 +83,6 @@ package body Exp_Aggr is
type Case_Table_Type is array (Nat range <>) of Case_Bounds;
-- Table type used by Check_Case_Choices procedure
- procedure Collect_Initialization_Statements
- (Obj : Entity_Id;
- N : Node_Id;
- Node_After : Node_Id);
- -- If Obj is not frozen, collect actions inserted after N until, but not
- -- including, Node_After, for initialization of Obj, and move them to an
- -- expression with actions, which becomes the Initialization_Statements for
- -- Obj.
-
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);
@@ -379,15 +375,6 @@ package body Exp_Aggr is
-- 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
@@ -426,6 +413,15 @@ package body Exp_Aggr is
return Nkind (First (Assoc)) /= N_Iterated_Component_Association;
end Is_OK_Aggregate;
+ Bounds : Range_Nodes;
+ Csiz : Uint := No_Uint;
+ Ctyp : Entity_Id;
+ Expr : Node_Id;
+ Index : Entity_Id;
+ Nunits : Int;
+ Remainder : Uint;
+ Value : Uint;
+
-- Start of processing for Aggr_Assignment_OK_For_Backend
begin
@@ -448,9 +444,9 @@ package body Exp_Aggr is
Index := First_Index (Ctyp);
while Present (Index) loop
- Get_Index_Bounds (Index, Low, High);
+ Bounds := Get_Index_Bounds (Index);
- if Is_Null_Range (Low, High) then
+ if Is_Null_Range (Bounds.First, Bounds.Last) then
return False;
end if;
@@ -688,9 +684,11 @@ package body Exp_Aggr is
begin
-- We bump the maximum size unless the aggregate has a single component
-- association, which will be more efficient if implemented with a loop.
+ -- The -gnatd_g switch disables this bumping.
- if No (Expressions (N))
- and then No (Next (First (Component_Associations (N))))
+ if (No (Expressions (N))
+ and then No (Next (First (Component_Associations (N)))))
+ or else Debug_Flag_Underscore_G
then
Max_Aggr_Size := Max_Aggregate_Size (N);
else
@@ -1922,7 +1920,7 @@ package body Exp_Aggr is
function Gen_Loop (L, H : Node_Id; Expr : Node_Id) return List_Id is
Is_Iterated_Component : constant Boolean :=
- Nkind (Parent (Expr)) = N_Iterated_Component_Association;
+ Parent_Kind (Expr) = N_Iterated_Component_Association;
L_J : Node_Id;
@@ -2284,10 +2282,12 @@ package body Exp_Aggr is
Assoc : Node_Id;
Choice : Node_Id;
Expr : Node_Id;
- High : Node_Id;
- Low : Node_Id;
Typ : Entity_Id;
+ Bounds : Range_Nodes;
+ Low : Node_Id renames Bounds.First;
+ High : Node_Id renames Bounds.Last;
+
Nb_Choices : Nat := 0;
Table : Case_Table_Type (1 .. Number_Of_Choices (N));
-- Used to sort all the different choice values
@@ -2349,7 +2349,7 @@ package body Exp_Aggr is
exit;
end if;
- Get_Index_Bounds (Choice, Low, High);
+ Bounds := Get_Index_Bounds (Choice);
if Low /= High then
Set_Loop_Actions (Assoc, New_List);
@@ -2438,7 +2438,7 @@ package body Exp_Aggr is
Expr := Get_Assoc_Expr (Others_Assoc);
Dup_Expr := New_Copy_Tree (Expr);
- Set_Parent (Dup_Expr, Parent (Expr));
+ Copy_Parent (To => Dup_Expr, From => Expr);
Set_Loop_Actions (Others_Assoc, New_List);
Append_List
@@ -2471,7 +2471,7 @@ package body Exp_Aggr is
Assoc := Last (Component_Associations (N));
if Nkind (Assoc) = N_Iterated_Component_Association then
- -- Ada 2020: generate a loop to have a proper scope for
+ -- Ada 2022: generate a loop to have a proper scope for
-- the identifier that typically appears in the expression.
-- The lower bound of the loop is the position after all
-- previous positional components.
@@ -4210,40 +4210,6 @@ package body Exp_Aggr is
return L;
end Build_Record_Aggr_Code;
- ---------------------------------------
- -- Collect_Initialization_Statements --
- ---------------------------------------
-
- procedure Collect_Initialization_Statements
- (Obj : Entity_Id;
- N : Node_Id;
- Node_After : Node_Id)
- is
- Loc : constant Source_Ptr := Sloc (N);
- Init_Actions : constant List_Id := New_List;
- Init_Node : Node_Id;
- Comp_Stmt : Node_Id;
-
- begin
- -- Nothing to do if Obj is already frozen, as in this case we known we
- -- won't need to move the initialization statements about later on.
-
- if Is_Frozen (Obj) then
- return;
- end if;
-
- Init_Node := N;
- while Next (Init_Node) /= Node_After loop
- Append_To (Init_Actions, Remove_Next (Init_Node));
- end loop;
-
- if not Is_Empty_List (Init_Actions) then
- Comp_Stmt := Make_Compound_Statement (Loc, Actions => Init_Actions);
- Insert_Action_After (Init_Node, Comp_Stmt);
- Set_Initialization_Statements (Obj, Comp_Stmt);
- end if;
- end Collect_Initialization_Statements;
-
-------------------------------
-- Convert_Aggr_In_Allocator --
-------------------------------
@@ -4314,6 +4280,8 @@ package body Exp_Aggr is
Typ : constant Entity_Id := Etype (Aggr);
Occ : constant Node_Id := New_Occurrence_Of (Obj, Loc);
+ Has_Transient_Scope : Boolean := False;
+
function Discriminants_Ok return Boolean;
-- If the object type is constrained, the discriminants in the
-- aggregate must be checked against the discriminants of the subtype.
@@ -4405,7 +4373,7 @@ package body Exp_Aggr is
-- the finalization list of the return must be moved to the caller's
-- finalization list to complete the return.
- -- However, if the aggregate is limited, it is built in place, and the
+ -- Similarly if the aggregate is limited, it is built in place, and the
-- controlled components are not assigned to intermediate temporaries
-- so there is no need for a transient scope in this case either.
@@ -4414,16 +4382,72 @@ package body Exp_Aggr is
and then not Is_Limited_Type (Typ)
then
Establish_Transient_Scope (Aggr, Manage_Sec_Stack => False);
+ Has_Transient_Scope := True;
end if;
declare
- Node_After : constant Node_Id := Next (N);
+ Stmts : constant List_Id := Late_Expansion (Aggr, Typ, Occ);
+ Stmt : Node_Id;
+ Param : Node_Id;
+
begin
- Insert_Actions_After (N, Late_Expansion (Aggr, Typ, Occ));
- Collect_Initialization_Statements (Obj, N, Node_After);
+ -- If Obj is already frozen or if N is wrapped in a transient scope,
+ -- Stmts do not need to be saved in Initialization_Statements since
+ -- there is no freezing issue.
+
+ if Is_Frozen (Obj) or else Has_Transient_Scope then
+ Insert_Actions_After (N, Stmts);
+ else
+ Stmt := Make_Compound_Statement (Sloc (N), Actions => Stmts);
+ Insert_Action_After (N, Stmt);
+
+ -- Insert_Action_After may freeze Obj in which case we should
+ -- remove the compound statement just created and simply insert
+ -- Stmts after N.
+
+ if Is_Frozen (Obj) then
+ Remove (Stmt);
+ Insert_Actions_After (N, Stmts);
+ else
+ Set_Initialization_Statements (Obj, Stmt);
+ end if;
+ end if;
+
+ -- If Typ has controlled components and a call to a Slice_Assign
+ -- procedure is part of the initialization statements, then we
+ -- need to initialize the array component since Slice_Assign will
+ -- need to adjust it.
+
+ if Has_Controlled_Component (Typ) then
+ Stmt := First (Stmts);
+
+ while Present (Stmt) loop
+ if Nkind (Stmt) = N_Procedure_Call_Statement
+ and then Get_TSS_Name (Entity (Name (Stmt)))
+ = TSS_Slice_Assign
+ then
+ Param := First (Parameter_Associations (Stmt));
+ Insert_Actions
+ (Stmt,
+ Build_Initialization_Call
+ (Sloc (N), New_Copy_Tree (Param), Etype (Param)));
+ end if;
+
+ Next (Stmt);
+ end loop;
+ end if;
end;
Set_No_Initialization (N);
+
+ -- After expansion the expression can be removed from the declaration
+ -- except if the object is class-wide, in which case the aggregate
+ -- provides the actual type.
+
+ if not Is_Class_Wide_Type (Etype (Obj)) then
+ Set_Expression (N, Empty);
+ end if;
+
Initialize_Discriminants (N, Typ);
end Convert_Aggr_In_Object_Decl;
@@ -4486,11 +4510,9 @@ package body Exp_Aggr is
Is_Array : constant Boolean := Is_Array_Type (Etype (N));
Aggr_In : Node_Id;
- Aggr_Lo : Node_Id;
- Aggr_Hi : Node_Id;
+ Aggr_Bounds : Range_Nodes;
Obj_In : Node_Id;
- Obj_Lo : Node_Id;
- Obj_Hi : Node_Id;
+ Obj_Bounds : Range_Nodes;
Parent_Kind : Node_Kind;
Parent_Node : Node_Id;
@@ -4801,16 +4823,17 @@ package body Exp_Aggr is
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);
+ Aggr_Bounds := Get_Index_Bounds (Aggr_In);
+ Obj_Bounds := Get_Index_Bounds (Obj_In);
-- 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)
+ if not Compile_Time_Known_Value (Obj_Bounds.First)
+ or else not Compile_Time_Known_Value (Obj_Bounds.Last)
+ or else not Compile_Time_Known_Value (Aggr_Bounds.First)
+ or else Expr_Value (Aggr_Bounds.First) /=
+ Expr_Value (Obj_Bounds.First)
then
return False;
@@ -4826,8 +4849,9 @@ package body Exp_Aggr is
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)
+ if not Compile_Time_Known_Value (Aggr_Bounds.Last)
+ or else Expr_Value (Aggr_Bounds.Last) /=
+ Expr_Value (Obj_Bounds.Last)
then
return False;
end if;
@@ -4895,13 +4919,11 @@ package body Exp_Aggr is
-- Just set the Delay flag in the cases where the transformation will be
-- done top down from above.
- if False
-
+ if
-- Internal aggregate (transformed when expanding the parent)
- or else Parent_Kind = N_Aggregate
- or else Parent_Kind = N_Extension_Aggregate
- or else Parent_Kind = N_Component_Association
+ Parent_Kind in
+ N_Aggregate | N_Extension_Aggregate | N_Component_Association
-- Allocator (see Convert_Aggr_In_Allocator)
@@ -5670,7 +5692,7 @@ package body Exp_Aggr is
-- type using the computable sizes of the aggregate and its sub-
-- aggregates.
- procedure Check_Bounds (Aggr_Bounds : Node_Id; Index_Bounds : Node_Id);
+ procedure Check_Bounds (Aggr_Bounds_Node, Index_Bounds_Node : Node_Id);
-- Checks that the bounds of Aggr_Bounds are within the bounds defined
-- by Index_Bounds.
@@ -5694,7 +5716,7 @@ package body Exp_Aggr is
function Safe_Left_Hand_Side (N : Node_Id) return Boolean;
-- In addition to Maybe_In_Place_OK, in order for an aggregate to be
-- built directly into the target of the assignment it must be free
- -- of side effects.
+ -- of side effects. N is the LHS of an assignment.
----------------------------
-- Build_Constrained_Type --
@@ -5770,55 +5792,58 @@ package body Exp_Aggr is
-- Check_Bounds --
------------------
- procedure Check_Bounds (Aggr_Bounds : Node_Id; Index_Bounds : Node_Id) is
- Aggr_Lo : Node_Id;
- Aggr_Hi : Node_Id;
+ procedure Check_Bounds (Aggr_Bounds_Node, Index_Bounds_Node : Node_Id) is
+ Aggr_Bounds : constant Range_Nodes :=
+ Get_Index_Bounds (Aggr_Bounds_Node);
+ Ind_Bounds : constant Range_Nodes :=
+ Get_Index_Bounds (Index_Bounds_Node);
- Ind_Lo : Node_Id;
- Ind_Hi : Node_Id;
-
- Cond : Node_Id := Empty;
+ Cond : Node_Id := Empty;
begin
- Get_Index_Bounds (Aggr_Bounds, Aggr_Lo, Aggr_Hi);
- Get_Index_Bounds (Index_Bounds, Ind_Lo, Ind_Hi);
-
-- Generate the following test:
-- [constraint_error when
- -- Aggr_Lo <= Aggr_Hi and then
- -- (Aggr_Lo < Ind_Lo or else Aggr_Hi > Ind_Hi)]
+ -- Aggr_Bounds.First <= Aggr_Bounds.Last and then
+ -- (Aggr_Bounds.First < Ind_Bounds.First
+ -- or else Aggr_Bounds.Last > Ind_Bounds.Last)]
-- As an optimization try to see if some tests are trivially vacuous
-- because we are comparing an expression against itself.
- if Aggr_Lo = Ind_Lo and then Aggr_Hi = Ind_Hi then
+ if Aggr_Bounds.First = Ind_Bounds.First
+ and then Aggr_Bounds.Last = Ind_Bounds.Last
+ then
Cond := Empty;
- elsif Aggr_Hi = Ind_Hi then
+ elsif Aggr_Bounds.Last = Ind_Bounds.Last then
Cond :=
Make_Op_Lt (Loc,
- Left_Opnd => Duplicate_Subexpr_Move_Checks (Aggr_Lo),
- Right_Opnd => Duplicate_Subexpr_Move_Checks (Ind_Lo));
+ Left_Opnd =>
+ Duplicate_Subexpr_Move_Checks (Aggr_Bounds.First),
+ Right_Opnd =>
+ Duplicate_Subexpr_Move_Checks (Ind_Bounds.First));
- elsif Aggr_Lo = Ind_Lo then
+ elsif Aggr_Bounds.First = Ind_Bounds.First then
Cond :=
Make_Op_Gt (Loc,
- Left_Opnd => Duplicate_Subexpr_Move_Checks (Aggr_Hi),
- Right_Opnd => Duplicate_Subexpr_Move_Checks (Ind_Hi));
+ Left_Opnd => Duplicate_Subexpr_Move_Checks (Aggr_Bounds.Last),
+ Right_Opnd => Duplicate_Subexpr_Move_Checks (Ind_Bounds.Last));
else
Cond :=
Make_Or_Else (Loc,
Left_Opnd =>
Make_Op_Lt (Loc,
- Left_Opnd => Duplicate_Subexpr_Move_Checks (Aggr_Lo),
- Right_Opnd => Duplicate_Subexpr_Move_Checks (Ind_Lo)),
+ Left_Opnd =>
+ Duplicate_Subexpr_Move_Checks (Aggr_Bounds.First),
+ Right_Opnd =>
+ Duplicate_Subexpr_Move_Checks (Ind_Bounds.First)),
Right_Opnd =>
Make_Op_Gt (Loc,
- Left_Opnd => Duplicate_Subexpr (Aggr_Hi),
- Right_Opnd => Duplicate_Subexpr (Ind_Hi)));
+ Left_Opnd => Duplicate_Subexpr (Aggr_Bounds.Last),
+ Right_Opnd => Duplicate_Subexpr (Ind_Bounds.Last)));
end if;
if Present (Cond) then
@@ -5826,8 +5851,10 @@ package body Exp_Aggr is
Make_And_Then (Loc,
Left_Opnd =>
Make_Op_Le (Loc,
- Left_Opnd => Duplicate_Subexpr_Move_Checks (Aggr_Lo),
- Right_Opnd => Duplicate_Subexpr_Move_Checks (Aggr_Hi)),
+ Left_Opnd =>
+ Duplicate_Subexpr_Move_Checks (Aggr_Bounds.First),
+ Right_Opnd =>
+ Duplicate_Subexpr_Move_Checks (Aggr_Bounds.Last)),
Right_Opnd => Cond);
@@ -5952,6 +5979,21 @@ package body Exp_Aggr is
if Nkind (First (Choice_List (Assoc))) = N_Others_Choice then
Others_Present (Dim) := True;
+
+ -- An others_clause may be superfluous if previous components
+ -- cover the full given range of a constrained array. In such
+ -- a case an others_clause does not contribute any additional
+ -- components and has not been analyzed. We analyze it now to
+ -- detect type errors in the expression, even though no code
+ -- will be generated for it.
+
+ if Dim = Aggr_Dimension
+ and then Nkind (Assoc) /= N_Iterated_Component_Association
+ and then not Analyzed (Expression (Assoc))
+ and then not Box_Present (Assoc)
+ then
+ Preanalyze_And_Resolve (Expression (Assoc), Ctyp);
+ end if;
end if;
end if;
@@ -6079,8 +6121,6 @@ package body Exp_Aggr is
-- Used to sort all the different choice values
J : Pos := 1;
- Low : Node_Id;
- High : Node_Id;
begin
Assoc := First (Component_Associations (Sub_Aggr));
@@ -6091,9 +6131,13 @@ package body Exp_Aggr is
exit;
end if;
- Get_Index_Bounds (Choice, Low, High);
- Table (J).Choice_Lo := Low;
- Table (J).Choice_Hi := High;
+ declare
+ Bounds : constant Range_Nodes :=
+ Get_Index_Bounds (Choice);
+ begin
+ Table (J).Choice_Lo := Bounds.First;
+ Table (J).Choice_Hi := Bounds.Last;
+ end;
J := J + 1;
Next (Choice);
@@ -6555,8 +6599,8 @@ package body Exp_Aggr is
-- For assignments we do the assignment in place if all the component
-- associations have compile-time known values, or are default-
-- initialized limited components, e.g. tasks. For other cases we
- -- create a temporary. The analysis for safety of on-line assignment
- -- is delicate, i.e. we don't know how to do it fully yet ???
+ -- create a temporary. A full analysis for safety of in-place assignment
+ -- is delicate.
-- For allocators we assign to the designated object in place if the
-- aggregate meets the same conditions as other in-place assignments.
@@ -6627,7 +6671,7 @@ package body Exp_Aggr is
-- aggregate. If the declaration has a subtype mark, use it,
-- otherwise use the itype of the aggregate.
- Set_Ekind (Tmp, E_Variable);
+ Mutate_Ekind (Tmp, E_Variable);
if not Is_Constrained (Typ) then
Build_Constrained_Type (Positional => False);
@@ -6655,9 +6699,13 @@ package body Exp_Aggr is
Set_Expansion_Delayed (N);
return;
- -- In the remaining cases the aggregate is the RHS of an assignment
+ -- In the remaining cases the aggregate appears in the RHS of an
+ -- assignment, which may be part of the expansion of an object
+ -- delaration. If the aggregate is an actual in a call, itself
+ -- possibly in a RHS, building it in the target is not possible.
elsif Maybe_In_Place_OK
+ and then Nkind (Parent_Node) not in N_Subprogram_Call
and then Safe_Left_Hand_Side (Name (Parent_Node))
then
Tmp := Name (Parent_Node);
@@ -6793,6 +6841,7 @@ package body Exp_Aggr is
-- code must be inserted after it. The defining entity might not come
-- from source if this is part of an inlined body, but the declaration
-- itself will.
+ -- The test below looks very specialized and kludgy???
if Comes_From_Source (Tmp)
or else
@@ -6800,18 +6849,18 @@ package body Exp_Aggr is
and then Comes_From_Source (Parent (N))
and then Tmp = Defining_Entity (Parent (N)))
then
- declare
- Node_After : constant Node_Id := Next (Parent_Node);
-
- begin
+ if Parent_Kind /= N_Object_Declaration or else Is_Frozen (Tmp) then
Insert_Actions_After (Parent_Node, Aggr_Code);
-
- if Parent_Kind = N_Object_Declaration then
- Collect_Initialization_Statements
- (Obj => Tmp, N => Parent_Node, Node_After => Node_After);
- end if;
- end;
-
+ else
+ declare
+ Comp_Stmt : constant Node_Id :=
+ Make_Compound_Statement
+ (Sloc (Parent_Node), Actions => Aggr_Code);
+ begin
+ Insert_Action_After (Parent_Node, Comp_Stmt);
+ Set_Initialization_Statements (Tmp, Comp_Stmt);
+ end;
+ end if;
else
Insert_Actions (N, Aggr_Code);
end if;
@@ -6971,11 +7020,24 @@ package body Exp_Aggr is
Init_Stat : Node_Id;
Siz : Int;
+ -- The following are used when the size of the aggregate is not
+ -- static and requires a dynamic evaluation.
+ Siz_Decl : Node_Id;
+ Siz_Exp : Node_Id := Empty;
+ Count_Type : Entity_Id;
+
function Aggregate_Size return Int;
-- Compute number of entries in aggregate, including choices
- -- that cover a range, as well as iterated constructs.
+ -- that cover a range or subtype, as well as iterated constructs.
-- Return -1 if the size is not known statically, in which case
- -- we allocate a default size for the aggregate.
+ -- allocate a default size for the aggregate, or build an expression
+ -- to estimate the size dynamically.
+
+ function Build_Siz_Exp (Comp : Node_Id) return Int;
+ -- When the aggregate contains a single Iterated_Component_Association
+ -- or Element_Association with non-static bounds, build an expression
+ -- to be used as the allocated size of the container. This may be an
+ -- overestimate if a filter is present, but is a safe approximation.
procedure Expand_Iterated_Component (Comp : Node_Id);
-- Handle iterated_component_association and iterated_Element
@@ -6994,34 +7056,54 @@ package body Exp_Aggr is
Siz : Int := 0;
procedure Add_Range_Size;
- -- Compute size of component association given by
- -- range or subtype name.
+ -- Compute number of components specified by a component association
+ -- given by a range or subtype name.
+
+ --------------------
+ -- Add_Range_Size --
+ --------------------
procedure Add_Range_Size is
begin
+ -- The bounds of the discrete range are integers or enumeration
+ -- literals
+
if Nkind (Lo) = N_Integer_Literal then
Siz := Siz + UI_To_Int (Intval (Hi))
- - UI_To_Int (Intval (Lo)) + 1;
+ - UI_To_Int (Intval (Lo)) + 1;
+ else
+ Siz := Siz + UI_To_Int (Enumeration_Pos (Hi))
+ - UI_To_Int (Enumeration_Pos (Lo)) + 1;
end if;
end Add_Range_Size;
begin
+ -- Aggregate is either all positional or all named.
+
if Present (Expressions (N)) then
Siz := List_Length (Expressions (N));
end if;
if Present (Component_Associations (N)) then
Comp := First (Component_Associations (N));
-
- -- If the component is an Iterated_Element_Association
- -- it includes an iterator or a loop parameter, possibly
- -- with a filter, so we do not attempt to compute its
- -- size. Room for future optimization ???
-
- if Nkind (Comp) = N_Iterated_Element_Association then
- return -1;
+ -- If there is a single component association it can be
+ -- an iterated component with dynamic bounds or an element
+ -- iterator over an iterable object. If it is an array
+ -- we can use the attribute Length to get its size;
+ -- for a predefined container the function Length plays
+ -- the same role. There is no available mechanism for
+ -- user-defined containers. For now we treat all of these
+ -- as dynamic.
+
+ if List_Length (Component_Associations (N)) = 1
+ and then Nkind (Comp) in N_Iterated_Component_Association |
+ N_Iterated_Element_Association
+ then
+ return Build_Siz_Exp (Comp);
end if;
+ -- Otherwise all associations must specify static sizes.
+
while Present (Comp) loop
Choice := First (Choice_List (Comp));
@@ -7031,26 +7113,14 @@ package body Exp_Aggr is
if Nkind (Choice) = N_Range then
Lo := Low_Bound (Choice);
Hi := High_Bound (Choice);
- if Nkind (Lo) /= N_Integer_Literal
- or else Nkind (Hi) /= N_Integer_Literal
- then
- return -1;
- else
- Add_Range_Size;
- end if;
+ 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));
- if Nkind (Lo) /= N_Integer_Literal
- or else Nkind (Hi) /= N_Integer_Literal
- then
- return -1;
- else
- Add_Range_Size;
- end if;
+ Add_Range_Size;
Rewrite (Choice,
Make_Range (Loc,
@@ -7073,6 +7143,55 @@ package body Exp_Aggr is
return Siz;
end Aggregate_Size;
+ -------------------
+ -- Build_Siz_Exp --
+ -------------------
+
+ function Build_Siz_Exp (Comp : Node_Id) return Int is
+ Lo, Hi : Node_Id;
+ begin
+ if Nkind (Comp) = N_Range then
+ Lo := Low_Bound (Comp);
+ Hi := High_Bound (Comp);
+ Analyze (Lo);
+ Analyze (Hi);
+
+ -- Compute static size when possible.
+
+ if Is_Static_Expression (Lo)
+ and then Is_Static_Expression (Hi)
+ then
+ if Nkind (Lo) = N_Integer_Literal then
+ Siz := UI_To_Int (Intval (Hi)) - UI_To_Int (Intval (Lo)) + 1;
+ else
+ Siz := UI_To_Int (Enumeration_Pos (Hi))
+ - UI_To_Int (Enumeration_Pos (Lo)) + 1;
+ end if;
+ return Siz;
+
+ else
+ Siz_Exp :=
+ Make_Op_Add (Sloc (Comp),
+ Left_Opnd =>
+ Make_Op_Subtract (Sloc (Comp),
+ Left_Opnd => New_Copy_Tree (Hi),
+ Right_Opnd => New_Copy_Tree (Lo)),
+ Right_Opnd =>
+ Make_Integer_Literal (Loc, 1));
+ return -1;
+ end if;
+
+ elsif Nkind (Comp) = N_Iterated_Component_Association then
+ return Build_Siz_Exp (First (Discrete_Choices (Comp)));
+
+ elsif Nkind (Comp) = N_Iterated_Element_Association then
+ return -1; -- ??? build expression for size of the domain
+
+ else
+ return -1;
+ end if;
+ end Build_Siz_Exp;
+
-------------------------------
-- Expand_Iterated_Component --
-------------------------------
@@ -7160,7 +7279,9 @@ package body Exp_Aggr is
-- parameter. Otherwise the key is given by the loop parameter
-- itself.
- if Present (Add_Unnamed_Subp) then
+ if Present (Add_Unnamed_Subp)
+ and then No (Add_Named_Subp)
+ then
Stats := New_List
(Make_Procedure_Call_Statement (Loc,
Name => New_Occurrence_Of (Entity (Add_Unnamed_Subp), Loc),
@@ -7205,38 +7326,80 @@ package body Exp_Aggr is
-- The constructor for bounded containers is a function with
-- a parameter that sets the size of the container. If the
- -- size cannot be determined statically we use a default value.
+ -- size cannot be determined statically we use a default value
+ -- or a dynamic expression.
Siz := Aggregate_Size;
- if Siz < 0 then
- Siz := 10;
- end if;
if Ekind (Entity (Empty_Subp)) = E_Function
and then Present (First_Formal (Entity (Empty_Subp)))
then
Default := Default_Value (First_Formal (Entity (Empty_Subp)));
- -- If aggregate size is not static, use default value of
- -- formal parameter for allocation. We assume that this
+
+ -- If aggregate size is not static, we can use default value
+ -- of formal parameter for allocation. We assume that this
-- (implementation-dependent) value is static, even though
- -- the AI does not require it ???.
+ -- the AI does not require it.
- if Siz < 0 then
- Siz := UI_To_Int (Intval (Default));
- end if;
+ -- Create declaration for size: a constant literal in the simple
+ -- case, an expression if iterated component associations may be
+ -- involved, the default otherwise.
- Init_Stat :=
- Make_Object_Declaration (Loc,
- Defining_Identifier => Temp,
- Object_Definition => New_Occurrence_Of (Typ, Loc),
- Expression => Make_Function_Call (Loc,
- Name => New_Occurrence_Of (Entity (Empty_Subp), Loc),
- Parameter_Associations =>
- New_List (Make_Integer_Literal (Loc, Siz))));
+ Count_Type := Etype (First_Formal (Entity (Empty_Subp)));
+ if Siz = -1 then
+ if No (Siz_Exp) then
+ Siz := UI_To_Int (Intval (Default));
+ Siz_Exp := Make_Integer_Literal (Loc, Siz);
+
+ else
+ Siz_Exp := Make_Type_Conversion (Loc,
+ Subtype_Mark =>
+ New_Occurrence_Of (Count_Type, Loc),
+ Expression => Siz_Exp);
+ end if;
+
+ else
+ Siz_Exp := Make_Integer_Literal (Loc, Siz);
+ end if;
+
+ Siz_Decl := Make_Object_Declaration (Loc,
+ Defining_Identifier => Make_Temporary (Loc, 'S', N),
+ Object_Definition =>
+ New_Occurrence_Of (Count_Type, Loc),
+ Expression => Siz_Exp);
+ Append (Siz_Decl, Aggr_Code);
+
+ if Nkind (Siz_Exp) = N_Integer_Literal then
+ Init_Stat :=
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Temp,
+ Object_Definition => New_Occurrence_Of (Typ, Loc),
+ Expression => Make_Function_Call (Loc,
+ Name => New_Occurrence_Of (Entity (Empty_Subp), Loc),
+ Parameter_Associations =>
+ New_List
+ (New_Occurrence_Of
+ (Defining_Identifier (Siz_Decl), Loc))));
+
+ else
+ Init_Stat :=
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Temp,
+ Object_Definition => New_Occurrence_Of (Typ, Loc),
+ Expression => Make_Function_Call (Loc,
+ Name =>
+ New_Occurrence_Of (Entity (New_Indexed_Subp), Loc),
+ Parameter_Associations =>
+ New_List (
+ Make_Integer_Literal (Loc, 1),
+ New_Occurrence_Of
+ (Defining_Identifier (Siz_Decl), Loc))));
+ end if;
Append (Init_Stat, Aggr_Code);
- -- Use default value when aggregate size is not static.
+ -- Size is dynamic: Create declaration for object, and intitialize
+ -- with a call to the null container, or an assignment to it.
else
Decl :=
@@ -7245,11 +7408,16 @@ package body Exp_Aggr is
Object_Definition => New_Occurrence_Of (Typ, Loc));
Insert_Action (N, Decl);
+
+ -- The Empty entity is either a parameterless function, or
+ -- a constant.
+
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),
@@ -7266,9 +7434,7 @@ package body Exp_Aggr is
-- If the aggregate is positional the aspect must include
-- an Add_Unnamed subprogram.
- if Present (Add_Unnamed_Subp)
- and then No (Component_Associations (N))
- then
+ if Present (Add_Unnamed_Subp) then
if Present (Expressions (N)) then
declare
Insert : constant Entity_Id := Entity (Add_Unnamed_Subp);
@@ -7289,13 +7455,18 @@ package body Exp_Aggr is
end;
end if;
- -- Iterated component associations may also be present.
+ -- Indexed aggregates are handled below. Unnamed aggregates
+ -- such as sets may include iterated component associations.
- Comp := First (Component_Associations (N));
- while Present (Comp) loop
- Expand_Iterated_Component (Comp);
- Next (Comp);
- end loop;
+ if No (New_Indexed_Subp) then
+ Comp := First (Component_Associations (N));
+ while Present (Comp) loop
+ if Nkind (Comp) = N_Iterated_Component_Association then
+ Expand_Iterated_Component (Comp);
+ end if;
+ Next (Comp);
+ end loop;
+ end if;
---------------------
-- Named_Aggregate --
@@ -7346,6 +7517,8 @@ package body Exp_Aggr is
-- subprogram. Note that unlike array aggregates, a container
-- aggregate must be fully positional or fully indexed. In the
-- first case the expansion has already taken place.
+ -- TBA: the keys for an indexed aggregate must provide a dense
+ -- range with no repetitions.
if Present (Assign_Indexed_Subp)
and then Present (Component_Associations (N))
@@ -8361,6 +8534,11 @@ package body Exp_Aggr is
elsif Is_Static_Dispatch_Table_Aggregate (N) then
return;
+
+ -- Case pattern aggregates need to remain as aggregates
+
+ elsif Is_Case_Choice_Pattern (N) then
+ return;
end if;
-- If the pragma Aggregate_Individually_Assign is set, always convert to
@@ -8612,7 +8790,7 @@ package body Exp_Aggr is
-- Aggregates are not supported for nonstandard rep clauses, since they
-- may lead to extra padding fields in CCG.
- if Ekind (Etype (N)) in Record_Kind
+ if Is_Record_Type (Etype (N))
and then Has_Non_Standard_Rep (Etype (N))
then
return False;
@@ -8667,30 +8845,25 @@ package body Exp_Aggr is
begin
return Building_Static_Dispatch_Tables
and then Tagged_Type_Expansion
- and then RTU_Loaded (Ada_Tags)
-- Avoid circularity when rebuilding the compiler
- and then Cunit_Entity (Get_Source_Unit (N)) /= RTU_Entity (Ada_Tags)
- and then (Typ = RTE (RE_Dispatch_Table_Wrapper)
+ and then not Is_RTU (Cunit_Entity (Get_Source_Unit (N)), Ada_Tags)
+ and then (Is_RTE (Typ, RE_Dispatch_Table_Wrapper)
or else
- Typ = RTE (RE_Address_Array)
+ Is_RTE (Typ, RE_Address_Array)
or else
- Typ = RTE (RE_Type_Specific_Data)
+ Is_RTE (Typ, RE_Type_Specific_Data)
or else
- Typ = RTE (RE_Tag_Table)
+ Is_RTE (Typ, RE_Tag_Table)
or else
- (RTE_Available (RE_Object_Specific_Data)
- and then Typ = RTE (RE_Object_Specific_Data))
+ Is_RTE (Typ, RE_Object_Specific_Data)
or else
- (RTE_Available (RE_Interface_Data)
- and then Typ = RTE (RE_Interface_Data))
+ Is_RTE (Typ, RE_Interface_Data)
or else
- (RTE_Available (RE_Interfaces_Array)
- and then Typ = RTE (RE_Interfaces_Array))
+ Is_RTE (Typ, RE_Interfaces_Array)
or else
- (RTE_Available (RE_Interface_Data_Element)
- and then Typ = RTE (RE_Interface_Data_Element)));
+ Is_RTE (Typ, RE_Interface_Data_Element));
end Is_Static_Dispatch_Table_Aggregate;
-----------------------------
@@ -8794,8 +8967,6 @@ package body Exp_Aggr is
(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
@@ -8805,6 +8976,10 @@ package body Exp_Aggr is
-- Return the context in which the aggregate appears, not counting
-- qualified expressions and similar.
+ ------------------
+ -- Aggr_Context --
+ ------------------
+
function Aggr_Context (N : Node_Id) return Node_Id is
Result : Node_Id := Parent (N);
begin
@@ -8822,6 +8997,10 @@ package body Exp_Aggr is
return Result;
end Aggr_Context;
+ --------------------
+ -- Use_Small_Size --
+ --------------------
+
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,
@@ -8852,11 +9031,15 @@ package body Exp_Aggr is
end case;
end Use_Small_Size;
+ -- Local variables
+
+ Typ : constant Entity_Id := Etype (N);
+
-- 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 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
@@ -8968,14 +9151,6 @@ package body Exp_Aggr is
declare
Csiz : constant Nat := UI_To_Int (Component_Size (Typ));
- Lo : Node_Id;
- Hi : Node_Id;
- -- Bounds of index type
-
- Lob : Uint;
- Hib : Uint;
- -- Values of bounds if compile time known
-
function Get_Component_Val (N : Node_Id) return Uint;
-- Given a expression value N of the component type Ctyp, returns a
-- value of Csiz (component size) bits representing this value. If
@@ -9017,147 +9192,154 @@ package body Exp_Aggr is
return Val mod Uint_2 ** Csiz;
end Get_Component_Val;
+ Bounds : constant Range_Nodes := Get_Index_Bounds (First_Index (Typ));
+
-- Here we know we have a one dimensional bit packed array
begin
- Get_Index_Bounds (First_Index (Typ), Lo, Hi);
-
-- Cannot do anything if bounds are dynamic
- if not Compile_Time_Known_Value (Lo)
- or else
- not Compile_Time_Known_Value (Hi)
+ if not (Compile_Time_Known_Value (Bounds.First)
+ and then
+ Compile_Time_Known_Value (Bounds.Last))
then
return False;
end if;
- -- Or are silly out of range of int bounds
-
- Lob := Expr_Value (Lo);
- Hib := Expr_Value (Hi);
-
- if not UI_Is_In_Int_Range (Lob)
- or else
- not UI_Is_In_Int_Range (Hib)
- then
- return False;
- end if;
+ declare
+ Bounds_Vals : Range_Values;
+ -- Compile-time known values of bounds
+ begin
+ -- Or are silly out of range of int bounds
- -- At this stage we have a suitable aggregate for handling at compile
- -- time. The only remaining checks are that the values of expressions
- -- in the aggregate are compile-time known (checks are performed by
- -- Get_Component_Val), and that any subtypes or ranges are statically
- -- known.
+ Bounds_Vals.First := Expr_Value (Bounds.First);
+ Bounds_Vals.Last := Expr_Value (Bounds.Last);
- -- If the aggregate is not fully positional at this stage, then
- -- convert it to positional form. Either this will fail, in which
- -- case we can do nothing, or it will succeed, in which case we have
- -- succeeded in handling the aggregate and transforming it into a
- -- modular value, or it will stay an aggregate, in which case we
- -- have failed to create a packed value for it.
+ if not UI_Is_In_Int_Range (Bounds_Vals.First)
+ or else
+ not UI_Is_In_Int_Range (Bounds_Vals.Last)
+ then
+ return False;
+ end if;
- if Present (Component_Associations (N)) then
- Convert_To_Positional (N, Handle_Bit_Packed => True);
- return Nkind (N) /= N_Aggregate;
- end if;
+ -- At this stage we have a suitable aggregate for handling at
+ -- compile time. The only remaining checks are that the values of
+ -- expressions in the aggregate are compile-time known (checks are
+ -- performed by Get_Component_Val), and that any subtypes or
+ -- ranges are statically known.
- -- Otherwise we are all positional, so convert to proper value
+ -- If the aggregate is not fully positional at this stage, then
+ -- convert it to positional form. Either this will fail, in which
+ -- case we can do nothing, or it will succeed, in which case we
+ -- have succeeded in handling the aggregate and transforming it
+ -- into a modular value, or it will stay an aggregate, in which
+ -- case we have failed to create a packed value for it.
- declare
- Lov : constant Int := UI_To_Int (Lob);
- Hiv : constant Int := UI_To_Int (Hib);
+ if Present (Component_Associations (N)) then
+ Convert_To_Positional (N, Handle_Bit_Packed => True);
+ return Nkind (N) /= N_Aggregate;
+ end if;
- Len : constant Nat := Int'Max (0, Hiv - Lov + 1);
- -- The length of the array (number of elements)
+ -- Otherwise we are all positional, so convert to proper value
- Aggregate_Val : Uint;
- -- Value of aggregate. The value is set in the low order bits of
- -- this value. For the little-endian case, the values are stored
- -- from low-order to high-order and for the big-endian case the
- -- values are stored from high-order to low-order. Note that gigi
- -- will take care of the conversions to left justify the value in
- -- the big endian case (because of left justified modular type
- -- processing), so we do not have to worry about that here.
+ declare
+ Len : constant Nat :=
+ Int'Max (0, UI_To_Int (Bounds_Vals.Last) -
+ UI_To_Int (Bounds_Vals.First) + 1);
+ -- The length of the array (number of elements)
- Lit : Node_Id;
- -- Integer literal for resulting constructed value
+ Aggregate_Val : Uint;
+ -- Value of aggregate. The value is set in the low order bits
+ -- of this value. For the little-endian case, the values are
+ -- stored from low-order to high-order and for the big-endian
+ -- case the values are stored from high order to low order.
+ -- Note that gigi will take care of the conversions to left
+ -- justify the value in the big endian case (because of left
+ -- justified modular type processing), so we do not have to
+ -- worry about that here.
- Shift : Nat;
- -- Shift count from low order for next value
+ Lit : Node_Id;
+ -- Integer literal for resulting constructed value
- Incr : Int;
- -- Shift increment for loop
+ Shift : Nat;
+ -- Shift count from low order for next value
- Expr : Node_Id;
- -- Next expression from positional parameters of aggregate
+ Incr : Int;
+ -- Shift increment for loop
- Left_Justified : Boolean;
- -- Set True if we are filling the high order bits of the target
- -- value (i.e. the value is left justified).
+ Expr : Node_Id;
+ -- Next expression from positional parameters of aggregate
- begin
- -- For little endian, we fill up the low order bits of the target
- -- value. For big endian we fill up the high order bits of the
- -- target value (which is a left justified modular value).
+ Left_Justified : Boolean;
+ -- Set True if we are filling the high order bits of the target
+ -- value (i.e. the value is left justified).
- Left_Justified := Bytes_Big_Endian;
+ begin
+ -- For little endian, we fill up the low order bits of the
+ -- target value. For big endian we fill up the high order bits
+ -- of the target value (which is a left justified modular
+ -- value).
- -- Switch justification if using -gnatd8
+ Left_Justified := Bytes_Big_Endian;
- if Debug_Flag_8 then
- Left_Justified := not Left_Justified;
- end if;
+ -- Switch justification if using -gnatd8
- -- Switch justfification if reverse storage order
+ if Debug_Flag_8 then
+ Left_Justified := not Left_Justified;
+ end if;
- if Reverse_Storage_Order (Base_Type (Typ)) then
- Left_Justified := not Left_Justified;
- end if;
+ -- Switch justfification if reverse storage order
- if Left_Justified then
- Shift := Csiz * (Len - 1);
- Incr := -Csiz;
- else
- Shift := 0;
- Incr := +Csiz;
- end if;
+ if Reverse_Storage_Order (Base_Type (Typ)) then
+ Left_Justified := not Left_Justified;
+ end if;
- -- Loop to set the values
+ if Left_Justified then
+ Shift := Csiz * (Len - 1);
+ Incr := -Csiz;
+ else
+ Shift := 0;
+ Incr := +Csiz;
+ end if;
- if Len = 0 then
- Aggregate_Val := Uint_0;
- else
- Expr := First (Expressions (N));
- Aggregate_Val := Get_Component_Val (Expr) * Uint_2 ** Shift;
+ -- Loop to set the values
- for J in 2 .. Len loop
- Shift := Shift + Incr;
- Next (Expr);
- Aggregate_Val :=
- Aggregate_Val + Get_Component_Val (Expr) * Uint_2 ** Shift;
- end loop;
- end if;
+ if Len = 0 then
+ Aggregate_Val := Uint_0;
+ else
+ Expr := First (Expressions (N));
+ Aggregate_Val := Get_Component_Val (Expr) * Uint_2 ** Shift;
+
+ for J in 2 .. Len loop
+ Shift := Shift + Incr;
+ Next (Expr);
+ Aggregate_Val :=
+ Aggregate_Val +
+ Get_Component_Val (Expr) * Uint_2 ** Shift;
+ end loop;
+ end if;
- -- Now we can rewrite with the proper value
+ -- Now we can rewrite with the proper value
- Lit := Make_Integer_Literal (Loc, Intval => Aggregate_Val);
- Set_Print_In_Hex (Lit);
+ Lit := Make_Integer_Literal (Loc, Intval => Aggregate_Val);
+ Set_Print_In_Hex (Lit);
- -- Construct the expression using this literal. Note that it is
- -- important to qualify the literal with its proper modular type
- -- since universal integer does not have the required range and
- -- also this is a left justified modular type, which is important
- -- in the big-endian case.
+ -- Construct the expression using this literal. Note that it
+ -- is important to qualify the literal with its proper modular
+ -- type since universal integer does not have the required
+ -- range and also this is a left justified modular type,
+ -- which is important in the big-endian case.
- Rewrite (N,
- Unchecked_Convert_To (Typ,
- Make_Qualified_Expression (Loc,
- Subtype_Mark =>
- New_Occurrence_Of (Packed_Array_Impl_Type (Typ), Loc),
- Expression => Lit)));
+ Rewrite (N,
+ Unchecked_Convert_To (Typ,
+ Make_Qualified_Expression (Loc,
+ Subtype_Mark =>
+ New_Occurrence_Of (Packed_Array_Impl_Type (Typ), Loc),
+ Expression => Lit)));
- Analyze_And_Resolve (N, Typ);
- return True;
+ Analyze_And_Resolve (N, Typ);
+ return True;
+ end;
end;
end;
@@ -9232,8 +9414,6 @@ package body Exp_Aggr is
(Obj_Type : Entity_Id;
Typ : Entity_Id) return Boolean
is
- L1, L2, H1, H2 : Node_Id;
-
begin
-- No sliding if the type of the object is not established yet, if it is
-- an unconstrained type whose actual subtype comes from the aggregate,
@@ -9251,20 +9431,25 @@ package body Exp_Aggr is
else
-- Sliding can only occur along the first dimension
- Get_Index_Bounds (First_Index (Typ), L1, H1);
- Get_Index_Bounds (First_Index (Obj_Type), L2, H2);
+ declare
+ Bounds1 : constant Range_Nodes :=
+ Get_Index_Bounds (First_Index (Typ));
+ Bounds2 : constant Range_Nodes :=
+ Get_Index_Bounds (First_Index (Obj_Type));
- if not Is_OK_Static_Expression (L1) or else
- not Is_OK_Static_Expression (L2) or else
- not Is_OK_Static_Expression (H1) or else
- not Is_OK_Static_Expression (H2)
- then
- return False;
- else
- return Expr_Value (L1) /= Expr_Value (L2)
- or else
- Expr_Value (H1) /= Expr_Value (H2);
- end if;
+ begin
+ if not Is_OK_Static_Expression (Bounds1.First) or else
+ not Is_OK_Static_Expression (Bounds2.First) or else
+ not Is_OK_Static_Expression (Bounds1.Last) or else
+ not Is_OK_Static_Expression (Bounds2.Last)
+ then
+ return False;
+ else
+ return Expr_Value (Bounds1.First) /= Expr_Value (Bounds2.First)
+ or else
+ Expr_Value (Bounds1.Last) /= Expr_Value (Bounds2.Last);
+ end if;
+ end;
end if;
end Must_Slide;
@@ -9317,7 +9502,7 @@ package body Exp_Aggr is
-- type Res_Typ is access all Comp_Typ;
Res_Typ := Make_Temporary (Loc, 'A');
- Set_Ekind (Res_Typ, E_General_Access_Type);
+ Mutate_Ekind (Res_Typ, E_General_Access_Type);
Set_Directly_Designated_Type (Res_Typ, Comp_Typ);
Add_Item
@@ -9337,7 +9522,7 @@ package body Exp_Aggr is
-- its lifetime is bounded by the current array or record component.
Res_Id := Make_Temporary (Loc, 'R');
- Set_Ekind (Res_Id, E_Constant);
+ Mutate_Ekind (Res_Id, E_Constant);
Set_Etype (Res_Id, Res_Typ);
-- Mark the transient object as successfully processed to avoid double
diff --git a/gcc/ada/exp_aggr.ads b/gcc/ada/exp_aggr.ads
index f9ad193..2e0fde1 100644
--- a/gcc/ada/exp_aggr.ads
+++ b/gcc/ada/exp_aggr.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute 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 dc1d138..bae98a6 100644
--- a/gcc/ada/exp_atag.adb
+++ b/gcc/ada/exp_atag.adb
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2006-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2006-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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,22 +23,25 @@
-- --
------------------------------------------------------------------------------
-with Atree; use Atree;
-with Einfo; use Einfo;
-with Elists; use Elists;
-with Exp_Disp; use Exp_Disp;
-with Namet; use Namet;
-with Nlists; use Nlists;
-with Nmake; use Nmake;
-with Opt; use Opt;
-with Rtsfind; use Rtsfind;
-with Sinfo; use Sinfo;
-with Sem_Aux; use Sem_Aux;
-with Sem_Disp; use Sem_Disp;
-with Sem_Util; use Sem_Util;
-with Stand; use Stand;
-with Snames; use Snames;
-with Tbuild; use Tbuild;
+with Atree; use Atree;
+with Einfo; use Einfo;
+with Einfo.Entities; use Einfo.Entities;
+with Einfo.Utils; use Einfo.Utils;
+with Elists; use Elists;
+with Exp_Disp; use Exp_Disp;
+with Namet; use Namet;
+with Nlists; use Nlists;
+with Nmake; use Nmake;
+with Opt; use Opt;
+with Rtsfind; use Rtsfind;
+with Sinfo; use Sinfo;
+with Sinfo.Nodes; use Sinfo.Nodes;
+with Sem_Aux; use Sem_Aux;
+with Sem_Disp; use Sem_Disp;
+with Sem_Util; use Sem_Util;
+with Stand; use Stand;
+with Snames; use Snames;
+with Tbuild; use Tbuild;
package body Exp_Atag is
diff --git a/gcc/ada/exp_atag.ads b/gcc/ada/exp_atag.ads
index 05e2f8e..e756080 100644
--- a/gcc/ada/exp_atag.ads
+++ b/gcc/ada/exp_atag.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2006-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2006-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute 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_attr.adb b/gcc/ada/exp_attr.adb
index 7f63a2d..f074521 100644
--- a/gcc/ada/exp_attr.adb
+++ b/gcc/ada/exp_attr.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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,52 +23,56 @@
-- --
------------------------------------------------------------------------------
-with Aspects; use Aspects;
-with Atree; use Atree;
-with Checks; use Checks;
-with Einfo; use Einfo;
-with Elists; use Elists;
-with Exp_Atag; use Exp_Atag;
-with Exp_Ch3; use Exp_Ch3;
-with Exp_Ch6; use Exp_Ch6;
-with Exp_Ch9; use Exp_Ch9;
-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 Aspects; use Aspects;
+with Atree; use Atree;
+with Checks; use Checks;
+with Einfo; use Einfo;
+with Einfo.Entities; use Einfo.Entities;
+with Einfo.Utils; use Einfo.Utils;
+with Elists; use Elists;
+with Exp_Atag; use Exp_Atag;
+with Exp_Ch3; use Exp_Ch3;
+with Exp_Ch6; use Exp_Ch6;
+with Exp_Ch9; use Exp_Ch9;
+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;
-with Freeze; use Freeze;
-with Gnatvsn; use Gnatvsn;
-with Itypes; use Itypes;
-with Lib; use Lib;
-with Namet; use Namet;
-with Nmake; use Nmake;
-with Nlists; use Nlists;
-with Opt; use Opt;
-with Restrict; use Restrict;
-with Rident; use Rident;
-with Rtsfind; use Rtsfind;
-with Sem; use Sem;
-with Sem_Aux; use Sem_Aux;
-with Sem_Ch6; use Sem_Ch6;
-with Sem_Ch7; use Sem_Ch7;
-with Sem_Ch8; use Sem_Ch8;
-with Sem_Eval; use Sem_Eval;
-with Sem_Res; use Sem_Res;
-with Sem_Util; use Sem_Util;
-with Sinfo; use Sinfo;
-with Snames; use Snames;
-with Stand; use Stand;
-with Stringt; use Stringt;
-with Tbuild; use Tbuild;
-with Ttypes; use Ttypes;
-with Uintp; use Uintp;
-with Uname; use Uname;
-with Urealp; use Urealp;
-with Validsw; use Validsw;
+with Exp_Tss; use Exp_Tss;
+with Exp_Util; use Exp_Util;
+with Expander; use Expander;
+with Freeze; use Freeze;
+with Gnatvsn; use Gnatvsn;
+with Itypes; use Itypes;
+with Lib; use Lib;
+with Namet; use Namet;
+with Nmake; use Nmake;
+with Nlists; use Nlists;
+with Opt; use Opt;
+with Restrict; use Restrict;
+with Rident; use Rident;
+with Rtsfind; use Rtsfind;
+with Sem; use Sem;
+with Sem_Aux; use Sem_Aux;
+with Sem_Ch6; use Sem_Ch6;
+with Sem_Ch7; use Sem_Ch7;
+with Sem_Ch8; use Sem_Ch8;
+with Sem_Eval; use Sem_Eval;
+with Sem_Res; use Sem_Res;
+with Sem_Util; use Sem_Util;
+with Sinfo; use Sinfo;
+with Sinfo.Nodes; use Sinfo.Nodes;
+with Sinfo.Utils; use Sinfo.Utils;
+with Snames; use Snames;
+with Stand; use Stand;
+with Stringt; use Stringt;
+with Tbuild; use Tbuild;
+with Ttypes; use Ttypes;
+with Uintp; use Uintp;
+with Uname; use Uname;
+with Urealp; use Urealp;
+with Validsw; use Validsw;
package body Exp_Attr is
@@ -113,8 +117,7 @@ package body Exp_Attr is
procedure Compile_Stream_Body_In_Scope
(N : Node_Id;
Decl : Node_Id;
- Arr : Entity_Id;
- Check : Boolean);
+ Arr : Entity_Id);
-- The body for a stream subprogram may be generated outside of the scope
-- of the type. If the type is fully private, it may depend on the full
-- view of other types (e.g. indexes) that are currently private as well.
@@ -385,7 +388,7 @@ package body Exp_Attr is
-- Stmts
-- end Func_Id;
- Set_Ekind (Func_Id, E_Function);
+ Mutate_Ekind (Func_Id, E_Function);
Set_Is_Internal (Func_Id);
Set_Is_Pure (Func_Id);
@@ -733,7 +736,7 @@ package body Exp_Attr is
-- Start of processing for Build_Record_VS_Func
begin
- Typ := Rec_Typ;
+ Typ := Validated_View (Rec_Typ);
-- Use the root type when dealing with a class-wide type
@@ -828,7 +831,7 @@ package body Exp_Attr is
-- Stmts
-- end Func_Id;
- Set_Ekind (Func_Id, E_Function);
+ Mutate_Ekind (Func_Id, E_Function);
Set_Is_Internal (Func_Id);
Set_Is_Pure (Func_Id);
@@ -863,8 +866,7 @@ package body Exp_Attr is
procedure Compile_Stream_Body_In_Scope
(N : Node_Id;
Decl : Node_Id;
- Arr : Entity_Id;
- Check : Boolean)
+ Arr : Entity_Id)
is
C_Type : constant Entity_Id := Base_Type (Component_Type (Arr));
Curr : constant Entity_Id := Current_Scope;
@@ -918,11 +920,7 @@ package body Exp_Attr is
Install := False;
end if;
- if Check then
- Insert_Action (N, Decl);
- else
- Insert_Action (N, Decl, Suppress => All_Checks);
- end if;
+ Insert_Action (N, Decl);
if Install then
@@ -1847,14 +1845,13 @@ package body Exp_Attr is
----------------------
function Get_Integer_Type (Typ : Entity_Id) return Entity_Id is
- Siz : constant Uint := Esize (Base_Type (Typ));
+ Siz : constant Uint := Esize (Base_Type (Typ));
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.
+ -- accept them for Enum_Rep and Pos, so we reason on the Esize.
- return Small_Integer_Type_For (Siz, Uns => True);
+ return Small_Integer_Type_For (Siz, Uns => Is_Unsigned_Type (Typ));
end Get_Integer_Type;
---------------------------------
@@ -2150,7 +2147,7 @@ package body Exp_Attr is
-- the node with the type imposed by the context.
if Nkind (Parent (N)) = N_Unchecked_Type_Conversion
- and then Etype (Parent (N)) = RTE (RE_Prim_Ptr)
+ and then Is_RTE (Etype (Parent (N)), RE_Prim_Ptr)
then
Set_Etype (N, RTE (RE_Prim_Ptr));
@@ -2363,6 +2360,7 @@ package body Exp_Attr is
= E_Anonymous_Access_Type
and then Present (Extra_Accessibility
(Entity (Prefix (Enc_Object))))
+ and then not No_Dynamic_Accessibility_Checks_Enabled (Enc_Object)
then
Apply_Accessibility_Check (Prefix (Enc_Object), Typ, N);
@@ -2801,10 +2799,9 @@ package body Exp_Attr is
Name =>
New_Occurrence_Of (RTE (RE_Callable), Loc),
Parameter_Associations => New_List (
- Make_Unchecked_Type_Conversion (Loc,
- Subtype_Mark =>
- New_Occurrence_Of (RTE (RO_ST_Task_Id), Loc),
- Expression => Build_Disp_Get_Task_Id_Call (Pref)))));
+ Unchecked_Convert_To
+ (RTE (RO_ST_Task_Id),
+ Build_Disp_Get_Task_Id_Call (Pref)))));
else
Rewrite (N, Build_Call_With_Task (Pref, RTE (RE_Callable)));
@@ -3631,8 +3628,8 @@ package body Exp_Attr is
-- min (scale of Typ'Small, 0)
-- For other ordinary fixed-point types
- -- xx = Real
- -- ftyp = Universal_Real
+ -- xx = Fixed
+ -- ftyp = Long_Float
-- pm = none
-- Note that we know that the type is a nonstatic subtype, or Fore would
@@ -3691,8 +3688,8 @@ package body Exp_Attr is
Fid := RE_Fore_Fixed128;
Ftyp := RTE (RE_Integer_128);
else
- Fid := RE_Fore_Real;
- Ftyp := Universal_Real;
+ Fid := RE_Fore_Fixed;
+ Ftyp := Standard_Long_Float;
end if;
end;
end if;
@@ -3721,7 +3718,7 @@ package body Exp_Attr is
-- For ordinary fixed-point types, append Num, Den and Scale
-- parameters and also set to do literal conversion
- elsif Fid /= RE_Fore_Real then
+ elsif Fid /= RE_Fore_Fixed then
Set_Conversion_OK (First (Arg_List));
Set_Conversion_OK (Next (First (Arg_List)));
@@ -4124,7 +4121,7 @@ package body Exp_Attr is
elsif Is_Array_Type (U_Type) then
Build_Array_Input_Function (Loc, U_Type, Decl, Fname);
- Compile_Stream_Body_In_Scope (N, Decl, U_Type, Check => False);
+ Compile_Stream_Body_In_Scope (N, Decl, U_Type);
-- Dispatching case with class-wide type
@@ -4237,12 +4234,13 @@ package body Exp_Attr is
-- type if the type lacks default discriminant values.
if Is_Unchecked_Union (Base_Type (U_Type))
- and then No (Discriminant_Constraint (U_Type))
+ and then
+ No (Discriminant_Default_Value (First_Discriminant (U_Type)))
then
- Insert_Action (N,
+ Rewrite (N,
Make_Raise_Program_Error (Loc,
Reason => PE_Unchecked_Union_Restriction));
-
+ Set_Etype (N, B_Type);
return;
end if;
@@ -4598,13 +4596,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
- -- wrapped inside a type conversion.
+ Typ : constant Entity_Id := Etype (N);
begin
-- If the prefix is X'Class, we transform it into a direct reference
@@ -4618,40 +4610,22 @@ package body Exp_Attr is
return;
end if;
- Apply_Universal_Integer_Attribute_Checks (N);
-
- -- The universal integer check may sometimes add a type conversion,
- -- retrieve the original attribute reference from the expression.
-
- Attr := N;
-
- if Nkind (Attr) = N_Type_Conversion then
- Attr := Expression (Attr);
- Conversion_Added := True;
- end if;
-
- pragma Assert (Nkind (Attr) = N_Attribute_Reference);
-
-- Heap-allocated controlled objects contain two extra pointers which
-- are not part of the actual type. Transform the attribute reference
-- into a runtime expression to add the size of the hidden header.
- if Needs_Finalization (Ptyp)
- and then not Header_Size_Added (Attr)
- then
- Set_Header_Size_Added (Attr);
-
- Atyp := Etype (Attr);
+ if Needs_Finalization (Ptyp) and then not Header_Size_Added (N) then
+ Set_Header_Size_Added (N);
-- Generate:
-- P'Max_Size_In_Storage_Elements +
- -- Atyp (Header_Size_With_Padding (Ptyp'Alignment))
+ -- Typ (Header_Size_With_Padding (Ptyp'Alignment))
- Rewrite (Attr,
+ Rewrite (N,
Make_Op_Add (Loc,
- Left_Opnd => Relocate_Node (Attr),
+ Left_Opnd => Relocate_Node (N),
Right_Opnd =>
- Convert_To (Atyp,
+ Convert_To (Typ,
Make_Function_Call (Loc,
Name =>
New_Occurrence_Of
@@ -4663,16 +4637,13 @@ 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
- Convert_To_And_Rewrite (Typ, Attr);
- end if;
-
+ Analyze_And_Resolve (N, Typ);
return;
end if;
+
+ -- In the other cases apply the required checks
+
+ Apply_Universal_Integer_Attribute_Checks (N);
end;
--------------------
@@ -4860,7 +4831,7 @@ package body Exp_Attr is
-- Set the entity kind now in order to mark the temporary as a
-- handler of attribute 'Old's prefix.
- Set_Ekind (Temp, E_Constant);
+ Mutate_Ekind (Temp, E_Constant);
Set_Stores_Attribute_Old_Prefix (Temp);
-- Push the scope of the related subprogram where _Postcondition
@@ -5260,7 +5231,7 @@ package body Exp_Attr is
elsif Is_Array_Type (U_Type) then
Build_Array_Output_Procedure (Loc, U_Type, Decl, Pname);
- Compile_Stream_Body_In_Scope (N, Decl, U_Type, Check => False);
+ Compile_Stream_Body_In_Scope (N, Decl, U_Type);
-- Class-wide case, first output external tag, then dispatch
-- to the appropriate primitive Output function (RM 13.13.2(31)).
@@ -5359,12 +5330,13 @@ package body Exp_Attr is
-- values.
if Is_Unchecked_Union (Base_Type (U_Type))
- and then No (Discriminant_Constraint (U_Type))
+ and then
+ No (Discriminant_Default_Value (First_Discriminant (U_Type)))
then
- Insert_Action (N,
+ Rewrite (N,
Make_Raise_Program_Error (Loc,
Reason => PE_Unchecked_Union_Restriction));
-
+ Set_Etype (N, Standard_Void_Type);
return;
end if;
@@ -6111,7 +6083,7 @@ package body Exp_Attr is
elsif Is_Array_Type (U_Type) then
Build_Array_Read_Procedure (N, U_Type, Decl, Pname);
- Compile_Stream_Body_In_Scope (N, Decl, U_Type, Check => False);
+ Compile_Stream_Body_In_Scope (N, Decl, U_Type);
-- Tagged type case, use the primitive Read function. Note that
-- this will dispatch in the class-wide case which is what we want
@@ -6142,10 +6114,7 @@ package body Exp_Attr is
return;
end if;
- if Has_Discriminants (U_Type)
- and then Present
- (Discriminant_Default_Value (First_Discriminant (U_Type)))
- then
+ if Has_Defaulted_Discriminants (U_Type) then
Build_Mutable_Record_Read_Procedure
(Loc, Full_Base (U_Type), Decl, Pname);
else
@@ -6153,11 +6122,7 @@ package body Exp_Attr is
(Loc, Full_Base (U_Type), Decl, Pname);
end if;
- -- Suppress checks, uninitialized or otherwise invalid
- -- data does not cause constraint errors to be raised for
- -- a complete record read.
-
- Insert_Action (N, Decl, All_Checks);
+ Insert_Action (N, Decl);
end if;
end if;
@@ -6780,10 +6745,9 @@ package body Exp_Attr is
Name =>
New_Occurrence_Of (RTE (RE_Terminated), Loc),
Parameter_Associations => New_List (
- Make_Unchecked_Type_Conversion (Loc,
- Subtype_Mark =>
- New_Occurrence_Of (RTE (RO_ST_Task_Id), Loc),
- Expression => Build_Disp_Get_Task_Id_Call (Pref)))));
+ Unchecked_Convert_To
+ (RTE (RO_ST_Task_Id),
+ Build_Disp_Get_Task_Id_Call (Pref)))));
elsif Restricted_Profile then
Rewrite (N,
@@ -7116,9 +7080,9 @@ package body Exp_Attr is
-- Start of processing for Float_Valid
begin
- -- The C and AAMP back-ends handle Valid for fpt types
+ -- The C back end handles Valid for floating-point types
- if Modify_Tree_For_C or else Float_Rep (PBtyp) = AAMP then
+ if Modify_Tree_For_C then
Analyze_And_Resolve (Pref, Ptyp);
Set_Etype (N, Standard_Boolean);
Set_Analyzed (N);
@@ -7329,7 +7293,7 @@ package body Exp_Attr is
-- of the size of the type, not the range of the values). We write
-- this as two tests, rather than a range check, so that static
-- evaluation will easily remove either or both of the checks if
- -- they can be -statically determined to be true (this happens
+ -- they can be statically determined to be true (this happens
-- when the type of X is static and the range extends to the full
-- range of stored values).
@@ -7350,12 +7314,40 @@ package body Exp_Attr is
else
declare
- Uns : constant Boolean
- := Is_Unsigned_Type (Ptyp)
- or else (Is_Private_Type (Ptyp)
- and then Is_Unsigned_Type (Btyp));
+ Uns : constant Boolean :=
+ Is_Unsigned_Type (Ptyp)
+ or else (Is_Private_Type (Ptyp)
+ and then Is_Unsigned_Type (Btyp));
+ Size : Uint;
+ P : Node_Id := Pref;
+
begin
- PBtyp := Integer_Type_For (Esize (Ptyp), Uns);
+ -- If the prefix is an object, use the Esize from this object
+ -- to handle in a more user friendly way the case of objects
+ -- or components with a large Size aspect: if a Size aspect is
+ -- specified, we want to read a scalar value as large as the
+ -- Size, unless the Size is larger than
+ -- System_Max_Integer_Size.
+
+ if Nkind (P) = N_Selected_Component then
+ P := Selector_Name (P);
+ end if;
+
+ if Nkind (P) in N_Has_Entity
+ and then Present (Entity (P))
+ and then Is_Object (Entity (P))
+ and then Esize (Entity (P)) /= Uint_0
+ then
+ if Esize (Entity (P)) <= System_Max_Integer_Size then
+ Size := Esize (Entity (P));
+ else
+ Size := UI_From_Int (System_Max_Integer_Size);
+ end if;
+ else
+ Size := Esize (Ptyp);
+ end if;
+
+ PBtyp := Small_Integer_Type_For (Size, Uns);
Rewrite (N, Make_Range_Test);
end;
end if;
@@ -7380,6 +7372,13 @@ package body Exp_Attr is
Validity_Checks_On := Save_Validity_Checks_On;
end Valid;
+ -----------------
+ -- Valid_Value --
+ -----------------
+
+ when Attribute_Valid_Value =>
+ Exp_Imgv.Expand_Valid_Value_Attribute (N);
+
-------------------
-- Valid_Scalars --
-------------------
@@ -7563,14 +7562,9 @@ package body Exp_Attr is
-- typ'Value
-- (Wide_Wide_String_To_String (X, Wide_Character_Encoding_Method))
- -- Wide_Wide_String_To_String is a runtime function that converts its
- -- wide string argument to String, converting any non-translatable
- -- characters into appropriate escape sequences. This preserves the
- -- required semantics of Wide_Wide_Value in all cases, and results in a
- -- very simple implementation approach.
-
- -- It's not quite right where typ = Wide_Wide_Character, because the
- -- encoding method may not cover the whole character type ???
+ -- See Wide_Value for more information. This is not quite right where
+ -- typ = Wide_Wide_Character, because the encoding method may not cover
+ -- the whole character type.
when Attribute_Wide_Wide_Value =>
Rewrite (N,
@@ -7712,7 +7706,7 @@ package body Exp_Attr is
elsif Is_Array_Type (U_Type) then
Build_Array_Write_Procedure (N, U_Type, Decl, Pname);
- Compile_Stream_Body_In_Scope (N, Decl, U_Type, Check => False);
+ Compile_Stream_Body_In_Scope (N, Decl, U_Type);
-- Tagged type case, use the primitive Write function. Note that
-- this will dispatch in the class-wide case which is what we want
@@ -7750,10 +7744,7 @@ package body Exp_Attr is
end if;
end if;
- if Has_Discriminants (U_Type)
- and then Present
- (Discriminant_Default_Value (First_Discriminant (U_Type)))
- then
+ if Has_Defaulted_Discriminants (U_Type) then
Build_Mutable_Record_Write_Procedure
(Loc, Full_Base (U_Type), Decl, Pname);
else
diff --git a/gcc/ada/exp_attr.ads b/gcc/ada/exp_attr.ads
index 6181977..6bbfeff 100644
--- a/gcc/ada/exp_attr.ads
+++ b/gcc/ada/exp_attr.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute 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 122a40f..116dc64 100644
--- a/gcc/ada/exp_cg.adb
+++ b/gcc/ada/exp_cg.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2010-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2010-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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,25 +23,29 @@
-- --
------------------------------------------------------------------------------
-with Atree; use Atree;
-with Einfo; use Einfo;
-with Elists; use Elists;
-with Exp_Dbug; use Exp_Dbug;
-with Exp_Tss; use Exp_Tss;
-with Lib; use Lib;
-with Namet; use Namet;
-with Opt; use Opt;
-with Output; use Output;
-with Sem_Aux; use Sem_Aux;
-with Sem_Disp; use Sem_Disp;
-with Sem_Type; use Sem_Type;
-with Sem_Util; use Sem_Util;
-with Sinfo; use Sinfo;
-with Sinput; use Sinput;
-with Snames; use Snames;
-with System; use System;
+with Atree; use Atree;
+with Einfo; use Einfo;
+with Einfo.Entities; use Einfo.Entities;
+with Einfo.Utils; use Einfo.Utils;
+with Elists; use Elists;
+with Exp_Dbug; use Exp_Dbug;
+with Exp_Tss; use Exp_Tss;
+with Lib; use Lib;
+with Namet; use Namet;
+with Opt; use Opt;
+with Output; use Output;
+with Sem_Aux; use Sem_Aux;
+with Sem_Disp; use Sem_Disp;
+with Sem_Type; use Sem_Type;
+with Sem_Util; use Sem_Util;
+with Sinfo; use Sinfo;
+with Sinfo.Nodes; use Sinfo.Nodes;
+with Sinfo.Utils; use Sinfo.Utils;
+with Sinput; use Sinput;
+with Snames; use Snames;
+with System; use System;
with Table;
-with Uintp; use Uintp;
+with Uintp; use Uintp;
package body Exp_CG is
@@ -376,7 +380,14 @@ package body Exp_CG is
and then Nkind (Parent (Par)) /= N_Compilation_Unit
loop
Par := Parent (Par);
- pragma Assert (Present (Par));
+
+ -- Par can legitimately be empty inside a class-wide
+ -- precondition; the "real" call will be found inside the
+ -- generated pragma.
+
+ if No (Par) then
+ return;
+ end if;
end loop;
Set_Parent (Copy, Par);
@@ -429,7 +440,7 @@ package body Exp_CG is
procedure Write_Call_Info (Call : Node_Id) is
Ctrl_Arg : constant Node_Id := Controlling_Argument (Call);
Ctrl_Typ : constant Entity_Id := Base_Type (Etype (Ctrl_Arg));
- Prim : constant Entity_Id := Entity (Sinfo.Name (Call));
+ Prim : constant Entity_Id := Entity (Sinfo.Nodes.Name (Call));
P : constant Node_Id := Parent (Call);
begin
@@ -559,13 +570,13 @@ package body Exp_CG is
Write_Char ('"');
Write_Name (Chars (Parent_Typ));
- -- Note: Einfo prefix not needed if this routine is moved to
+ -- Note: Einfo.Entities prefix not needed if this routine is moved to
-- exp_disp???
- if Present (Einfo.Interfaces (Typ))
- and then not Is_Empty_Elmt_List (Einfo.Interfaces (Typ))
+ if Present (Einfo.Entities.Interfaces (Typ))
+ and then not Is_Empty_Elmt_List (Einfo.Entities.Interfaces (Typ))
then
- Elmt := First_Elmt (Einfo.Interfaces (Typ));
+ Elmt := First_Elmt (Einfo.Entities.Interfaces (Typ));
while Present (Elmt) loop
Write_Str (", ");
Write_Name (Chars (Node (Elmt)));
diff --git a/gcc/ada/exp_cg.ads b/gcc/ada/exp_cg.ads
index f32e73c..a26bb5e 100644
--- a/gcc/ada/exp_cg.ads
+++ b/gcc/ada/exp_cg.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2010-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2010-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute 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 3b6dcc4..2193d02 100644
--- a/gcc/ada/exp_ch10.ads
+++ b/gcc/ada/exp_ch10.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute 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 a501bf1..40288e4 100644
--- a/gcc/ada/exp_ch11.adb
+++ b/gcc/ada/exp_ch11.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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,33 +23,37 @@
-- --
------------------------------------------------------------------------------
-with Atree; use Atree;
-with Debug; use Debug;
-with Einfo; use Einfo;
-with Elists; use Elists;
-with Errout; use Errout;
-with Exp_Ch7; use Exp_Ch7;
-with Exp_Intr; use Exp_Intr;
-with Exp_Util; use Exp_Util;
-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 Rtsfind; use Rtsfind;
-with Sem; use Sem;
-with Sem_Ch8; use Sem_Ch8;
-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;
-with Targparm; use Targparm;
-with Tbuild; use Tbuild;
-with Uintp; use Uintp;
+with Atree; use Atree;
+with Debug; use Debug;
+with Einfo; use Einfo;
+with Einfo.Entities; use Einfo.Entities;
+with Einfo.Utils; use Einfo.Utils;
+with Elists; use Elists;
+with Errout; use Errout;
+with Exp_Ch7; use Exp_Ch7;
+with Exp_Intr; use Exp_Intr;
+with Exp_Util; use Exp_Util;
+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 Rtsfind; use Rtsfind;
+with Sem; use Sem;
+with Sem_Ch8; use Sem_Ch8;
+with Sem_Res; use Sem_Res;
+with Sem_Util; use Sem_Util;
+with Sinfo; use Sinfo;
+with Sinfo.Nodes; use Sinfo.Nodes;
+with Sinfo.Utils; use Sinfo.Utils;
+with Sinput; use Sinput;
+with Snames; use Snames;
+with Stand; use Stand;
+with Stringt; use Stringt;
+with Targparm; use Targparm;
+with Tbuild; use Tbuild;
+with Uintp; use Uintp;
package body Exp_Ch11 is
@@ -1084,10 +1088,19 @@ package body Exp_Ch11 is
-- (protecting test only needed if not at library level)
- -- exceptF : Boolean := True -- static data
+ -- exceptF : aliased System.Atomic_Operations.Test_And_Set.
+ -- .Test_And_Set_Flag := 0; -- static data
+ -- if not Atomic_Test_And_Set (exceptF) then
+ -- Register_Exception (except'Unrestricted_Access);
+ -- end if;
+
+ -- If a No_Tasking restriction is in effect, or if Test_And_Set_Flag
+ -- is unavailable, then use Boolean instead. In that case, we generate:
+ --
+ -- exceptF : Boolean := True; -- static data
-- if exceptF then
- -- exceptF := False;
- -- Register_Exception (except'Unchecked_Access);
+ -- ExceptF := False;
+ -- Register_Exception (except'Unrestricted_Access);
-- end if;
procedure Expand_N_Exception_Declaration (N : Node_Id) is
@@ -1242,16 +1255,13 @@ package body Exp_Ch11 is
Prefix => New_Occurrence_Of (Ex_Id, Loc),
Attribute_Name => Name_Length));
- -- Full_Name component: Standard.A_Char!(Nam'Address)
-
- -- The unchecked conversion causes capacity issues for CodePeer in some
- -- cases and is never useful, so we set the Full_Name component to null
- -- instead for CodePeer.
+ -- Full_Name component: Standard_Address?(Nam'Address)
+ -- or 0 if CodePeer_Mode
if CodePeer_Mode then
- Append_To (L, Make_Null (Loc));
+ Append_To (L, Make_Integer_Literal (Loc, Uint_0));
else
- Append_To (L, Unchecked_Convert_To (Standard_A_Char,
+ Append_To (L, OK_Convert_To (Standard_Address,
Make_Attribute_Reference (Loc,
Prefix => New_Occurrence_Of (Ex_Id, Loc),
Attribute_Name => Name_Address)));
@@ -1261,9 +1271,9 @@ package body Exp_Ch11 is
Append_To (L, Make_Null (Loc));
- -- Foreign_Data component: null
+ -- Foreign_Data component: null address
- Append_To (L, Make_Null (Loc));
+ Append_To (L, Make_Integer_Literal (Loc, Uint_0));
-- Raise_Hook component: null
@@ -1274,7 +1284,7 @@ package body Exp_Ch11 is
Force_Static_Allocation_Of_Referenced_Objects (Expression (N));
- -- Register_Exception (except'Unchecked_Access);
+ -- Register_Exception (except'Unrestricted_Access);
if not No_Exception_Handlers_Set
and then not Restriction_Active (No_Exception_Registration)
@@ -1295,27 +1305,59 @@ package body Exp_Ch11 is
Flag_Id :=
Make_Defining_Identifier (Loc,
Chars => New_External_Name (Chars (Id), 'F'));
-
- Insert_Action (N,
- Make_Object_Declaration (Loc,
- Defining_Identifier => Flag_Id,
- Object_Definition =>
- New_Occurrence_Of (Standard_Boolean, Loc),
- Expression =>
- New_Occurrence_Of (Standard_True, Loc)));
-
Set_Is_Statically_Allocated (Flag_Id);
- Append_To (L,
- Make_Assignment_Statement (Loc,
- Name => New_Occurrence_Of (Flag_Id, Loc),
- Expression => New_Occurrence_Of (Standard_False, Loc)));
+ declare
+ Use_Test_And_Set_Flag : constant Boolean :=
+ (not Global_No_Tasking)
+ and then RTE_Available (RE_Test_And_Set_Flag);
+
+ Flag_Decl : Node_Id;
+ Condition : Node_Id;
+ begin
+ if Use_Test_And_Set_Flag then
+ Flag_Decl :=
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Flag_Id,
+ Aliased_Present => True,
+ Object_Definition =>
+ New_Occurrence_Of (RTE (RE_Test_And_Set_Flag), Loc),
+ Expression =>
+ Make_Integer_Literal (Loc, 0));
+ else
+ Flag_Decl :=
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Flag_Id,
+ Object_Definition =>
+ New_Occurrence_Of (Standard_Boolean, Loc),
+ Expression =>
+ New_Occurrence_Of (Standard_True, Loc));
+ end if;
- Insert_After_And_Analyze (N,
- Make_Implicit_If_Statement (N,
- Condition => New_Occurrence_Of (Flag_Id, Loc),
- Then_Statements => L));
+ Insert_Action (N, Flag_Decl);
+
+ if Use_Test_And_Set_Flag then
+ Condition :=
+ Make_Op_Not (Loc,
+ Make_Function_Call (Loc,
+ Name => New_Occurrence_Of
+ (RTE (RE_Atomic_Test_And_Set), Loc),
+ Parameter_Associations =>
+ New_List (New_Occurrence_Of (Flag_Id, Loc))));
+ else
+ Condition := New_Occurrence_Of (Flag_Id, Loc);
+
+ Append_To (L,
+ Make_Assignment_Statement (Loc,
+ Name => New_Occurrence_Of (Flag_Id, Loc),
+ Expression => New_Occurrence_Of (Standard_False, Loc)));
+ end if;
+ Insert_After_And_Analyze (N,
+ Make_Implicit_If_Statement (N,
+ Condition => Condition,
+ Then_Statements => L));
+ end;
else
Insert_List_After_And_Analyze (N, L);
end if;
@@ -1700,7 +1742,7 @@ package body Exp_Ch11 is
if No (Choice_Parameter (Ehand)) then
E := Make_Temporary (Loc, 'E');
Set_Choice_Parameter (Ehand, E);
- Set_Ekind (E, E_Variable);
+ Mutate_Ekind (E, E_Variable);
Set_Etype (E, RTE (RE_Exception_Occurrence));
Set_Scope (E, Current_Scope);
end if;
@@ -1735,6 +1777,24 @@ package body Exp_Ch11 is
Analyze (N);
end Expand_N_Raise_Statement;
+ -----------------------------------
+ -- Expand_N_Raise_When_Statement --
+ -----------------------------------
+
+ procedure Expand_N_Raise_When_Statement (N : Node_Id) is
+ Loc : constant Source_Ptr := Sloc (N);
+ begin
+ Rewrite (N,
+ Make_If_Statement (Loc,
+ Condition => Condition (N),
+ Then_Statements => New_List (
+ Make_Raise_Statement (Loc,
+ Name => Name (N),
+ Expression => Expression (N)))));
+
+ Analyze (N);
+ end Expand_N_Raise_When_Statement;
+
----------------------------------
-- Expand_N_Raise_Storage_Error --
----------------------------------
diff --git a/gcc/ada/exp_ch11.ads b/gcc/ada/exp_ch11.ads
index e6f7ff6..057919b 100644
--- a/gcc/ada/exp_ch11.ads
+++ b/gcc/ada/exp_ch11.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -34,6 +34,7 @@ package Exp_Ch11 is
procedure Expand_N_Raise_Expression (N : Node_Id);
procedure Expand_N_Raise_Program_Error (N : Node_Id);
procedure Expand_N_Raise_Statement (N : Node_Id);
+ procedure Expand_N_Raise_When_Statement (N : Node_Id);
procedure Expand_N_Raise_Storage_Error (N : Node_Id);
-- Data structures for gathering information to build exception tables
diff --git a/gcc/ada/exp_ch12.adb b/gcc/ada/exp_ch12.adb
index 2c5ac8a..3a73a8e 100644
--- a/gcc/ada/exp_ch12.adb
+++ b/gcc/ada/exp_ch12.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1997-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1997-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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,15 +23,18 @@
-- --
------------------------------------------------------------------------------
-with Atree; use Atree;
-with Checks; use Checks;
-with Einfo; use Einfo;
-with Exp_Util; use Exp_Util;
-with Nmake; use Nmake;
-with Sinfo; use Sinfo;
-with Snames; use Snames;
-with Stand; use Stand;
-with Tbuild; use Tbuild;
+with Atree; use Atree;
+with Checks; use Checks;
+with Einfo; use Einfo;
+with Einfo.Entities; use Einfo.Entities;
+with Exp_Util; use Exp_Util;
+with Nmake; use Nmake;
+with Sinfo; use Sinfo;
+with Sinfo.Nodes; use Sinfo.Nodes;
+with Sinfo.Utils; use Sinfo.Utils;
+with Snames; use Snames;
+with Stand; use Stand;
+with Tbuild; use Tbuild;
package body Exp_Ch12 is
diff --git a/gcc/ada/exp_ch12.ads b/gcc/ada/exp_ch12.ads
index c258d75..69fb86e 100644
--- a/gcc/ada/exp_ch12.ads
+++ b/gcc/ada/exp_ch12.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute 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 89efca9..479deca 100644
--- a/gcc/ada/exp_ch13.adb
+++ b/gcc/ada/exp_ch13.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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,33 +23,37 @@
-- --
------------------------------------------------------------------------------
-with Atree; use Atree;
-with Checks; use Checks;
-with Einfo; use Einfo;
-with Exp_Ch3; use Exp_Ch3;
+with Atree; use Atree;
+with Checks; use Checks;
+with Einfo; use Einfo;
+with Einfo.Entities; use Einfo.Entities;
+with Einfo.Utils; use Einfo.Utils;
+with Exp_Ch3; use Exp_Ch3;
with Exp_Ch6;
-with Exp_Imgv; use Exp_Imgv;
-with Exp_Tss; use Exp_Tss;
-with Exp_Util; use Exp_Util;
-with Freeze; use Freeze;
-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 Rtsfind; use Rtsfind;
-with Sem; use Sem;
-with Sem_Aux; use Sem_Aux;
-with Sem_Ch7; use Sem_Ch7;
-with Sem_Ch8; use Sem_Ch8;
-with Sem_Eval; use Sem_Eval;
-with Sem_Util; use Sem_Util;
-with Sinfo; use Sinfo;
-with Snames; use Snames;
-with Tbuild; use Tbuild;
-with Uintp; use Uintp;
-with Validsw; use Validsw;
+with Exp_Imgv; use Exp_Imgv;
+with Exp_Tss; use Exp_Tss;
+with Exp_Util; use Exp_Util;
+with Freeze; use Freeze;
+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 Rtsfind; use Rtsfind;
+with Sem; use Sem;
+with Sem_Aux; use Sem_Aux;
+with Sem_Ch7; use Sem_Ch7;
+with Sem_Ch8; use Sem_Ch8;
+with Sem_Eval; use Sem_Eval;
+with Sem_Util; use Sem_Util;
+with Sinfo; use Sinfo;
+with Sinfo.Nodes; use Sinfo.Nodes;
+with Sinfo.Utils; use Sinfo.Utils;
+with Snames; use Snames;
+with Tbuild; use Tbuild;
+with Uintp; use Uintp;
+with Validsw; use Validsw;
package body Exp_Ch13 is
diff --git a/gcc/ada/exp_ch13.ads b/gcc/ada/exp_ch13.ads
index 843dd4f..1c5301d 100644
--- a/gcc/ada/exp_ch13.ads
+++ b/gcc/ada/exp_ch13.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute 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 6c41e08..a8b20aa 100644
--- a/gcc/ada/exp_ch2.adb
+++ b/gcc/ada/exp_ch2.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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,27 +23,31 @@
-- --
------------------------------------------------------------------------------
-with Atree; use Atree;
-with Checks; use Checks;
-with Debug; use Debug;
-with Einfo; use Einfo;
-with Elists; use Elists;
-with Exp_Smem; use Exp_Smem;
-with Exp_Tss; use Exp_Tss;
-with Exp_Util; use Exp_Util;
-with Namet; use Namet;
-with Nmake; use Nmake;
-with Opt; use Opt;
-with Output; use Output;
-with Sem; use Sem;
-with Sem_Eval; use Sem_Eval;
-with Sem_Res; use Sem_Res;
-with Sem_Util; use Sem_Util;
-with Sem_Warn; use Sem_Warn;
-with Sinfo; use Sinfo;
-with Sinput; use Sinput;
-with Snames; use Snames;
-with Tbuild; use Tbuild;
+with Atree; use Atree;
+with Checks; use Checks;
+with Debug; use Debug;
+with Einfo; use Einfo;
+with Einfo.Entities; use Einfo.Entities;
+with Einfo.Utils; use Einfo.Utils;
+with Elists; use Elists;
+with Exp_Smem; use Exp_Smem;
+with Exp_Tss; use Exp_Tss;
+with Exp_Util; use Exp_Util;
+with Namet; use Namet;
+with Nmake; use Nmake;
+with Opt; use Opt;
+with Output; use Output;
+with Sem; use Sem;
+with Sem_Eval; use Sem_Eval;
+with Sem_Res; use Sem_Res;
+with Sem_Util; use Sem_Util;
+with Sem_Warn; use Sem_Warn;
+with Sinfo; use Sinfo;
+with Sinfo.Nodes; use Sinfo.Nodes;
+with Sinfo.Utils; use Sinfo.Utils;
+with Sinput; use Sinput;
+with Snames; use Snames;
+with Tbuild; use Tbuild;
package body Exp_Ch2 is
diff --git a/gcc/ada/exp_ch2.ads b/gcc/ada/exp_ch2.ads
index 8d11dd4..c84ccef 100644
--- a/gcc/ada/exp_ch2.ads
+++ b/gcc/ada/exp_ch2.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute 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 e0040ed..ad82e56 100644
--- a/gcc/ada/exp_ch3.adb
+++ b/gcc/ada/exp_ch3.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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,55 +23,60 @@
-- --
------------------------------------------------------------------------------
-with Aspects; use Aspects;
-with Atree; use Atree;
-with Checks; use Checks;
-with Einfo; use Einfo;
-with Errout; use Errout;
-with Exp_Aggr; use Exp_Aggr;
-with Exp_Atag; use Exp_Atag;
-with Exp_Ch4; use Exp_Ch4;
-with Exp_Ch6; use Exp_Ch6;
-with Exp_Ch7; use Exp_Ch7;
-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 Aspects; use Aspects;
+with Atree; use Atree;
+with Checks; use Checks;
+with Einfo; use Einfo;
+with Einfo.Entities; use Einfo.Entities;
+with Einfo.Utils; use Einfo.Utils;
+with Errout; use Errout;
+with Expander; use Expander;
+with Exp_Aggr; use Exp_Aggr;
+with Exp_Atag; use Exp_Atag;
+with Exp_Ch4; use Exp_Ch4;
+with Exp_Ch6; use Exp_Ch6;
+with Exp_Ch7; use Exp_Ch7;
+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;
-with Exp_Util; use Exp_Util;
-with Freeze; use Freeze;
-with Ghost; use Ghost;
-with Lib; use Lib;
-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 Rtsfind; use Rtsfind;
-with Sem; use Sem;
-with Sem_Aux; use Sem_Aux;
-with Sem_Attr; use Sem_Attr;
-with Sem_Cat; use Sem_Cat;
-with Sem_Ch3; use Sem_Ch3;
-with Sem_Ch6; use Sem_Ch6;
-with Sem_Ch8; use Sem_Ch8;
-with Sem_Disp; use Sem_Disp;
-with Sem_Eval; use Sem_Eval;
-with Sem_Mech; use Sem_Mech;
-with Sem_Res; use Sem_Res;
-with Sem_SCIL; use Sem_SCIL;
-with Sem_Type; use Sem_Type;
-with Sem_Util; use Sem_Util;
-with Sinfo; use Sinfo;
-with Stand; use Stand;
-with Snames; use Snames;
-with Tbuild; use Tbuild;
-with Ttypes; use Ttypes;
-with Validsw; use Validsw;
+with Exp_Smem; use Exp_Smem;
+with Exp_Strm; use Exp_Strm;
+with Exp_Tss; use Exp_Tss;
+with Exp_Util; use Exp_Util;
+with Freeze; use Freeze;
+with Ghost; use Ghost;
+with Lib; use Lib;
+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 Rtsfind; use Rtsfind;
+with Sem; use Sem;
+with Sem_Aux; use Sem_Aux;
+with Sem_Attr; use Sem_Attr;
+with Sem_Cat; use Sem_Cat;
+with Sem_Ch3; use Sem_Ch3;
+with Sem_Ch6; use Sem_Ch6;
+with Sem_Ch8; use Sem_Ch8;
+with Sem_Disp; use Sem_Disp;
+with Sem_Eval; use Sem_Eval;
+with Sem_Mech; use Sem_Mech;
+with Sem_Res; use Sem_Res;
+with Sem_SCIL; use Sem_SCIL;
+with Sem_Type; use Sem_Type;
+with Sem_Util; use Sem_Util;
+with Sinfo; use Sinfo;
+with Sinfo.Nodes; use Sinfo.Nodes;
+with Sinfo.Utils; use Sinfo.Utils;
+with Stand; use Stand;
+with Snames; use Snames;
+with Tbuild; use Tbuild;
+with Ttypes; use Ttypes;
+with Validsw; use Validsw;
package body Exp_Ch3 is
@@ -124,7 +129,7 @@ package body Exp_Ch3 is
-- Build assignment procedure for one-dimensional arrays of controlled
-- types. Other array and slice assignments are expanded in-line, but
-- the code expansion for controlled components (when control actions
- -- are active) can lead to very large blocks that GCC3 handles poorly.
+ -- are active) can lead to very large blocks that GCC handles poorly.
procedure Build_Untagged_Equality (Typ : Entity_Id);
-- AI05-0123: Equality on untagged records composes. This procedure
@@ -881,7 +886,7 @@ package body Exp_Ch3 is
Make_Handled_Sequence_Of_Statements (Loc,
Statements => Body_Stmts)));
- Set_Ekind (Proc_Id, E_Procedure);
+ Mutate_Ekind (Proc_Id, E_Procedure);
Set_Is_Public (Proc_Id, Is_Public (A_Type));
Set_Is_Internal (Proc_Id);
Set_Has_Completion (Proc_Id);
@@ -1076,7 +1081,7 @@ package body Exp_Ch3 is
Statements => New_List (
Build_Case_Statement (Case_Id, Variant))));
- Set_Ekind (Func_Id, E_Function);
+ Mutate_Ekind (Func_Id, E_Function);
Set_Mechanism (Func_Id, Default_Mechanism);
Set_Is_Inlined (Func_Id, True);
Set_Is_Pure (Func_Id, True);
@@ -1498,7 +1503,8 @@ package body Exp_Ch3 is
Typ : constant Entity_Id := Etype (Discr);
procedure Check_Missing_Others (V : Node_Id);
- -- ???
+ -- Check that a given variant and its nested variants have an others
+ -- choice, and generate a constraint error raise when it does not.
--------------------------
-- Check_Missing_Others --
@@ -1692,8 +1698,7 @@ package body Exp_Ch3 is
if Has_Task (Full_Type) then
if Restriction_Active (No_Task_Hierarchy) then
- Append_To (Args,
- New_Occurrence_Of (RTE (RE_Library_Task_Level), Loc));
+ Append_To (Args, Make_Integer_Literal (Loc, Library_Task_Level));
else
Append_To (Args, Make_Identifier (Loc, Name_uMaster));
end if;
@@ -1868,10 +1873,6 @@ package body Exp_Ch3 is
-- Pass the extra accessibility level parameter associated with the
-- level of the object being initialized when required.
- -- When no entity is present for Id_Ref it may not have been fully
- -- analyzed, so allow the default value of standard standard to be
- -- passed ???
-
if Is_Entity_Name (Id_Ref)
and then Present (Init_Proc_Level_Formal (Proc))
then
@@ -1925,6 +1926,7 @@ package body Exp_Ch3 is
Proc_Id : Entity_Id;
Rec_Type : Entity_Id;
Set_Tag : Entity_Id := Empty;
+ Has_Late_Init_Comp : Boolean := False; -- set in Build_Init_Statements
function Build_Assignment
(Id : Entity_Id;
@@ -2020,35 +2022,27 @@ package body Exp_Ch3 is
Selector_Name => New_Occurrence_Of (Id, Default_Loc));
Set_Assignment_OK (Lhs);
- -- Case of an access attribute applied to the current instance.
- -- Replace the reference to the type by a reference to the actual
- -- object. (Note that this handles the case of the top level of
- -- the expression being given by such an attribute, but does not
- -- cover uses nested within an initial value expression. Nested
- -- uses are unlikely to occur in practice, but are theoretically
- -- possible.) It is not clear how to handle them without fully
- -- traversing the expression. ???
-
- if Kind = N_Attribute_Reference
- 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
- then
- Exp :=
- Make_Attribute_Reference (Default_Loc,
- Prefix =>
- Make_Identifier (Default_Loc, Name_uInit),
- Attribute_Name => Name_Unrestricted_Access);
- end if;
-
-- Take a copy of Exp to ensure that later copies of this component
-- declaration in derived types see the original tree, not a node
-- rewritten during expansion of the init_proc. If the copy contains
-- itypes, the scope of the new itypes is the init_proc being built.
- Exp := New_Copy_Tree (Exp, New_Scope => Proc_Id);
+ declare
+ Map : Elist_Id := No_Elist;
+ begin
+ if Has_Late_Init_Comp then
+ -- Map the type to the _Init parameter in order to
+ -- handle "current instance" references.
+
+ Map := New_Elmt_List
+ (Elmt1 => Rec_Type,
+ Elmt2 => Defining_Identifier (First
+ (Parameter_Specifications
+ (Parent (Proc_Id)))));
+ end if;
+
+ Exp := New_Copy_Tree (Exp, New_Scope => Proc_Id, Map => Map);
+ end;
Res := New_List (
Make_Assignment_Statement (Loc,
@@ -2214,8 +2208,8 @@ package body Exp_Ch3 is
if Has_Task (Rec_Type) then
if Restriction_Active (No_Task_Hierarchy) then
- Append_To (Args,
- New_Occurrence_Of (RTE (RE_Library_Task_Level), Loc));
+ Append_To
+ (Args, Make_Integer_Literal (Loc, Library_Task_Level));
else
Append_To (Args, Make_Identifier (Loc, Name_uMaster));
end if;
@@ -2372,7 +2366,7 @@ package body Exp_Ch3 is
New_Occurrence_Of (Iface_Comp, Loc)),
Attribute_Name => Name_Position))))));
- Set_Ekind (Func_Id, E_Function);
+ Mutate_Ekind (Func_Id, E_Function);
Set_Mechanism (Func_Id, Default_Mechanism);
Set_Is_Internal (Func_Id, True);
@@ -2487,7 +2481,7 @@ package body Exp_Ch3 is
Make_Defining_Identifier (Loc,
Chars => Make_TSS_Name (Rec_Type, TSS_CPP_Init_Proc));
- Set_Ekind (Proc_Id, E_Procedure);
+ Mutate_Ekind (Proc_Id, E_Procedure);
Set_Is_Internal (Proc_Id);
Set_Defining_Unit_Name (Proc_Spec_Node, Proc_Id);
@@ -2541,7 +2535,7 @@ package body Exp_Ch3 is
begin
Body_Stmts := New_List;
Body_Node := New_Node (N_Subprogram_Body, Loc);
- Set_Ekind (Proc_Id, E_Procedure);
+ Mutate_Ekind (Proc_Id, E_Procedure);
Proc_Spec_Node := New_Node (N_Procedure_Specification, Loc);
Set_Defining_Unit_Name (Proc_Spec_Node, Proc_Id);
@@ -2980,7 +2974,6 @@ package body Exp_Ch3 is
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;
@@ -3096,10 +3089,9 @@ package body Exp_Ch3 is
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)))
+ if Is_Entity_Name (N)
+ and then Present (Entity (N))
+ and then Is_Current_Instance (N)
then
References_Current_Instance := True;
return Abandon;
@@ -3254,8 +3246,6 @@ package body Exp_Ch3 is
-- step deals with regular components. The second step deals with
-- components that require late initialization.
- Has_Late_Init_Comp := False;
-
-- First pass : regular components
Decl := First_Non_Pragma (Component_Items (Comp_List));
@@ -4168,7 +4158,7 @@ package body Exp_Ch3 is
-- Generates the following subprogram:
- -- procedure Assign
+ -- procedure array_typeSA
-- (Source, Target : Array_Type,
-- Left_Lo, Left_Hi : Index;
-- Right_Lo, Right_Hi : Index;
@@ -4178,7 +4168,6 @@ package body Exp_Ch3 is
-- Ri1 : Index;
-- begin
-
-- if Left_Hi < Left_Lo then
-- return;
-- end if;
@@ -4204,7 +4193,7 @@ package body Exp_Ch3 is
-- Ri1 := Index'succ (Ri1);
-- end if;
-- end loop;
- -- end Assign;
+ -- end array_typeSA;
procedure Build_Slice_Assignment (Typ : Entity_Id) is
Loc : constant Source_Ptr := Sloc (Typ);
@@ -4386,7 +4375,7 @@ package body Exp_Ch3 is
declare
Spec : Node_Id;
- Formals : List_Id := New_List;
+ Formals : List_Id;
begin
Formals := New_List (
@@ -5478,9 +5467,7 @@ package body Exp_Ch3 is
First_Component (Base_Type (Underlying_Type (Etype (Typ))));
Comp := First_Component (Typ);
while Present (Comp) loop
- if Ekind (Comp) = E_Component
- and then Chars (Comp) = Chars (Old_Comp)
- then
+ if Chars (Comp) = Chars (Old_Comp) then
Set_Discriminant_Checking_Func
(Comp, Discriminant_Checking_Func (Old_Comp));
end if;
@@ -6013,7 +6000,7 @@ package body Exp_Ch3 is
-- The parent type is private then we need to inherit any TSS operations
-- from the full view.
- if Ekind (Par_Id) in Private_Kind
+ if Is_Private_Type (Par_Id)
and then Present (Full_View (Par_Id))
then
Par_Id := Base_Type (Full_View (Par_Id));
@@ -6049,7 +6036,7 @@ package body Exp_Ch3 is
-- If the derived type itself is private with a full view, then
-- associate the full view with the inherited TSS_Elist as well.
- if Ekind (B_Id) in Private_Kind
+ if Is_Private_Type (B_Id)
and then Present (Full_View (B_Id))
then
Ensure_Freeze_Node (Base_Type (Full_View (B_Id)));
@@ -6154,8 +6141,7 @@ package body Exp_Ch3 is
Comp := First_Component (Full_Type);
while Present (Comp) loop
- if Ekind (Comp) = E_Component
- and then Present (Expression (Parent (Comp)))
+ if Present (Expression (Parent (Comp)))
and then
not Is_OK_Static_Expression (Expression (Parent (Comp)))
then
@@ -6187,9 +6173,7 @@ package body Exp_Ch3 is
Comp := First_Component (Full_Type);
while Present (Comp) loop
- if Ekind (Comp) = E_Component
- and then Present (Expression (Parent (Comp)))
- then
+ if Present (Expression (Parent (Comp))) then
Append_To (Component_Associations (Aggr),
Make_Component_Association (Loc,
Choices => New_List (New_Occurrence_Of (Comp, Loc)),
@@ -6561,7 +6545,7 @@ package body Exp_Ch3 is
if Needs_Finalization (Typ) and then not No_Initialization (N) then
Obj_Init :=
Make_Init_Call
- (Obj_Ref => New_Occurrence_Of (Def_Id, Loc),
+ (Obj_Ref => New_Object_Reference,
Typ => Typ);
end if;
@@ -6977,11 +6961,7 @@ package body Exp_Ch3 is
else
-- Obtain actual expression from qualified expression
- if Nkind (Expr) = N_Qualified_Expression then
- Expr_Q := Expression (Expr);
- else
- Expr_Q := Expr;
- end if;
+ Expr_Q := Unqualify (Expr);
-- When we have the appropriate type of aggregate in the expression
-- (it has been determined during analysis of the aggregate by
@@ -6995,12 +6975,16 @@ package body Exp_Ch3 is
-- happen when the aggregate is limited and the declared object
-- 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).
+ -- (see Analyze_Object_Declaration). Resolution is done without
+ -- expansion because it will take place when the declaration
+ -- itself is expanded.
if (Is_Limited_Type (Typ) or else Modify_Tree_For_C)
and then not Analyzed (Expr)
then
+ Expander_Mode_Save_And_Set (False);
Resolve (Expr, Typ);
+ Expander_Mode_Restore;
end if;
Convert_Aggr_In_Object_Decl (N);
@@ -7282,10 +7266,10 @@ package body Exp_Ch3 is
Link_Entities (New_Id, Next_Entity (Def_Id));
Link_Entities (Def_Id, Next_Temp);
- Set_Chars (Defining_Identifier (N), Chars (Def_Id));
+ Set_Chars (Defining_Identifier (N), Chars (Def_Id));
Set_Homonym (Defining_Identifier (N), Homonym (Def_Id));
- Set_Ekind (Defining_Identifier (N), Ekind (Def_Id));
- Set_Sloc (Defining_Identifier (N), Sloc (Def_Id));
+ Mutate_Ekind (Defining_Identifier (N), Ekind (Def_Id));
+ Set_Sloc (Defining_Identifier (N), Sloc (Def_Id));
Set_Comes_From_Source (Def_Id, False);
@@ -7542,7 +7526,7 @@ package body Exp_Ch3 is
Level_Expr : Node_Id;
begin
- Set_Ekind (Level, Ekind (Def_Id));
+ Mutate_Ekind (Level, Ekind (Def_Id));
Set_Etype (Level, Standard_Natural);
Set_Scope (Level, Scope (Def_Id));
@@ -7782,9 +7766,14 @@ package body Exp_Ch3 is
-- Expand_Record_Extension is called directly from the semantics, so
-- we must check to see whether expansion is active before proceeding,
-- because this affects the visibility of selected components in bodies
- -- of instances.
+ -- of instances. Within a generic we still need to set Parent_Subtype
+ -- link because the visibility of inherited components will have to be
+ -- verified in subsequent instances.
if not Expander_Active then
+ if Inside_A_Generic and then Ekind (T) = E_Record_Type then
+ Set_Parent_Subtype (T, Etype (T));
+ end if;
return;
end if;
@@ -8597,35 +8586,28 @@ package body Exp_Ch3 is
--------------------------------
function Simple_Init_Defaulted_Type return Node_Id is
- Subtyp : constant Entity_Id := First_Subtype (Typ);
+ Subtyp : Entity_Id := First_Subtype (Typ);
begin
- -- Use the Sloc of the context node when constructing the initial
- -- value because the expression of Default_Value may come from a
- -- different unit. Updating the Sloc will result in accurate error
- -- diagnostics.
-
-- When the first subtype is private, retrieve the expression of the
-- Default_Value from the underlying type.
if Is_Private_Type (Subtyp) then
- return
- Unchecked_Convert_To
- (Typ => Typ,
- Expr =>
- New_Copy_Tree
- (Source => Default_Aspect_Value (Full_View (Subtyp)),
- New_Sloc => Loc));
-
- else
- return
- Convert_To
- (Typ => Typ,
- Expr =>
- New_Copy_Tree
- (Source => Default_Aspect_Value (Subtyp),
- New_Sloc => Loc));
+ Subtyp := Full_View (Subtyp);
end if;
+
+ -- Use the Sloc of the context node when constructing the initial
+ -- value because the expression of Default_Value may come from a
+ -- different unit. Updating the Sloc will result in accurate error
+ -- diagnostics.
+
+ return
+ OK_Convert_To
+ (Typ => Typ,
+ Expr =>
+ New_Copy_Tree
+ (Source => Default_Aspect_Value (Subtyp),
+ New_Sloc => Loc));
end Simple_Init_Defaulted_Type;
-----------------------------------------
@@ -9008,11 +8990,10 @@ package body Exp_Ch3 is
begin
Comp := First_Component (E);
while Present (Comp) loop
- if Ekind (Comp) = E_Discriminant
- or else
- (Nkind (Parent (Comp)) = N_Component_Declaration
- and then Present (Expression (Parent (Comp))))
- then
+ pragma Assert
+ (Nkind (Parent (Comp)) = N_Component_Declaration);
+
+ if Present (Expression (Parent (Comp))) then
Warning_Needed := True;
exit;
end if;
@@ -9080,7 +9061,7 @@ package body Exp_Ch3 is
Defining_Identifier =>
Make_Defining_Identifier (Loc, Name_uMaster),
Parameter_Type =>
- New_Occurrence_Of (RTE (RE_Master_Id), Loc)));
+ New_Occurrence_Of (Standard_Integer, Loc)));
Set_Has_Master_Entity (Proc_Id);
@@ -9715,11 +9696,11 @@ package body Exp_Ch3 is
-- primitive operations list. We add the minimum decoration needed
-- to override interface primitives.
- Set_Ekind (Defining_Unit_Name (Func_Spec), E_Function);
+ Mutate_Ekind (Defining_Unit_Name (Func_Spec), E_Function);
+ Set_Is_Wrapper (Defining_Unit_Name (Func_Spec));
Override_Dispatching_Operation
- (Tag_Typ, Subp, New_Op => Defining_Unit_Name (Func_Spec),
- Is_Wrapper => True);
+ (Tag_Typ, Subp, New_Op => Defining_Unit_Name (Func_Spec));
end if;
<<Next_Prim>>
@@ -10353,9 +10334,14 @@ package body Exp_Ch3 is
-- Spec of Put_Image
- if Enable_Put_Image (Tag_Typ)
- and then No (TSS (Tag_Typ, TSS_Put_Image))
+ if (not No_Run_Time_Mode)
+ and then RTE_Available (RE_Root_Buffer_Type)
then
+ -- No_Run_Time_Mode implies that the declaration of Tag_Typ
+ -- (like any tagged type) will be rejected. Given this, avoid
+ -- cascading errors associated with the Tag_Typ's TSS_Put_Image
+ -- procedure.
+
Append_To (Res, Predef_Spec_Or_Body (Loc,
Tag_Typ => Tag_Typ,
Name => Make_TSS_Name (Tag_Typ, TSS_Put_Image),
@@ -10957,8 +10943,9 @@ package body Exp_Ch3 is
-- Body of Put_Image
- if Enable_Put_Image (Tag_Typ)
- and then No (TSS (Tag_Typ, TSS_Put_Image))
+ if No (TSS (Tag_Typ, TSS_Put_Image))
+ and then (not No_Run_Time_Mode)
+ and then RTE_Available (RE_Root_Buffer_Type)
then
Build_Record_Put_Image_Procedure (Loc, Tag_Typ, Decl, Ent);
Append_To (Res, Decl);
@@ -11261,12 +11248,7 @@ package body Exp_Ch3 is
or else not Is_Abstract_Type (Typ)
or else not Is_Derived_Type (Typ))
and then not Has_Unknown_Discriminants (Typ)
- and then not
- (Is_Interface (Typ)
- and then
- (Is_Task_Interface (Typ)
- or else Is_Protected_Interface (Typ)
- or else Is_Synchronized_Interface (Typ)))
+ and then not Is_Concurrent_Interface (Typ)
and then not Restriction_Active (No_Streams)
and then not Restriction_Active (No_Dispatch)
and then No (No_Tagged_Streams_Pragma (Typ))
diff --git a/gcc/ada/exp_ch3.ads b/gcc/ada/exp_ch3.ads
index a4b7f1f..0c5f9cc 100644
--- a/gcc/ada/exp_ch3.ads
+++ b/gcc/ada/exp_ch3.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute 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_ch4.adb b/gcc/ada/exp_ch4.adb
index 04bd1fe..16f513e 100644
--- a/gcc/ada/exp_ch4.adb
+++ b/gcc/ada/exp_ch4.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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,55 +23,59 @@
-- --
------------------------------------------------------------------------------
-with Atree; use Atree;
-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_Atag; use Exp_Atag;
-with Exp_Ch3; use Exp_Ch3;
-with Exp_Ch6; use Exp_Ch6;
-with Exp_Ch7; use Exp_Ch7;
-with Exp_Ch9; use Exp_Ch9;
-with Exp_Disp; use Exp_Disp;
-with Exp_Fixd; use Exp_Fixd;
-with Exp_Intr; use Exp_Intr;
-with Exp_Pakd; use Exp_Pakd;
-with Exp_Tss; use Exp_Tss;
-with Exp_Util; use Exp_Util;
-with Freeze; use Freeze;
-with Inline; use Inline;
-with Namet; use Namet;
-with Nlists; use Nlists;
-with Nmake; use Nmake;
-with Opt; use Opt;
-with Par_SCO; use Par_SCO;
-with Restrict; use Restrict;
-with Rident; use Rident;
-with Rtsfind; use Rtsfind;
-with Sem; use Sem;
-with Sem_Aux; use Sem_Aux;
-with Sem_Cat; use Sem_Cat;
-with Sem_Ch3; use Sem_Ch3;
-with Sem_Ch13; use Sem_Ch13;
-with Sem_Eval; use Sem_Eval;
-with Sem_Res; use Sem_Res;
-with Sem_Type; use Sem_Type;
-with Sem_Util; use Sem_Util;
-with Sem_Warn; use Sem_Warn;
-with Sinfo; use Sinfo;
-with Snames; use Snames;
-with Stand; use Stand;
-with SCIL_LL; use SCIL_LL;
-with Targparm; use Targparm;
-with Tbuild; use Tbuild;
-with Ttypes; use Ttypes;
-with Uintp; use Uintp;
-with Urealp; use Urealp;
-with Validsw; use Validsw;
-with Warnsw; use Warnsw;
+with Atree; use Atree;
+with Checks; use Checks;
+with Debug; use Debug;
+with Einfo; use Einfo;
+with Einfo.Entities; use Einfo.Entities;
+with Einfo.Utils; use Einfo.Utils;
+with Elists; use Elists;
+with Errout; use Errout;
+with Exp_Aggr; use Exp_Aggr;
+with Exp_Atag; use Exp_Atag;
+with Exp_Ch3; use Exp_Ch3;
+with Exp_Ch6; use Exp_Ch6;
+with Exp_Ch7; use Exp_Ch7;
+with Exp_Ch9; use Exp_Ch9;
+with Exp_Disp; use Exp_Disp;
+with Exp_Fixd; use Exp_Fixd;
+with Exp_Intr; use Exp_Intr;
+with Exp_Pakd; use Exp_Pakd;
+with Exp_Tss; use Exp_Tss;
+with Exp_Util; use Exp_Util;
+with Freeze; use Freeze;
+with Inline; use Inline;
+with Namet; use Namet;
+with Nlists; use Nlists;
+with Nmake; use Nmake;
+with Opt; use Opt;
+with Par_SCO; use Par_SCO;
+with Restrict; use Restrict;
+with Rident; use Rident;
+with Rtsfind; use Rtsfind;
+with Sem; use Sem;
+with Sem_Aux; use Sem_Aux;
+with Sem_Cat; use Sem_Cat;
+with Sem_Ch3; use Sem_Ch3;
+with Sem_Ch13; use Sem_Ch13;
+with Sem_Eval; use Sem_Eval;
+with Sem_Res; use Sem_Res;
+with Sem_Type; use Sem_Type;
+with Sem_Util; use Sem_Util;
+with Sem_Warn; use Sem_Warn;
+with Sinfo; use Sinfo;
+with Sinfo.Nodes; use Sinfo.Nodes;
+with Sinfo.Utils; use Sinfo.Utils;
+with Snames; use Snames;
+with Stand; use Stand;
+with SCIL_LL; use SCIL_LL;
+with Targparm; use Targparm;
+with Tbuild; use Tbuild;
+with Ttypes; use Ttypes;
+with Uintp; use Uintp;
+with Urealp; use Urealp;
+with Validsw; use Validsw;
+with Warnsw; use Warnsw;
package body Exp_Ch4 is
@@ -172,16 +176,9 @@ package body Exp_Ch4 is
-- routine is to find the real type by looking up the tree. We also
-- determine if the operation must be rounded.
- function Has_Inferable_Discriminants (N : Node_Id) return Boolean;
- -- Ada 2005 (AI-216): A view of an Unchecked_Union object has inferable
- -- discriminants if it has a constrained nominal type, unless the object
- -- is a component of an enclosing Unchecked_Union object that is subject
- -- to a per-object constraint and the enclosing object lacks inferable
- -- discriminants.
- --
- -- An expression of an Unchecked_Union type has inferable discriminants
- -- if it is either a name of an object with inferable discriminants or a
- -- qualified expression whose subtype mark denotes a constrained subtype.
+ function Get_Size_For_Range (Lo, Hi : Uint) return Uint;
+ -- Return the size of a small signed integer type covering Lo .. Hi, the
+ -- main goal being to return a size lower than that of standard types.
procedure Insert_Dereference_Action (N : Node_Id);
-- N is an expression whose type is an access. When the type of the
@@ -618,6 +615,7 @@ package body Exp_Ch4 is
and then Is_Class_Wide_Type (DesigT)
and then Tagged_Type_Expansion
and then not Scope_Suppress.Suppress (Accessibility_Check)
+ and then not No_Dynamic_Accessibility_Checks_Enabled (Ref)
and then
(Type_Access_Level (Etype (Exp)) > Type_Access_Level (PtrT)
or else
@@ -733,8 +731,7 @@ package body Exp_Ch4 is
Append_To (Stmts,
Make_Raise_Program_Error (Loc,
- Condition => New_Occurrence_Of (Standard_True, Loc),
- Reason => PE_Accessibility_Check_Failed));
+ Reason => PE_Accessibility_Check_Failed));
-- Step 2: Create the accessibility comparison
@@ -1169,6 +1166,9 @@ package body Exp_Ch4 is
-- secondary stack). In that case, the object will be moved, so we do
-- want to Adjust. However, if it's a nonlimited build-in-place
-- function call, Adjust is not wanted.
+ --
+ -- Needs_Finalization (DesigT) can differ from Needs_Finalization (T)
+ -- if one of the two types is class-wide, and the other is not.
if Needs_Finalization (DesigT)
and then Needs_Finalization (T)
@@ -2253,9 +2253,6 @@ package body Exp_Ch4 is
LLIB : constant Entity_Id := Base_Type (Standard_Long_Long_Integer);
-- Entity for Long_Long_Integer'Base
- Check : constant Overflow_Mode_Type := Overflow_Check_Mode;
- -- Current overflow checking mode
-
procedure Set_True;
procedure Set_False;
-- These procedures rewrite N with an occurrence of Standard_True or
@@ -2284,17 +2281,6 @@ package body Exp_Ch4 is
-- Start of processing for Expand_Compare_Minimize_Eliminate_Overflow
begin
- -- Nothing to do unless we have a comparison operator with operands
- -- that are signed integer types, and we are operating in either
- -- MINIMIZED or ELIMINATED overflow checking mode.
-
- if Nkind (N) not in N_Op_Compare
- or else Check not in Minimized_Or_Eliminated
- or else not Is_Signed_Integer_Type (Etype (Left_Opnd (N)))
- then
- return;
- end if;
-
-- OK, this is the case we are interested in. First step is to process
-- our operands using the Minimize_Eliminate circuitry which applies
-- this processing to the two operand subtrees.
@@ -3035,16 +3021,6 @@ package body Exp_Ch4 is
if Is_Enumeration_Type (Ityp) then
Artyp := Standard_Integer;
- -- If index type is Positive, we use the standard unsigned type, to give
- -- more room on the top of the range, obviating the need for an overflow
- -- check when creating the upper bound. This is needed to avoid junk
- -- overflow checks in the common case of String types.
-
- -- ??? Disabled for now
-
- -- elsif Istyp = Standard_Positive then
- -- Artyp := Standard_Unsigned;
-
-- 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 a 64-bit type.
@@ -3803,7 +3779,7 @@ package body Exp_Ch4 is
-- Bounds in Minimize calls, not used currently
LLIB : constant Entity_Id := Base_Type (Standard_Long_Long_Integer);
- -- Entity for Long_Long_Integer'Base (Standard should export this???)
+ -- Entity for Long_Long_Integer'Base
begin
Minimize_Eliminate_Overflows (Lop, Lo, Hi, Top_Level => False);
@@ -4282,7 +4258,7 @@ package body Exp_Ch4 is
-- larger type for the operands, to prevent spurious constraint
-- errors on large legal literals of the type.
- if Modulus (Etype (N)) > UI_From_Int (Int (Integer'Last)) then
+ if Modulus (Etype (N)) > Int (Integer'Last) then
Target_Type := Standard_Long_Long_Integer;
else
Target_Type := Standard_Integer;
@@ -4499,10 +4475,6 @@ package body Exp_Ch4 is
-- are too large, and which in the absence of a check results in
-- undetected chaos ???
- -- Note in particular that this is a pessimistic estimate in the
- -- case of packed array types, where an array element might occupy
- -- just a fraction of a storage element???
-
declare
Idx : Node_Id := First_Index (E);
Len : Node_Id;
@@ -4624,9 +4596,10 @@ package body Exp_Ch4 is
end if;
-- 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 ???
+ -- shall not be a remote access-to-class-wide-limited-private type.
+ -- We probably shouldn't be doing this legality check during expansion,
+ -- but this is only an issue for Annex E users, and is unlikely to be a
+ -- problem in practice.
Validate_Remote_Access_To_Class_Wide_Type (N);
@@ -5224,8 +5197,8 @@ package body Exp_Ch4 is
end if;
if Restriction_Active (No_Task_Hierarchy) then
- Append_To (Args,
- New_Occurrence_Of (RTE (RE_Library_Task_Level), Loc));
+ Append_To
+ (Args, Make_Integer_Literal (Loc, Library_Task_Level));
else
Append_To (Args,
New_Occurrence_Of
@@ -5308,6 +5281,8 @@ package body Exp_Ch4 is
if Ada_Version >= Ada_2005
and then
Ekind (Etype (Nod)) = E_Anonymous_Access_Type
+ and then not
+ No_Dynamic_Accessibility_Checks_Enabled (Nod)
then
Apply_Accessibility_Check
(Nod, Typ, Insert_Node => Nod);
@@ -5568,10 +5543,8 @@ package body Exp_Ch4 is
if Is_Copy_Type (Typ) then
Target_Typ := Typ;
- -- ??? Do not perform the optimization when the return statement is
- -- within a predicate function, as this causes spurious errors. Could
- -- this be a possible mismatch in handling this case somewhere else
- -- in semantic analysis?
+ -- Do not perform the optimization when the return statement is
+ -- within a predicate function, as this causes spurious errors.
Optimize_Return_Stmt :=
Nkind (Par) = N_Simple_Return_Statement and then not In_Predicate;
@@ -5813,15 +5786,14 @@ package body Exp_Ch4 is
-- Avoid processing temporary function results multiple times when
-- dealing with nested expression_with_actions.
+ -- Similarly, do not process temporary function results in loops.
+ -- This is done by Expand_N_Loop_Statement and Build_Finalizer.
+ -- Note that we used to wrongly return Abandon instead of Skip here:
+ -- this is wrong since it means that we were ignoring lots of
+ -- relevant subsequent statements.
- elsif Nkind (Act) = N_Expression_With_Actions then
- return Abandon;
-
- -- Do not process temporary function results in loops. This is done
- -- by Expand_N_Loop_Statement and Build_Finalizer.
-
- elsif Nkind (Act) = N_Loop_Statement then
- return Abandon;
+ elsif Nkind (Act) in N_Expression_With_Actions | N_Loop_Statement then
+ return Skip;
end if;
return OK;
@@ -5941,9 +5913,14 @@ package body Exp_Ch4 is
-- Start of processing for Expand_N_If_Expression
begin
- -- Check for MINIMIZED/ELIMINATED overflow mode
+ -- Check for MINIMIZED/ELIMINATED overflow mode.
+ -- Apply_Arithmetic_Overflow_Check will not deal with Then/Else_Actions
+ -- so skip this step if any actions are present.
- if Minimized_Eliminated_Overflow_Check (N) then
+ if Minimized_Eliminated_Overflow_Check (N)
+ and then No (Then_Actions (N))
+ and then No (Else_Actions (N))
+ then
Apply_Arithmetic_Overflow_Check (N);
return;
end if;
@@ -6355,13 +6332,11 @@ package body Exp_Ch4 is
-- perspective.
if Comes_From_Source (Obj_Ref) then
-
- -- Recover the actual object reference. There may be more cases
- -- to consider???
-
loop
if Nkind (Obj_Ref) in
- N_Type_Conversion | N_Unchecked_Type_Conversion
+ N_Type_Conversion |
+ N_Unchecked_Type_Conversion |
+ N_Qualified_Expression
then
Obj_Ref := Expression (Obj_Ref);
else
@@ -6425,8 +6400,7 @@ package body Exp_Ch4 is
-- type, then expand with a separate procedure. Note the use of the
-- flag No_Minimize_Eliminate to prevent infinite recursion.
- if Overflow_Check_Mode in Minimized_Or_Eliminated
- and then Is_Signed_Integer_Type (Ltyp)
+ if Minimized_Eliminated_Overflow_Check (Left_Opnd (N))
and then not No_Minimize_Eliminate (N)
then
Expand_Membership_Minimize_Eliminate_Overflow (N);
@@ -6507,8 +6481,6 @@ package body Exp_Ch4 is
begin
-- If test is explicit x'First .. x'Last, replace by valid check
- -- Could use some individual comments for this complex test ???
-
if Is_Scalar_Type (Ltyp)
-- And left operand is X'First where X matches left operand
@@ -6899,6 +6871,7 @@ package body Exp_Ch4 is
if Ada_Version >= Ada_2012
and then Is_Acc
and then Ekind (Ltyp) = E_Anonymous_Access_Type
+ and then not No_Dynamic_Accessibility_Checks_Enabled (Lop)
then
declare
Expr_Entity : Entity_Id := Empty;
@@ -8113,13 +8086,9 @@ package body Exp_Ch4 is
function User_Defined_Primitive_Equality_Op
(Typ : Entity_Id) return Entity_Id
is
- Enclosing_Scope : constant Node_Id := Scope (Typ);
+ Enclosing_Scope : constant Entity_Id := Scope (Typ);
E : Entity_Id;
begin
- -- Prune this search by somehow not looking at decls that precede
- -- the declaration of the first view of Typ (which might be a partial
- -- view)???
-
for Private_Entities in Boolean loop
if Private_Entities then
if Ekind (Enclosing_Scope) /= E_Package then
@@ -8154,138 +8123,129 @@ package body Exp_Ch4 is
function Has_Unconstrained_UU_Component
(Typ : Entity_Id) return Boolean
is
- Tdef : constant Node_Id :=
- Type_Definition (Declaration_Node (Base_Type (Typ)));
- Clist : Node_Id;
- Vpart : Node_Id;
-
- function Component_Is_Unconstrained_UU
- (Comp : Node_Id) return Boolean;
- -- Determines whether the subtype of the component is an
- -- unconstrained Unchecked_Union.
-
- function Variant_Is_Unconstrained_UU
- (Variant : Node_Id) return Boolean;
- -- Determines whether a component of the variant has an unconstrained
- -- Unchecked_Union subtype.
-
- -----------------------------------
- -- Component_Is_Unconstrained_UU --
- -----------------------------------
-
- function Component_Is_Unconstrained_UU
- (Comp : Node_Id) return Boolean
- is
- begin
- if Nkind (Comp) /= N_Component_Declaration then
- return False;
- end if;
-
- declare
- Sindic : constant Node_Id :=
- Subtype_Indication (Component_Definition (Comp));
+ function Unconstrained_UU_In_Component_Declaration
+ (N : Node_Id) return Boolean;
- begin
- -- Unconstrained nominal type. In the case of a constraint
- -- present, the node kind would have been N_Subtype_Indication.
+ function Unconstrained_UU_In_Component_Items
+ (L : List_Id) return Boolean;
- if Nkind (Sindic) = N_Identifier then
- return Is_Unchecked_Union (Base_Type (Etype (Sindic)));
- end if;
+ function Unconstrained_UU_In_Component_List
+ (N : Node_Id) return Boolean;
- return False;
- end;
- end Component_Is_Unconstrained_UU;
+ function Unconstrained_UU_In_Variant_Part
+ (N : Node_Id) return Boolean;
+ -- A family of routines that determine whether a particular construct
+ -- of a record type definition contains a subcomponent of an
+ -- unchecked union type whose nominal subtype is unconstrained.
+ --
+ -- Individual routines correspond to the production rules of the Ada
+ -- grammar, as described in the Ada RM (P).
- ---------------------------------
- -- Variant_Is_Unconstrained_UU --
- ---------------------------------
+ -----------------------------------------------
+ -- Unconstrained_UU_In_Component_Declaration --
+ -----------------------------------------------
- function Variant_Is_Unconstrained_UU
- (Variant : Node_Id) return Boolean
+ function Unconstrained_UU_In_Component_Declaration
+ (N : Node_Id) return Boolean
is
- Clist : constant Node_Id := Component_List (Variant);
+ pragma Assert (Nkind (N) = N_Component_Declaration);
+ Sindic : constant Node_Id :=
+ Subtype_Indication (Component_Definition (N));
begin
- if Is_Empty_List (Component_Items (Clist)) then
- return False;
- end if;
-
- -- We only need to test one component
-
- declare
- Comp : Node_Id := First (Component_Items (Clist));
-
- begin
- while Present (Comp) loop
- if Component_Is_Unconstrained_UU (Comp) then
- return True;
- end if;
-
- Next (Comp);
- end loop;
- end;
-
- -- None of the components withing the variant were of
- -- unconstrained Unchecked_Union type.
-
- return False;
- end Variant_Is_Unconstrained_UU;
+ -- If the component declaration includes a subtype indication
+ -- it is not an unchecked_union. Otherwise verify that it carries
+ -- the Unchecked_Union flag and is either a record or a private
+ -- type. A Record_Subtype declared elsewhere does not qualify,
+ -- even if its parent type carries the flag.
+
+ return Nkind (Sindic) in N_Expanded_Name | N_Identifier
+ and then Is_Unchecked_Union (Base_Type (Etype (Sindic)))
+ and then (Ekind (Entity (Sindic)) in
+ E_Private_Type | E_Record_Type);
+ end Unconstrained_UU_In_Component_Declaration;
+
+ -----------------------------------------
+ -- Unconstrained_UU_In_Component_Items --
+ -----------------------------------------
+
+ function Unconstrained_UU_In_Component_Items
+ (L : List_Id) return Boolean
+ is
+ N : Node_Id := First (L);
+ begin
+ while Present (N) loop
+ if Nkind (N) = N_Component_Declaration
+ and then Unconstrained_UU_In_Component_Declaration (N)
+ then
+ return True;
+ end if;
- -- Start of processing for Has_Unconstrained_UU_Component
+ Next (N);
+ end loop;
- begin
- if Null_Present (Tdef) then
return False;
- end if;
-
- Clist := Component_List (Tdef);
- Vpart := Variant_Part (Clist);
+ end Unconstrained_UU_In_Component_Items;
- -- Inspect available components
+ ----------------------------------------
+ -- Unconstrained_UU_In_Component_List --
+ ----------------------------------------
- if Present (Component_Items (Clist)) then
- declare
- Comp : Node_Id := First (Component_Items (Clist));
+ function Unconstrained_UU_In_Component_List
+ (N : Node_Id) return Boolean
+ is
+ pragma Assert (Nkind (N) = N_Component_List);
- begin
- while Present (Comp) loop
+ Optional_Variant_Part : Node_Id;
+ begin
+ if Unconstrained_UU_In_Component_Items (Component_Items (N)) then
+ return True;
+ end if;
- -- One component is sufficient
+ Optional_Variant_Part := Variant_Part (N);
- if Component_Is_Unconstrained_UU (Comp) then
- return True;
- end if;
+ return
+ Present (Optional_Variant_Part)
+ and then
+ Unconstrained_UU_In_Variant_Part (Optional_Variant_Part);
+ end Unconstrained_UU_In_Component_List;
- Next (Comp);
- end loop;
- end;
- end if;
+ --------------------------------------
+ -- Unconstrained_UU_In_Variant_Part --
+ --------------------------------------
- -- Inspect available components withing variants
+ function Unconstrained_UU_In_Variant_Part
+ (N : Node_Id) return Boolean
+ is
+ pragma Assert (Nkind (N) = N_Variant_Part);
- if Present (Vpart) then
- declare
- Variant : Node_Id := First (Variants (Vpart));
+ Variant : Node_Id := First (Variants (N));
+ begin
+ loop
+ if Unconstrained_UU_In_Component_List (Component_List (Variant))
+ then
+ return True;
+ end if;
- begin
- while Present (Variant) loop
+ Next (Variant);
+ exit when No (Variant);
+ end loop;
- -- One component within a variant is sufficient
+ return False;
+ end Unconstrained_UU_In_Variant_Part;
- if Variant_Is_Unconstrained_UU (Variant) then
- return True;
- end if;
+ Typ_Def : constant Node_Id :=
+ Type_Definition (Declaration_Node (Base_Type (Typ)));
- Next (Variant);
- end loop;
- end;
- end if;
+ Optional_Component_List : constant Node_Id :=
+ Component_List (Typ_Def);
- -- Neither the available components, nor the components inside the
- -- variant parts were of an unconstrained Unchecked_Union subtype.
+ -- Start of processing for Has_Unconstrained_UU_Component
- return False;
+ begin
+ return Present (Optional_Component_List)
+ and then
+ Unconstrained_UU_In_Component_List (Optional_Component_List);
end Has_Unconstrained_UU_Component;
-- Local variables
@@ -8343,7 +8303,9 @@ package body Exp_Ch4 is
-- Deal with overflow checks in MINIMIZED/ELIMINATED mode and if that
-- means we no longer have a comparison operation, we are all done.
- Expand_Compare_Minimize_Eliminate_Overflow (N);
+ if Minimized_Eliminated_Overflow_Check (Left_Opnd (N)) then
+ Expand_Compare_Minimize_Eliminate_Overflow (N);
+ end if;
if Nkind (N) /= N_Op_Eq then
return;
@@ -9128,15 +9090,12 @@ package body Exp_Ch4 is
-- overflow), and if there is an infinity generated and a range check
-- is required, the check will fail anyway.
- -- Historical note: we used to convert everything to Long_Long_Float
- -- and call a single common routine, but this had the undesirable effect
- -- of giving different results for small static exponent values and the
- -- same dynamic values.
-
else
pragma Assert (Is_Floating_Point_Type (Rtyp));
- if Rtyp = Standard_Float then
+ -- Short_Float and Float are the same type for GNAT
+
+ if Rtyp = Standard_Short_Float or else Rtyp = Standard_Float then
Etyp := Standard_Float;
Rent := RE_Exn_Float;
@@ -9154,8 +9113,7 @@ package body Exp_Ch4 is
-- If we are in the right type, we can call runtime routine directly
if Typ = Etyp
- and then Rtyp /= Universal_Integer
- and then Rtyp /= Universal_Real
+ and then not Is_Universal_Numeric_Type (Rtyp)
then
Rewrite (N,
Wrap_MA (
@@ -9201,7 +9159,9 @@ package body Exp_Ch4 is
-- Deal with overflow checks in MINIMIZED/ELIMINATED mode and if that
-- means we no longer have a comparison operation, we are all done.
- Expand_Compare_Minimize_Eliminate_Overflow (N);
+ if Minimized_Eliminated_Overflow_Check (Op1) then
+ Expand_Compare_Minimize_Eliminate_Overflow (N);
+ end if;
if Nkind (N) /= N_Op_Ge then
return;
@@ -9250,7 +9210,9 @@ package body Exp_Ch4 is
-- Deal with overflow checks in MINIMIZED/ELIMINATED mode and if that
-- means we no longer have a comparison operation, we are all done.
- Expand_Compare_Minimize_Eliminate_Overflow (N);
+ if Minimized_Eliminated_Overflow_Check (Op1) then
+ Expand_Compare_Minimize_Eliminate_Overflow (N);
+ end if;
if Nkind (N) /= N_Op_Gt then
return;
@@ -9299,7 +9261,9 @@ package body Exp_Ch4 is
-- Deal with overflow checks in MINIMIZED/ELIMINATED mode and if that
-- means we no longer have a comparison operation, we are all done.
- Expand_Compare_Minimize_Eliminate_Overflow (N);
+ if Minimized_Eliminated_Overflow_Check (Op1) then
+ Expand_Compare_Minimize_Eliminate_Overflow (N);
+ end if;
if Nkind (N) /= N_Op_Le then
return;
@@ -9348,7 +9312,9 @@ package body Exp_Ch4 is
-- Deal with overflow checks in MINIMIZED/ELIMINATED mode and if that
-- means we no longer have a comparison operation, we are all done.
- Expand_Compare_Minimize_Eliminate_Overflow (N);
+ if Minimized_Eliminated_Overflow_Check (Op1) then
+ Expand_Compare_Minimize_Eliminate_Overflow (N);
+ end if;
if Nkind (N) /= N_Op_Lt then
return;
@@ -9667,6 +9633,7 @@ package body Exp_Ch4 is
if ((not ROK) or else (Rlo <= (-1) and then (-1) <= Rhi))
and then ((not LOK) or else (Llo = LLB))
+ and then not CodePeer_Mode
then
Rewrite (N,
Make_If_Expression (Loc,
@@ -9942,7 +9909,9 @@ package body Exp_Ch4 is
-- Deal with overflow checks in MINIMIZED/ELIMINATED mode and if
-- means we no longer have a /= operation, we are all done.
- Expand_Compare_Minimize_Eliminate_Overflow (N);
+ if Minimized_Eliminated_Overflow_Check (Left_Opnd (N)) then
+ Expand_Compare_Minimize_Eliminate_Overflow (N);
+ end if;
if Nkind (N) /= N_Op_Ne then
return;
@@ -10431,7 +10400,9 @@ package body Exp_Ch4 is
-- types and this is really marginal). We will just assume that we need
-- the test if the left operand can be negative at all.
- if Lneg and Rneg then
+ if (Lneg and Rneg)
+ and then not CodePeer_Mode
+ then
Rewrite (N,
Make_If_Expression (Loc,
Expressions => New_List (
@@ -10890,10 +10861,11 @@ package body Exp_Ch4 is
Var : Entity_Id;
begin
- -- Ensure that the bound variable is properly frozen. We must do
- -- this before expansion because the expression is about to be
- -- converted into a loop, and resulting freeze nodes may end up
- -- in the wrong place in the tree.
+ -- Ensure that the bound variable as well as the type of Name of the
+ -- Iter_Spec if present are properly frozen. We must do this before
+ -- expansion because the expression is about to be converted into a
+ -- loop, and resulting freeze nodes may end up in the wrong place in the
+ -- tree.
if Present (Iter_Spec) then
Var := Defining_Identifier (Iter_Spec);
@@ -10908,6 +10880,10 @@ package body Exp_Ch4 is
P := Parent (P);
end loop;
+ if Present (Iter_Spec) then
+ Freeze_Before (P, Etype (Name (Iter_Spec)));
+ end if;
+
Freeze_Before (P, Etype (Var));
end;
@@ -12019,9 +11995,8 @@ package body Exp_Ch4 is
-- unchecked conversion to the target fixed-point type.
Conv :=
- Make_Unchecked_Type_Conversion (Loc,
- Subtype_Mark => New_Occurrence_Of (Target_Type, Loc),
- Expression => New_Occurrence_Of (Expr_Id, Loc));
+ Unchecked_Convert_To
+ (Target_Type, New_Occurrence_Of (Expr_Id, Loc));
end;
-- All other conversions
@@ -12273,6 +12248,41 @@ package body Exp_Ch4 is
end;
end if;
+ -- If the conversion is from Universal_Integer and requires an overflow
+ -- check, try to do an intermediate conversion to a narrower type first
+ -- without overflow check, in order to avoid doing the overflow check
+ -- in Universal_Integer, which can be a very large type.
+
+ if Operand_Type = Universal_Integer and then Do_Overflow_Check (N) then
+ declare
+ Lo, Hi, Siz : Uint;
+ OK : Boolean;
+ Typ : Entity_Id;
+
+ begin
+ Determine_Range (Operand, OK, Lo, Hi, Assume_Valid => True);
+
+ if OK then
+ Siz := Get_Size_For_Range (Lo, Hi);
+
+ -- We use the base type instead of the first subtype because
+ -- overflow checks are done in the base type, so this avoids
+ -- the need for useless conversions.
+
+ if Siz < System_Max_Integer_Size then
+ Typ := Etype (Integer_Type_For (Siz, Uns => False));
+
+ Convert_To_And_Rewrite (Typ, Operand);
+ Analyze_And_Resolve
+ (Operand, Typ, Suppress => Overflow_Check);
+
+ Analyze_And_Resolve (N, Target_Type);
+ goto Done;
+ end if;
+ end if;
+ end;
+ end if;
+
-- Do validity check if validity checking operands
if Validity_Checks_On and Validity_Check_Operands then
@@ -12329,6 +12339,7 @@ package body Exp_Ch4 is
and then Ekind (Etype (Operand_Acc)) = E_Anonymous_Access_Type
and then (Nkind (Original_Node (N)) /= N_Attribute_Reference
or else Attribute_Name (Original_Node (N)) = Name_Access)
+ and then not No_Dynamic_Accessibility_Checks_Enabled (N)
then
if not Comes_From_Source (N)
and then Nkind (Parent (N)) in N_Function_Call
@@ -12506,10 +12517,7 @@ package body Exp_Ch4 is
Conv : Node_Id;
begin
Make_Tag_Check (Class_Wide_Type (Actual_Targ_Typ));
- Conv :=
- Make_Unchecked_Type_Conversion (Loc,
- Subtype_Mark => New_Occurrence_Of (Target_Type, Loc),
- Expression => Relocate_Node (Expression (N)));
+ Conv := Unchecked_Convert_To (Target_Type, Expression (N));
Rewrite (N, Conv);
Analyze_And_Resolve (N, Target_Type);
end;
@@ -12589,6 +12597,13 @@ package body Exp_Ch4 is
if Is_Constrained (Target_Type) then
Apply_Length_Check (Operand, Target_Type);
else
+ -- If the object has an unconstrained array subtype with fixed
+ -- lower bound, then sliding to that bound may be needed.
+
+ if Is_Fixed_Lower_Bound_Array_Subtype (Target_Type) then
+ Expand_Sliding_Conversion (Operand, Target_Type);
+ end if;
+
Apply_Range_Check (Operand, Target_Type);
end if;
@@ -12667,17 +12682,7 @@ package body Exp_Ch4 is
-- At this stage, either the conversion node has been transformed into
-- some other equivalent expression, or left as a conversion that can be
- -- handled by Gigi, in the following cases:
-
- -- Conversions with no change of representation or type
-
- -- Numeric conversions involving integer, floating- and fixed-point
- -- values. Fixed-point values are allowed only if Conversion_OK is
- -- set, i.e. if the fixed-point values are to be treated as integers.
-
- -- No other conversions should be passed to Gigi
-
- -- Check: are these rules stated in sinfo??? if so, why restate here???
+ -- handled by Gigi.
-- The only remaining step is to generate a range check if we still have
-- a type conversion at this stage and Do_Range_Check is set. Note that
@@ -12742,7 +12747,16 @@ package body Exp_Ch4 is
-- guard is necessary to prevent infinite recursions when we generate
-- internal conversions for the purpose of checking predicates.
- if Predicate_Enabled (Target_Type)
+ -- A view conversion of a tagged object is an object and can appear
+ -- in an assignment context, in which case no predicate check applies
+ -- to the now-dead value.
+
+ if Nkind (Parent (N)) = N_Assignment_Statement
+ and then N = Name (Parent (N))
+ then
+ null;
+
+ elsif Predicate_Enabled (Target_Type)
and then Target_Type /= Operand_Type
and then Comes_From_Source (N)
then
@@ -12796,14 +12810,7 @@ package body Exp_Ch4 is
-- an Assignment_OK indication which must be propagated to the operand.
if Operand_Type = Target_Type then
-
- -- Code duplicates Expand_N_Unchecked_Expression above, factor???
-
- if Assignment_OK (N) then
- Set_Assignment_OK (Operand);
- end if;
-
- Rewrite (N, Relocate_Node (Operand));
+ Expand_N_Unchecked_Expression (N);
return;
end if;
@@ -12834,9 +12841,6 @@ package body Exp_Ch4 is
return;
end if;
- -- Otherwise force evaluation unless Assignment_OK flag is set (this
- -- flag indicates ??? More comments needed here)
-
if Assignment_OK (N) then
null;
else
@@ -13331,83 +13335,53 @@ package body Exp_Ch4 is
end if;
end Fixup_Universal_Fixed_Operation;
- ---------------------------------
- -- Has_Inferable_Discriminants --
- ---------------------------------
+ ------------------------
+ -- Get_Size_For_Range --
+ ------------------------
- function Has_Inferable_Discriminants (N : Node_Id) return Boolean is
+ function Get_Size_For_Range (Lo, Hi : Uint) return Uint is
- function Prefix_Is_Formal_Parameter (N : Node_Id) return Boolean;
- -- Determines whether the left-most prefix of a selected component is a
- -- formal parameter in a subprogram. Assumes N is a selected component.
+ function Is_OK_For_Range (Siz : Uint) return Boolean;
+ -- Return True if a signed integer with given size can cover Lo .. Hi
- --------------------------------
- -- Prefix_Is_Formal_Parameter --
- --------------------------------
+ --------------------------
+ -- Is_OK_For_Range --
+ --------------------------
- function Prefix_Is_Formal_Parameter (N : Node_Id) return Boolean is
- Sel_Comp : Node_Id;
+ function Is_OK_For_Range (Siz : Uint) return Boolean is
+ B : constant Uint := Uint_2 ** (Siz - 1);
begin
- -- Move to the left-most prefix by climbing up the tree
-
- Sel_Comp := N;
- while Present (Parent (Sel_Comp))
- and then Nkind (Parent (Sel_Comp)) = N_Selected_Component
- loop
- Sel_Comp := Parent (Sel_Comp);
- end loop;
-
- return Is_Formal (Entity (Prefix (Sel_Comp)));
- end Prefix_Is_Formal_Parameter;
+ -- Test B = 2 ** (size - 1) (can accommodate -B .. +(B - 1))
- -- Start of processing for Has_Inferable_Discriminants
+ return Lo >= -B and then Hi >= -B and then Lo < B and then Hi < B;
+ end Is_OK_For_Range;
begin
- -- For selected components, the subtype of the selector must be a
- -- constrained Unchecked_Union. If the component is subject to a
- -- per-object constraint, then the enclosing object must have inferable
- -- discriminants.
-
- if Nkind (N) = N_Selected_Component then
- if Has_Per_Object_Constraint (Entity (Selector_Name (N))) then
-
- -- A small hack. If we have a per-object constrained selected
- -- component of a formal parameter, return True since we do not
- -- know the actual parameter association yet.
+ -- This is (almost always) the size of Integer
- if Prefix_Is_Formal_Parameter (N) then
- return True;
-
- -- Otherwise, check the enclosing object and the selector
+ if Is_OK_For_Range (Uint_32) then
+ return Uint_32;
- else
- return Has_Inferable_Discriminants (Prefix (N))
- and then Has_Inferable_Discriminants (Selector_Name (N));
- end if;
+ -- Check 63
- -- The call to Has_Inferable_Discriminants will determine whether
- -- the selector has a constrained Unchecked_Union nominal type.
+ elsif Is_OK_For_Range (Uint_63) then
+ return Uint_63;
- else
- return Has_Inferable_Discriminants (Selector_Name (N));
- end if;
+ -- This is (almost always) the size of Long_Long_Integer
- -- A qualified expression has inferable discriminants if its subtype
- -- mark is a constrained Unchecked_Union subtype.
+ elsif Is_OK_For_Range (Uint_64) then
+ return Uint_64;
- elsif Nkind (N) = N_Qualified_Expression then
- return Is_Unchecked_Union (Etype (Subtype_Mark (N)))
- and then Is_Constrained (Etype (Subtype_Mark (N)));
+ -- Check 127
- -- For all other names, it is sufficient to have a constrained
- -- Unchecked_Union nominal subtype.
+ elsif Is_OK_For_Range (Uint_127) then
+ return Uint_127;
else
- return Is_Unchecked_Union (Base_Type (Etype (N)))
- and then Is_Constrained (Etype (N));
+ return Uint_128;
end if;
- end Has_Inferable_Discriminants;
+ end Get_Size_For_Range;
-------------------------------
-- Insert_Dereference_Action --
@@ -13722,9 +13696,6 @@ package body Exp_Ch4 is
-- do not need to generate an actual or formal generic part, just the
-- instantiated function itself.
- -- Perhaps we could have the actual generic available in the run-time,
- -- obtained by rtsfind, and actually expand a real instantiation ???
-
function Make_Array_Comparison_Op
(Typ : Entity_Id;
Nod : Node_Id) return Node_Id
@@ -14114,9 +14085,15 @@ package body Exp_Ch4 is
function Minimized_Eliminated_Overflow_Check (N : Node_Id) return Boolean is
begin
+ -- The MINIMIZED mode operates in Long_Long_Integer so we cannot use it
+ -- if the type of the expression is already larger.
+
return
Is_Signed_Integer_Type (Etype (N))
- and then Overflow_Check_Mode in Minimized_Or_Eliminated;
+ and then Overflow_Check_Mode in Minimized_Or_Eliminated
+ and then not (Overflow_Check_Mode = Minimized
+ and then
+ Esize (Etype (N)) > Standard_Long_Long_Integer_Size);
end Minimized_Eliminated_Overflow_Check;
----------------------------
@@ -14132,58 +14109,6 @@ package body Exp_Ch4 is
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;
-
- -- If the size of Typ is 128 then check 127
-
- elsif Tsiz = Uint_128 and then Is_OK_For_Range (Uint_127) then
- return Uint_127;
-
- else
- return Uint_128;
- end if;
- end Get_Size_For_Range;
-
-- Local variables
L : Node_Id;
@@ -15026,7 +14951,17 @@ package body Exp_Ch4 is
-- Hook := null;
-- end if;
+ -- Note that the value returned by Find_Hook_Context may be an operator
+ -- node, which is not a list member. We must locate the proper node in
+ -- in the tree after which to insert the finalization code.
+
else
+ while not Is_List_Member (Fin_Context) loop
+ Fin_Context := Parent (Fin_Context);
+ end loop;
+
+ pragma Assert (Present (Fin_Context));
+
Insert_Action_After (Fin_Context,
Make_Implicit_If_Statement (Obj_Decl,
Condition =>
@@ -15247,7 +15182,7 @@ package body Exp_Ch4 is
Selector_Name =>
New_Occurrence_Of (First_Tag_Component (Left_Type), Loc));
- if Is_Class_Wide_Type (Right_Type) or else Is_Interface (Left_Type) then
+ if Is_Class_Wide_Type (Right_Type) then
-- No need to issue a run-time check if we statically know that the
-- result of this membership test is always true. For example,
diff --git a/gcc/ada/exp_ch4.ads b/gcc/ada/exp_ch4.ads
index ed5e236..b1df4a0 100644
--- a/gcc/ada/exp_ch4.ads
+++ b/gcc/ada/exp_ch4.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute 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 4cae2ee..8ac9662 100644
--- a/gcc/ada/exp_ch5.adb
+++ b/gcc/ada/exp_ch5.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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,43 +23,50 @@
-- --
------------------------------------------------------------------------------
-with Aspects; use Aspects;
-with Atree; use Atree;
-with Checks; use Checks;
-with Debug; use Debug;
-with Einfo; use Einfo;
-with Elists; use Elists;
-with Exp_Aggr; use Exp_Aggr;
-with Exp_Ch6; use Exp_Ch6;
-with Exp_Ch7; use Exp_Ch7;
-with Exp_Ch11; use Exp_Ch11;
-with Exp_Dbug; use Exp_Dbug;
-with Exp_Pakd; use Exp_Pakd;
-with Exp_Tss; use Exp_Tss;
-with Exp_Util; use Exp_Util;
-with Inline; use Inline;
-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 Rtsfind; use Rtsfind;
-with Sinfo; use Sinfo;
-with Sem; use Sem;
-with Sem_Aux; use Sem_Aux;
-with Sem_Ch3; use Sem_Ch3;
-with Sem_Ch8; use Sem_Ch8;
-with Sem_Ch13; use Sem_Ch13;
-with Sem_Eval; use Sem_Eval;
-with Sem_Res; use Sem_Res;
-with Sem_Util; use Sem_Util;
-with Snames; use Snames;
-with Stand; use Stand;
-with Stringt; use Stringt;
-with Tbuild; use Tbuild;
-with Uintp; use Uintp;
-with Validsw; use Validsw;
+with Aspects; use Aspects;
+with Atree; use Atree;
+with Checks; use Checks;
+with Debug; use Debug;
+with Einfo; use Einfo;
+with Einfo.Entities; use Einfo.Entities;
+with Einfo.Utils; use Einfo.Utils;
+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;
+with Exp_Ch11; use Exp_Ch11;
+with Exp_Dbug; use Exp_Dbug;
+with Exp_Pakd; use Exp_Pakd;
+with Exp_Tss; use Exp_Tss;
+with Exp_Util; use Exp_Util;
+with Expander; use Expander;
+with Inline; use Inline;
+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 Rtsfind; use Rtsfind;
+with Sinfo; use Sinfo;
+with Sinfo.Nodes; use Sinfo.Nodes;
+with Sinfo.Utils; use Sinfo.Utils;
+with Sem; use Sem;
+with Sem_Aux; use Sem_Aux;
+with Sem_Ch3; use Sem_Ch3;
+with Sem_Ch8; use Sem_Ch8;
+with Sem_Ch13; use Sem_Ch13;
+with Sem_Eval; use Sem_Eval;
+with Sem_Res; use Sem_Res;
+with Sem_Util; use Sem_Util;
+with Snames; use Snames;
+with Stand; use Stand;
+with Stringt; use Stringt;
+with Tbuild; use Tbuild;
+with Ttypes; use Ttypes;
+with Uintp; use Uintp;
+with Validsw; use Validsw;
package body Exp_Ch5 is
@@ -121,8 +128,16 @@ package body Exp_Ch5 is
R_Type : Entity_Id;
Rev : Boolean) return Node_Id;
-- Alternative to Expand_Assign_Array_Loop for packed bitfields. Generates
- -- a call to the System.Bitfields.Copy_Bitfield, which is more efficient
- -- than copying component-by-component.
+ -- a call to System.Bitfields.Copy_Bitfield, which is more efficient than
+ -- copying component-by-component.
+
+ function Expand_Assign_Array_Bitfield_Fast
+ (N : Node_Id;
+ Larray : Entity_Id;
+ Rarray : Entity_Id) return Node_Id;
+ -- Alternative to Expand_Assign_Array_Bitfield. Generates a call to
+ -- System.Bitfields.Fast_Copy_Bitfield, which is more efficient than
+ -- Copy_Bitfield, but only works in restricted situations.
function Expand_Assign_Array_Loop_Or_Bitfield
(N : Node_Id;
@@ -132,8 +147,8 @@ package body Exp_Ch5 is
R_Type : Entity_Id;
Ndim : Pos;
Rev : Boolean) return Node_Id;
- -- Calls either Expand_Assign_Array_Loop or Expand_Assign_Array_Bitfield as
- -- appropriate.
+ -- Calls either Expand_Assign_Array_Loop, Expand_Assign_Array_Bitfield, or
+ -- Expand_Assign_Array_Bitfield_Fast as appropriate.
procedure Expand_Assign_Record (N : Node_Id);
-- N is an assignment of an untagged record value. This routine handles
@@ -1434,6 +1449,139 @@ package body Exp_Ch5 is
R_Addr, R_Bit, L_Addr, L_Bit, Size));
end Expand_Assign_Array_Bitfield;
+ ---------------------------------------
+ -- Expand_Assign_Array_Bitfield_Fast --
+ ---------------------------------------
+
+ function Expand_Assign_Array_Bitfield_Fast
+ (N : Node_Id;
+ Larray : Entity_Id;
+ Rarray : Entity_Id) return Node_Id
+ is
+ pragma Assert (not Change_Of_Representation (N));
+ -- This won't work, for example, to copy a packed array to an unpacked
+ -- array.
+
+ -- For L (A .. B) := R (C .. D), we generate:
+ --
+ -- L := Fast_Copy_Bitfield (R, <offset of R(C)>, L, <offset of L(A)>,
+ -- L (A .. B)'Length * L'Component_Size);
+ --
+ -- with L and R suitably uncheckedly converted to/from Val_2.
+ -- The offsets are from the start of L and R.
+
+ Loc : constant Source_Ptr := Sloc (N);
+
+ L_Typ : constant Entity_Id := Etype (Larray);
+ R_Typ : constant Entity_Id := Etype (Rarray);
+ -- The original type of the arrays
+
+ L_Val : constant Node_Id :=
+ Unchecked_Convert_To (RTE (RE_Val_2), Larray);
+ R_Val : constant Node_Id :=
+ Unchecked_Convert_To (RTE (RE_Val_2), Rarray);
+ -- Converted values of left- and right-hand sides
+
+ L_Small : constant Boolean :=
+ Known_Static_RM_Size (L_Typ)
+ and then RM_Size (L_Typ) < Standard_Long_Long_Integer_Size;
+ R_Small : constant Boolean :=
+ Known_Static_RM_Size (R_Typ)
+ and then RM_Size (R_Typ) < Standard_Long_Long_Integer_Size;
+ -- Whether the above unchecked conversions need to be padded with zeros
+
+ C_Size : constant Uint := Component_Size (L_Typ);
+ pragma Assert (C_Size >= 1);
+ pragma Assert (C_Size = Component_Size (R_Typ));
+
+ Larray_Bounds : constant Range_Values :=
+ Get_Index_Bounds (First_Index (L_Typ));
+ L_Bounds : constant Range_Values :=
+ (if Nkind (Name (N)) = N_Slice
+ then Get_Index_Bounds (Discrete_Range (Name (N)))
+ else Larray_Bounds);
+ -- If the left-hand side is A (First..Last), Larray_Bounds is A'Range,
+ -- and L_Bounds is First..Last. If it's not a slice, we treat it like
+ -- a slice starting at A'First.
+
+ L_Bit : constant Node_Id :=
+ Make_Integer_Literal
+ (Loc, (L_Bounds.First - Larray_Bounds.First) * C_Size);
+
+ Rarray_Bounds : constant Range_Values :=
+ Get_Index_Bounds (First_Index (R_Typ));
+ R_Bounds : constant Range_Values :=
+ (if Nkind (Expression (N)) = N_Slice
+ then Get_Index_Bounds (Discrete_Range (Expression (N)))
+ else Rarray_Bounds);
+
+ R_Bit : constant Node_Id :=
+ Make_Integer_Literal
+ (Loc, (R_Bounds.First - Rarray_Bounds.First) * C_Size);
+
+ Size : constant Node_Id :=
+ Make_Op_Multiply (Loc,
+ Make_Attribute_Reference (Loc,
+ Prefix =>
+ Duplicate_Subexpr (Name (N), True),
+ Attribute_Name => Name_Length),
+ Make_Attribute_Reference (Loc,
+ Prefix =>
+ Duplicate_Subexpr (Larray, True),
+ Attribute_Name => Name_Component_Size));
+
+ L_Arg, R_Arg, Call : Node_Id;
+
+ begin
+ -- The semantics of unchecked conversion between bit-packed arrays that
+ -- are implemented as modular types and modular types is precisely that
+ -- of unchecked conversion between modular types. Therefore, if it needs
+ -- to be padded with zeros, the padding must be moved to the correct end
+ -- for memory order because System.Bitfield_Utils works in memory order.
+
+ if L_Small
+ and then (Bytes_Big_Endian xor Reverse_Storage_Order (L_Typ))
+ then
+ L_Arg := Make_Op_Shift_Left (Loc,
+ Left_Opnd => L_Val,
+ Right_Opnd => Make_Integer_Literal (Loc,
+ Standard_Long_Long_Integer_Size - RM_Size (L_Typ)));
+ else
+ L_Arg := L_Val;
+ end if;
+
+ if R_Small
+ and then (Bytes_Big_Endian xor Reverse_Storage_Order (R_Typ))
+ then
+ R_Arg := Make_Op_Shift_Left (Loc,
+ Left_Opnd => R_Val,
+ Right_Opnd => Make_Integer_Literal (Loc,
+ Standard_Long_Long_Integer_Size - RM_Size (R_Typ)));
+ else
+ R_Arg := R_Val;
+ end if;
+
+ Call := Make_Function_Call (Loc,
+ Name => New_Occurrence_Of (RTE (RE_Fast_Copy_Bitfield), Loc),
+ Parameter_Associations => New_List (
+ R_Arg, R_Bit, L_Arg, L_Bit, Size));
+
+ -- Conversely, the final unchecked conversion must take significant bits
+
+ if L_Small
+ and then (Bytes_Big_Endian xor Reverse_Storage_Order (L_Typ))
+ then
+ Call := Make_Op_Shift_Right (Loc,
+ Left_Opnd => Call,
+ Right_Opnd => Make_Integer_Literal (Loc,
+ Standard_Long_Long_Integer_Size - RM_Size (L_Typ)));
+ end if;
+
+ return Make_Assignment_Statement (Loc,
+ Name => Duplicate_Subexpr (Larray, True),
+ Expression => Unchecked_Convert_To (L_Typ, Call));
+ end Expand_Assign_Array_Bitfield_Fast;
+
------------------------------------------
-- Expand_Assign_Array_Loop_Or_Bitfield --
------------------------------------------
@@ -1447,37 +1595,42 @@ package body Exp_Ch5 is
Ndim : Pos;
Rev : Boolean) return Node_Id
is
+
+ L : constant Node_Id := Name (N);
+ R : constant Node_Id := Expression (N);
+ -- Left- and right-hand sides of the assignment statement
+
Slices : constant Boolean :=
- Nkind (Name (N)) = N_Slice or else Nkind (Expression (N)) = N_Slice;
+ Nkind (L) = N_Slice or else Nkind (R) = N_Slice;
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 (Prefix (Name (N))) in
+ Nkind (L) = N_Slice
+ and then Nkind (Prefix (L)) 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 (Prefix (Expression (N))) in
+ Nkind (R) = N_Slice
+ and then Nkind (Prefix (R)) 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
- -- doesn't work for reversed storage orders. It is efficient for slices
- -- of bit-packed arrays. Copy_Bitfield can read and write bits that are
- -- not part of the objects being copied, so we don't want to use it if
- -- there are volatile or independent components. If the Prefix of the
- -- slice is a component or slice, then it might be a part of an object
- -- with some other volatile or independent components, so we disable the
- -- optimization in that case as well. We could complicate this code by
- -- actually looking for such volatile and independent components.
+ -- Determine whether Copy_Bitfield or Fast_Copy_Bitfield is appropriate
+ -- (will work, and will be more efficient than component-by-component
+ -- copy). Copy_Bitfield doesn't work for reversed storage orders. It is
+ -- efficient for slices of bit-packed arrays. Copy_Bitfield can read and
+ -- write bits that are not part of the objects being copied, so we don't
+ -- want to use it if there are volatile or independent components. If
+ -- the Prefix of the slice is a component or slice, then it might be a
+ -- part of an object with some other volatile or independent components,
+ -- so we disable the optimization in that case as well. We could
+ -- complicate this code by actually looking for such volatile and
+ -- independent components.
if Is_Bit_Packed_Array (L_Type)
and then Is_Bit_Packed_Array (R_Type)
and then not Reverse_Storage_Order (L_Type)
and then not Reverse_Storage_Order (R_Type)
and then Ndim = 1
- and then not Rev
and then Slices
and then not Has_Volatile_Component (L_Type)
and then not Has_Volatile_Component (R_Type)
@@ -1485,14 +1638,88 @@ package body Exp_Ch5 is
and then not Has_Independent_Components (R_Type)
and then not L_Prefix_Comp
and then not R_Prefix_Comp
- and then RTE_Available (RE_Copy_Bitfield)
then
- return Expand_Assign_Array_Bitfield
- (N, Larray, Rarray, L_Type, R_Type, Rev);
- else
- return Expand_Assign_Array_Loop
- (N, Larray, Rarray, L_Type, R_Type, Ndim, Rev);
+ -- Here if Copy_Bitfield can work (except for the Rev test below).
+ -- Determine whether to call Fast_Copy_Bitfield instead. If we
+ -- are assigning slices, and all the relevant bounds are known at
+ -- compile time, and the maximum object size is no greater than
+ -- System.Bitfields.Val_Bits (i.e. Long_Long_Integer'Size / 2), and
+ -- we don't have enumeration representation clauses, we can use
+ -- Fast_Copy_Bitfield. The max size test is to ensure that the slices
+ -- cannot overlap boundaries not supported by Fast_Copy_Bitfield.
+
+ pragma Assert (Known_Component_Size (Base_Type (L_Type)));
+ pragma Assert (Known_Component_Size (Base_Type (R_Type)));
+
+ -- Note that L_Type and R_Type do not necessarily have the same base
+ -- type, because of array type conversions. Hence the need to check
+ -- various properties of both.
+
+ if Compile_Time_Known_Bounds (Base_Type (L_Type))
+ and then Compile_Time_Known_Bounds (Base_Type (R_Type))
+ then
+ declare
+ Left_Base_Index : constant Entity_Id :=
+ First_Index (Base_Type (L_Type));
+ Left_Base_Range : constant Range_Values :=
+ Get_Index_Bounds (Left_Base_Index);
+
+ Right_Base_Index : constant Entity_Id :=
+ First_Index (Base_Type (R_Type));
+ Right_Base_Range : constant Range_Values :=
+ Get_Index_Bounds (Right_Base_Index);
+
+ Known_Left_Slice_Low : constant Boolean :=
+ (if Nkind (L) = N_Slice
+ then Compile_Time_Known_Value
+ (Get_Index_Bounds (Discrete_Range (L)).First));
+ Known_Right_Slice_Low : constant Boolean :=
+ (if Nkind (R) = N_Slice
+ then Compile_Time_Known_Value
+ (Get_Index_Bounds (Discrete_Range (R)).Last));
+
+ Val_Bits : constant Pos := Standard_Long_Long_Integer_Size / 2;
+
+ begin
+ if Left_Base_Range.Last - Left_Base_Range.First < Val_Bits
+ and then Right_Base_Range.Last - Right_Base_Range.First <
+ Val_Bits
+ and then Known_Esize (L_Type)
+ and then Known_Esize (R_Type)
+ and then Known_Left_Slice_Low
+ and then Known_Right_Slice_Low
+ and then Compile_Time_Known_Value
+ (Get_Index_Bounds (First_Index (Etype (Larray))).First)
+ and then Compile_Time_Known_Value
+ (Get_Index_Bounds (First_Index (Etype (Rarray))).First)
+ and then
+ not (Is_Enumeration_Type (Etype (Left_Base_Index))
+ and then Has_Enumeration_Rep_Clause
+ (Etype (Left_Base_Index)))
+ and then RTE_Available (RE_Fast_Copy_Bitfield)
+ then
+ pragma Assert (Esize (L_Type) /= 0);
+ pragma Assert (Esize (R_Type) /= 0);
+
+ return Expand_Assign_Array_Bitfield_Fast (N, Larray, Rarray);
+ end if;
+ end;
+ end if;
+
+ -- Fast_Copy_Bitfield can work if Rev is True, because the data is
+ -- passed and returned by copy. Copy_Bitfield cannot.
+
+ if not Rev and then RTE_Available (RE_Copy_Bitfield) then
+ return Expand_Assign_Array_Bitfield
+ (N, Larray, Rarray, L_Type, R_Type, Rev);
+ end if;
end if;
+
+ -- Here if we did not return above, with Fast_Copy_Bitfield or
+ -- Copy_Bitfield.
+
+ return Expand_Assign_Array_Loop
+ (N, Larray, Rarray, L_Type, R_Type, Ndim, Rev);
end Expand_Assign_Array_Loop_Or_Bitfield;
--------------------------
@@ -2544,7 +2771,9 @@ package body Exp_Ch5 is
(Entity (Lhs)), Loc),
Expression =>
Accessibility_Level
- (Rhs, Dynamic_Level));
+ (Expr => Rhs,
+ Level => Dynamic_Level,
+ Allow_Alt_Model => False));
begin
if not Accessibility_Checks_Suppressed (Entity (Lhs)) then
@@ -3027,7 +3256,444 @@ package body Exp_Ch5 is
Choice : Node_Id;
Chlist : List_Id;
+ function Expand_General_Case_Statement return Node_Id;
+ -- Expand a case statement whose selecting expression is not discrete
+
+ -----------------------------------
+ -- Expand_General_Case_Statement --
+ -----------------------------------
+
+ function Expand_General_Case_Statement return Node_Id is
+ -- expand into a block statement
+
+ Selector : constant Entity_Id :=
+ Make_Temporary (Loc, 'J');
+
+ function Selector_Subtype_Mark return Node_Id is
+ (New_Occurrence_Of (Etype (Expr), Loc));
+
+ Renamed_Name : constant Node_Id :=
+ (if Is_Name_Reference (Expr)
+ then Expr
+ else Make_Qualified_Expression (Loc,
+ Subtype_Mark => Selector_Subtype_Mark,
+ Expression => Expr));
+
+ Selector_Decl : constant Node_Id :=
+ Make_Object_Renaming_Declaration (Loc,
+ Defining_Identifier => Selector,
+ Subtype_Mark => Selector_Subtype_Mark,
+ Name => Renamed_Name);
+
+ First_Alt : constant Node_Id := First (Alternatives (N));
+
+ function Choice_Index_Decl_If_Needed return Node_Id;
+ -- If we are going to need a choice index object (that is, if
+ -- Multidefined_Bindings is true for at least one of the case
+ -- alternatives), then create and return that object's declaration.
+ -- Otherwise, return Empty; no need for a decl in that case because
+ -- it would never be referenced.
+
+ ---------------------------------
+ -- Choice_Index_Decl_If_Needed --
+ ---------------------------------
+
+ function Choice_Index_Decl_If_Needed return Node_Id is
+ Alt : Node_Id := First_Alt;
+ begin
+ while Present (Alt) loop
+ if Multidefined_Bindings (Alt) then
+ return Make_Object_Declaration
+ (Sloc => Loc,
+ Defining_Identifier =>
+ Make_Temporary (Loc, 'K'),
+ Object_Definition =>
+ New_Occurrence_Of (Standard_Positive, Loc));
+ end if;
+
+ Next (Alt);
+ end loop;
+ return Empty; -- decl not needed
+ end Choice_Index_Decl_If_Needed;
+
+ Choice_Index_Decl : constant Node_Id := Choice_Index_Decl_If_Needed;
+
+ function Pattern_Match
+ (Pattern : Node_Id;
+ Object : Node_Id;
+ Choice_Index : Natural;
+ Alt : Node_Id;
+ Suppress_Choice_Index_Update : Boolean := False) return Node_Id;
+ -- Returns a Boolean-valued expression indicating a pattern match
+ -- for a given pattern and object. If Choice_Index is nonzero,
+ -- then Choice_Index is assigned to Choice_Index_Decl (unless
+ -- Suppress_Choice_Index_Update is specified, which should only
+ -- be the case for a recursive call where the caller has already
+ -- taken care of the update). Pattern occurs as a choice (or as a
+ -- subexpression of a choice) of the case statement alternative Alt.
+
+ function Top_Level_Pattern_Match_Condition
+ (Alt : Node_Id) return Node_Id;
+ -- Returns a Boolean-valued expression indicating a pattern match
+ -- for the given alternative's list of choices.
+
+ -------------------
+ -- Pattern_Match --
+ -------------------
+
+ function Pattern_Match
+ (Pattern : Node_Id;
+ Object : Node_Id;
+ Choice_Index : Natural;
+ Alt : Node_Id;
+ Suppress_Choice_Index_Update : Boolean := False) return Node_Id
+ is
+ function Update_Choice_Index return Node_Id is (
+ Make_Assignment_Statement (Loc,
+ Name =>
+ New_Occurrence_Of
+ (Defining_Identifier (Choice_Index_Decl), Loc),
+ Expression => Make_Integer_Literal (Loc, Pos (Choice_Index))));
+
+ function PM
+ (Pattern : Node_Id;
+ Object : Node_Id;
+ Choice_Index : Natural := Pattern_Match.Choice_Index;
+ Alt : Node_Id := Pattern_Match.Alt;
+ Suppress_Choice_Index_Update : Boolean :=
+ Pattern_Match.Suppress_Choice_Index_Update) return Node_Id
+ renames Pattern_Match;
+ -- convenient rename for recursive calls
+
+ begin
+ if Choice_Index /= 0 and not Suppress_Choice_Index_Update then
+ pragma Assert (Present (Choice_Index_Decl));
+
+ -- Add Choice_Index update as a side effect of evaluating
+ -- this condition and try again, this time suppressing
+ -- Choice_Index update.
+
+ return Make_Expression_With_Actions (Loc,
+ Actions => New_List (Update_Choice_Index),
+ Expression =>
+ PM (Pattern, Object,
+ Suppress_Choice_Index_Update => True));
+ end if;
+
+ if Nkind (Pattern) in N_Has_Etype
+ and then Is_Discrete_Type (Etype (Pattern))
+ and then Compile_Time_Known_Value (Pattern)
+ then
+ declare
+ Val : Node_Id;
+ begin
+ if Is_Enumeration_Type (Etype (Pattern)) then
+ Val := Get_Enum_Lit_From_Pos
+ (Etype (Pattern), Expr_Value (Pattern), Loc);
+ else
+ Val := Make_Integer_Literal (Loc, Expr_Value (Pattern));
+ end if;
+ return Make_Op_Eq (Loc, Object, Val);
+ end;
+ end if;
+
+ case Nkind (Pattern) is
+ when N_Aggregate =>
+ return Result : Node_Id :=
+ New_Occurrence_Of (Standard_True, Loc)
+ do
+ if Is_Array_Type (Etype (Pattern)) then
+ -- Calling Error_Msg_N during expansion is usually a
+ -- mistake but is ok for an "unimplemented" message.
+ Error_Msg_N
+ ("array-valued case choices unimplemented",
+ Pattern);
+ return;
+ end if;
+
+ -- positional notation should have been normalized
+ pragma Assert (No (Expressions (Pattern)));
+
+ declare
+ Component_Assoc : Node_Id
+ := First (Component_Associations (Pattern));
+ Choice : Node_Id;
+
+ function Subobject return Node_Id is
+ (Make_Selected_Component (Loc,
+ Prefix => New_Copy_Tree (Object),
+ Selector_Name => New_Occurrence_Of
+ (Entity (Choice), Loc)));
+ begin
+ while Present (Component_Assoc) loop
+ Choice := First (Choices (Component_Assoc));
+ while Present (Choice) loop
+ pragma Assert
+ (Is_Entity_Name (Choice)
+ and then Ekind (Entity (Choice))
+ in E_Discriminant | E_Component);
+
+ if Box_Present (Component_Assoc) then
+ -- Box matches anything
+
+ pragma Assert
+ (No (Expression (Component_Assoc)));
+ else
+ Result := Make_And_Then (Loc,
+ Left_Opnd => Result,
+ Right_Opnd =>
+ PM (Pattern =>
+ Expression
+ (Component_Assoc),
+ Object => Subobject));
+ end if;
+
+ -- If this component association defines
+ -- (in the case where the pattern matches)
+ -- the value of a binding object, then
+ -- prepend to the statement list for this
+ -- alternative an assignment to the binding
+ -- object. This assignment will be conditional
+ -- if there is more than one choice.
+
+ if Binding_Chars (Component_Assoc) /= No_Name
+ then
+ declare
+ Decl_Chars : constant Name_Id :=
+ Binding_Chars (Component_Assoc);
+
+ Block_Stmt : constant Node_Id :=
+ First (Statements (Alt));
+ pragma Assert
+ (Nkind (Block_Stmt) = N_Block_Statement);
+ pragma Assert (No (Next (Block_Stmt)));
+ Decl : Node_Id
+ := First (Declarations (Block_Stmt));
+ Def_Id : Node_Id := Empty;
+
+ Assignment_Stmt : Node_Id;
+ Condition : Node_Id;
+ Prepended_Stmt : Node_Id;
+ begin
+ -- find the variable to be modified
+ while No (Def_Id) or else
+ Chars (Def_Id) /= Decl_Chars
+ loop
+ Def_Id := Defining_Identifier (Decl);
+ Next (Decl);
+ end loop;
+
+ Assignment_Stmt :=
+ Make_Assignment_Statement (Loc,
+ Name => New_Occurrence_Of
+ (Def_Id, Loc),
+ Expression => Subobject);
+
+ -- conditional if multiple choices
+
+ if Present (Choice_Index_Decl) then
+ Condition :=
+ Make_Op_Eq (Loc,
+ New_Occurrence_Of
+ (Defining_Identifier
+ (Choice_Index_Decl), Loc),
+ Make_Integer_Literal
+ (Loc, Int (Choice_Index)));
+
+ Prepended_Stmt :=
+ Make_If_Statement (Loc,
+ Condition => Condition,
+ Then_Statements =>
+ New_List (Assignment_Stmt));
+ else
+ -- assignment is unconditional
+ Prepended_Stmt := Assignment_Stmt;
+ end if;
+
+ declare
+ HSS : constant Node_Id :=
+ Handled_Statement_Sequence
+ (Block_Stmt);
+ begin
+ Prepend (Prepended_Stmt,
+ Statements (HSS));
+
+ Set_Analyzed (Block_Stmt, False);
+ Set_Analyzed (HSS, False);
+ end;
+ end;
+ end if;
+
+ Next (Choice);
+ end loop;
+
+ Next (Component_Assoc);
+ end loop;
+ end;
+ end return;
+
+ when N_Qualified_Expression =>
+ -- Make a copy for one of the two uses of Object; the choice
+ -- of where to use the original and where to use the copy
+ -- is arbitrary.
+
+ return Make_And_Then (Loc,
+ Left_Opnd => Make_In (Loc,
+ Left_Opnd => New_Copy_Tree (Object),
+ Right_Opnd => New_Copy_Tree (Subtype_Mark (Pattern))),
+ Right_Opnd =>
+ PM (Pattern => Expression (Pattern),
+ Object => Object));
+
+ when N_Identifier | N_Expanded_Name =>
+ if Is_Type (Entity (Pattern)) then
+ return Make_In (Loc,
+ Left_Opnd => Object,
+ Right_Opnd => New_Occurrence_Of
+ (Entity (Pattern), Loc));
+ end if;
+
+ when N_Others_Choice =>
+ return New_Occurrence_Of (Standard_True, Loc);
+
+ when N_Type_Conversion =>
+ -- aggregate expansion sometimes introduces conversions
+ if not Comes_From_Source (Pattern)
+ and then Base_Type (Etype (Pattern))
+ = Base_Type (Etype (Expression (Pattern)))
+ then
+ return PM (Expression (Pattern), Object);
+ end if;
+
+ when others =>
+ null;
+ end case;
+
+ -- Avoid cascading errors
+ pragma Assert (Serious_Errors_Detected > 0);
+ return New_Occurrence_Of (Standard_True, Loc);
+ end Pattern_Match;
+
+ ---------------------------------------
+ -- Top_Level_Pattern_Match_Condition --
+ ---------------------------------------
+
+ function Top_Level_Pattern_Match_Condition
+ (Alt : Node_Id) return Node_Id
+ is
+ Top_Level_Object : constant Node_Id :=
+ New_Occurrence_Of (Selector, Loc);
+
+ Choices : constant List_Id := Discrete_Choices (Alt);
+
+ First_Choice : constant Node_Id := First (Choices);
+ Subsequent : Node_Id := Next (First_Choice);
+
+ Choice_Index : Natural := 0;
+ begin
+ if Multidefined_Bindings (Alt) then
+ Choice_Index := 1;
+ end if;
+
+ return Result : Node_Id :=
+ Pattern_Match (Pattern => First_Choice,
+ Object => Top_Level_Object,
+ Choice_Index => Choice_Index,
+ Alt => Alt)
+ do
+ while Present (Subsequent) loop
+ if Choice_Index /= 0 then
+ Choice_Index := Choice_Index + 1;
+ end if;
+
+ Result := Make_Or_Else (Loc,
+ Left_Opnd => Result,
+ Right_Opnd => Pattern_Match
+ (Pattern => Subsequent,
+ Object => Top_Level_Object,
+ Choice_Index => Choice_Index,
+ Alt => Alt));
+ Subsequent := Next (Subsequent);
+ end loop;
+ end return;
+ end Top_Level_Pattern_Match_Condition;
+
+ function Elsif_Parts return List_Id;
+ -- Process subsequent alternatives
+
+ -----------------
+ -- Elsif_Parts --
+ -----------------
+
+ function Elsif_Parts return List_Id is
+ Alt : Node_Id := First_Alt;
+ Result : constant List_Id := New_List;
+ begin
+ loop
+ Alt := Next (Alt);
+ exit when No (Alt);
+
+ Append (Make_Elsif_Part (Loc,
+ Condition => Top_Level_Pattern_Match_Condition (Alt),
+ Then_Statements => Statements (Alt)),
+ Result);
+ end loop;
+ return Result;
+ end Elsif_Parts;
+
+ function Else_Statements return List_Id;
+ -- Returns a "raise Constraint_Error" statement if
+ -- exception propagate is permitted and No_List otherwise.
+
+ ---------------------
+ -- Else_Statements --
+ ---------------------
+
+ function Else_Statements return List_Id is
+ begin
+ if Restriction_Active (No_Exception_Propagation) then
+ return No_List;
+ else
+ return New_List (Make_Raise_Constraint_Error (Loc,
+ Reason => CE_Invalid_Data));
+ end if;
+ end Else_Statements;
+
+ -- Local constants
+
+ If_Stmt : constant Node_Id :=
+ Make_If_Statement (Loc,
+ Condition => Top_Level_Pattern_Match_Condition (First_Alt),
+ Then_Statements => Statements (First_Alt),
+ Elsif_Parts => Elsif_Parts,
+ Else_Statements => Else_Statements);
+
+ Declarations : constant List_Id := New_List (Selector_Decl);
+
+ -- Start of processing for Expand_General_Case_Statment
+
+ begin
+ if Present (Choice_Index_Decl) then
+ Append_To (Declarations, Choice_Index_Decl);
+ end if;
+
+ return Make_Block_Statement (Loc,
+ Declarations => Declarations,
+ Handled_Statement_Sequence =>
+ Make_Handled_Sequence_Of_Statements (Loc,
+ Statements => New_List (If_Stmt)));
+ end Expand_General_Case_Statement;
+
+ -- Start of processing for Expand_N_Case_Statement
+
begin
+ if Extensions_Allowed and then not Is_Discrete_Type (Etype (Expr)) then
+ Rewrite (N, Expand_General_Case_Statement);
+ Analyze (N);
+ Expand (N);
+ return;
+ end if;
+
-- Check for the situation where we know at compile time which branch
-- will be taken.
@@ -3403,7 +4069,7 @@ package body Exp_Ch5 is
Analyze (Init_Decl);
Init_Name := Defining_Identifier (Init_Decl);
- Set_Ekind (Init_Name, E_Loop_Parameter);
+ Mutate_Ekind (Init_Name, E_Loop_Parameter);
-- The cursor was marked as a loop parameter to prevent user assignments
-- to it, however this renders the advancement step illegal as it is not
@@ -3440,7 +4106,6 @@ package body Exp_Ch5 is
Make_Defining_Identifier (Loc,
Chars => New_External_Name (Chars (Element), 'C'));
Elmt_Decl : Node_Id;
- Elmt_Ref : Node_Id;
Element_Op : constant Entity_Id :=
Get_Iterable_Type_Primitive (Container_Typ, Name_Element);
@@ -3451,19 +4116,10 @@ package body Exp_Ch5 is
begin
-- For an element iterator, the Element aspect must be present,
- -- (this is checked during analysis) and the expansion takes the form:
+ -- (this is checked during analysis).
- -- Cursor : Cursor_Type := First (Container);
- -- Elmt : Element_Type;
- -- while Has_Element (Cursor, Container) loop
- -- Elmt := Element (Container, Cursor);
- -- <original loop statements>
- -- Cursor := Next (Container, Cursor);
- -- end loop;
-
- -- However this expansion is not legal if the element is indefinite.
- -- In that case we create a block to hold a variable declaration
- -- initialized with a call to Element, and generate:
+ -- We create a block to hold a variable declaration initialized with
+ -- a call to Element, and generate:
-- Cursor : Cursor_Type := First (Container);
-- while Has_Element (Cursor, Container) loop
@@ -3479,7 +4135,7 @@ package body Exp_Ch5 is
(N, Container, Cursor, Init, Advance, New_Loop);
Append_To (Stats, Advance);
- Set_Ekind (Cursor, E_Variable);
+ Mutate_Ekind (Cursor, E_Variable);
Insert_Action (N, Init);
-- The loop parameter is declared by an object declaration, but within
@@ -3495,48 +4151,20 @@ package body Exp_Ch5 is
Defining_Identifier => Element,
Object_Definition => New_Occurrence_Of (Etype (Element_Op), Loc));
- if not Is_Constrained (Etype (Element_Op)) then
- Set_Expression (Elmt_Decl,
- Make_Function_Call (Loc,
- Name => New_Occurrence_Of (Element_Op, Loc),
- Parameter_Associations => New_List (
- Convert_To_Iterable_Type (Container, Loc),
- New_Occurrence_Of (Cursor, Loc))));
-
- Set_Statements (New_Loop,
- New_List
- (Make_Block_Statement (Loc,
- Declarations => New_List (Elmt_Decl),
- Handled_Statement_Sequence =>
- Make_Handled_Sequence_Of_Statements (Loc,
- Statements => Stats))));
-
- else
- Elmt_Ref :=
- Make_Assignment_Statement (Loc,
- Name => New_Occurrence_Of (Element, Loc),
- Expression =>
- Make_Function_Call (Loc,
- Name => New_Occurrence_Of (Element_Op, Loc),
- Parameter_Associations => New_List (
- Convert_To_Iterable_Type (Container, Loc),
- New_Occurrence_Of (Cursor, Loc))));
-
- Prepend (Elmt_Ref, Stats);
-
- -- The element is assignable in the expanded code
-
- Set_Assignment_OK (Name (Elmt_Ref));
-
- -- The loop is rewritten as a block, to hold the element declaration
-
- New_Loop :=
- Make_Block_Statement (Loc,
- Declarations => New_List (Elmt_Decl),
+ Set_Expression (Elmt_Decl,
+ Make_Function_Call (Loc,
+ Name => New_Occurrence_Of (Element_Op, Loc),
+ Parameter_Associations => New_List (
+ Convert_To_Iterable_Type (Container, Loc),
+ New_Occurrence_Of (Cursor, Loc))));
+
+ Set_Statements (New_Loop,
+ New_List
+ (Make_Block_Statement (Loc,
+ Declarations => New_List (Elmt_Decl),
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
- Statements => New_List (New_Loop)));
- end if;
+ Statements => Stats))));
-- The element is only modified in expanded code, so it appears as
-- unassigned to the warning machinery. We must suppress this spurious
@@ -3548,12 +4176,29 @@ package body Exp_Ch5 is
Analyze (N);
end Expand_Formal_Container_Element_Loop;
+ ----------------------------------
+ -- Expand_N_Goto_When_Statement --
+ ----------------------------------
+
+ procedure Expand_N_Goto_When_Statement (N : Node_Id) is
+ Loc : constant Source_Ptr := Sloc (N);
+ begin
+ Rewrite (N,
+ Make_If_Statement (Loc,
+ Condition => Condition (N),
+ Then_Statements => New_List (
+ Make_Goto_Statement (Loc,
+ Name => Name (N)))));
+
+ Analyze (N);
+ end Expand_N_Goto_When_Statement;
+
---------------------------
-- Expand_N_If_Statement --
---------------------------
-- First we deal with the case of C and Fortran convention boolean values,
- -- with zero/non-zero semantics.
+ -- with zero/nonzero semantics.
-- Second, we deal with the obvious rewriting for the cases where the
-- condition of the IF is known at compile time to be True or False.
@@ -3788,62 +4433,58 @@ package body Exp_Ch5 is
-- return not (expression);
- -- Only do these optimizations if we are at least at -O1 level and
- -- do not do them if control flow optimizations are suppressed.
+ -- Do these optimizations only for internally generated code and only
+ -- when -fpreserve-control-flow isn't set, to preserve the original
+ -- source control flow.
- if Optimization_Level > 0
+ if not Comes_From_Source (N)
and then not Opt.Suppress_Control_Flow_Optimizations
+ and then Nkind (N) = N_If_Statement
+ and then No (Elsif_Parts (N))
+ and then Present (Else_Statements (N))
+ and then List_Length (Then_Statements (N)) = 1
+ and then List_Length (Else_Statements (N)) = 1
then
- if Nkind (N) = N_If_Statement
- and then No (Elsif_Parts (N))
- and then Present (Else_Statements (N))
- and then List_Length (Then_Statements (N)) = 1
- and then List_Length (Else_Statements (N)) = 1
- then
- declare
- Then_Stm : constant Node_Id := First (Then_Statements (N));
- Else_Stm : constant Node_Id := First (Else_Statements (N));
+ declare
+ Then_Stm : constant Node_Id := First (Then_Statements (N));
+ Else_Stm : constant Node_Id := First (Else_Statements (N));
- begin
- if Nkind (Then_Stm) = N_Simple_Return_Statement
+ Then_Expr : Node_Id;
+ Else_Expr : Node_Id;
+
+ begin
+ if Nkind (Then_Stm) = N_Simple_Return_Statement
+ and then
+ Nkind (Else_Stm) = N_Simple_Return_Statement
+ then
+ Then_Expr := Expression (Then_Stm);
+ Else_Expr := Expression (Else_Stm);
+
+ if Nkind (Then_Expr) in N_Expanded_Name | N_Identifier
and then
- Nkind (Else_Stm) = N_Simple_Return_Statement
+ Nkind (Else_Expr) in N_Expanded_Name | N_Identifier
then
- declare
- Then_Expr : constant Node_Id := Expression (Then_Stm);
- Else_Expr : constant Node_Id := Expression (Else_Stm);
+ if Entity (Then_Expr) = Standard_True
+ and then Entity (Else_Expr) = Standard_False
+ then
+ Rewrite (N,
+ Make_Simple_Return_Statement (Loc,
+ Expression => Relocate_Node (Condition (N))));
+ Analyze (N);
- begin
- if Nkind (Then_Expr) in N_Expanded_Name | N_Identifier
- and then
- Nkind (Else_Expr) in N_Expanded_Name | N_Identifier
- then
- if Entity (Then_Expr) = Standard_True
- and then Entity (Else_Expr) = Standard_False
- then
- Rewrite (N,
- Make_Simple_Return_Statement (Loc,
- Expression => Relocate_Node (Condition (N))));
- Analyze (N);
- return;
-
- elsif Entity (Then_Expr) = Standard_False
- and then Entity (Else_Expr) = Standard_True
- then
- Rewrite (N,
- Make_Simple_Return_Statement (Loc,
- Expression =>
- Make_Op_Not (Loc,
- Right_Opnd =>
- Relocate_Node (Condition (N)))));
- Analyze (N);
- return;
- end if;
- end if;
- end;
+ elsif Entity (Then_Expr) = Standard_False
+ and then Entity (Else_Expr) = Standard_True
+ then
+ Rewrite (N,
+ Make_Simple_Return_Statement (Loc,
+ Expression =>
+ Make_Op_Not (Loc,
+ Right_Opnd => Relocate_Node (Condition (N)))));
+ Analyze (N);
+ end if;
end if;
- end;
- end if;
+ end if;
+ end;
end if;
end Expand_N_If_Statement;
@@ -3900,7 +4541,7 @@ package body Exp_Ch5 is
begin
if Present (Iterator_Filter (I_Spec)) then
- pragma Assert (Ada_Version >= Ada_2020);
+ pragma Assert (Ada_Version >= Ada_2022);
Stats := New_List (Make_If_Statement (Loc,
Condition => Iterator_Filter (I_Spec),
Then_Statements => Stats));
@@ -4201,7 +4842,7 @@ package body Exp_Ch5 is
begin
if Present (Iterator_Filter (I_Spec)) then
- pragma Assert (Ada_Version >= Ada_2020);
+ pragma Assert (Ada_Version >= Ada_2022);
Stats := New_List (Make_If_Statement (Loc,
Condition => Iterator_Filter (I_Spec),
Then_Statements => Stats));
@@ -4484,7 +5125,7 @@ package body Exp_Ch5 is
(Container_Typ, Aspect_Variable_Indexing))
or else not Is_Variable (Original_Node (Container))
then
- Set_Ekind (Id, E_Constant);
+ Mutate_Ekind (Id, E_Constant);
end if;
Prepend_To (Stats, Decl);
@@ -4620,7 +5261,7 @@ package body Exp_Ch5 is
Set_Assignment_OK (Cursor_Decl);
Insert_Action (N, Cursor_Decl);
- Set_Ekind (Cursor, Id_Kind);
+ Mutate_Ekind (Cursor, Id_Kind);
end;
-- If the range of iteration is given by a function call that returns
@@ -4701,7 +5342,7 @@ package body Exp_Ch5 is
end if;
if Present (Iterator_Filter (LPS)) then
- pragma Assert (Ada_Version >= Ada_2020);
+ pragma Assert (Ada_Version >= Ada_2022);
Set_Statements (N,
New_List (Make_If_Statement (Loc,
Condition => Iterator_Filter (LPS),
@@ -5081,7 +5722,7 @@ package body Exp_Ch5 is
-- identifier, since there may be references in the loop body.
Set_Analyzed (Loop_Id, False);
- Set_Ekind (Loop_Id, E_Variable);
+ Mutate_Ekind (Loop_Id, E_Variable);
-- In most loops the loop variable is assigned in various
-- alternatives in the body. However, in the rare case when
diff --git a/gcc/ada/exp_ch5.ads b/gcc/ada/exp_ch5.ads
index 4f5e995..75dd2cc 100644
--- a/gcc/ada/exp_ch5.ads
+++ b/gcc/ada/exp_ch5.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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 @@ package Exp_Ch5 is
procedure Expand_N_Block_Statement (N : Node_Id);
procedure Expand_N_Case_Statement (N : Node_Id);
procedure Expand_N_Exit_Statement (N : Node_Id);
+ procedure Expand_N_Goto_When_Statement (N : Node_Id);
procedure Expand_N_If_Statement (N : Node_Id);
procedure Expand_N_Loop_Statement (N : Node_Id);
diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb
index 2cd40e4..59704a4 100644
--- a/gcc/ada/exp_ch6.adb
+++ b/gcc/ada/exp_ch6.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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,57 +23,61 @@
-- --
------------------------------------------------------------------------------
-with Atree; use Atree;
-with Aspects; use Aspects;
-with Checks; use Checks;
-with Contracts; use Contracts;
-with Debug; use Debug;
-with Einfo; use Einfo;
-with Errout; use Errout;
-with Elists; use Elists;
-with Expander; use Expander;
-with Exp_Aggr; use Exp_Aggr;
-with Exp_Atag; use Exp_Atag;
-with Exp_Ch3; use Exp_Ch3;
-with Exp_Ch7; use Exp_Ch7;
-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_Intr; use Exp_Intr;
-with Exp_Pakd; use Exp_Pakd;
-with Exp_Tss; use Exp_Tss;
-with Exp_Util; use Exp_Util;
-with Freeze; use Freeze;
-with Inline; use Inline;
-with Itypes; use Itypes;
-with Lib; use Lib;
-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 Rtsfind; use Rtsfind;
-with Sem; use Sem;
-with Sem_Aux; use Sem_Aux;
-with Sem_Ch6; use Sem_Ch6;
-with Sem_Ch8; use Sem_Ch8;
-with Sem_Ch13; use Sem_Ch13;
-with Sem_Dim; use Sem_Dim;
-with Sem_Disp; use Sem_Disp;
-with Sem_Dist; use Sem_Dist;
-with Sem_Eval; use Sem_Eval;
-with Sem_Mech; use Sem_Mech;
-with Sem_Res; use Sem_Res;
-with Sem_SCIL; use Sem_SCIL;
-with Sem_Util; use Sem_Util;
-with Sinfo; use Sinfo;
-with Snames; use Snames;
-with Stand; use Stand;
-with Tbuild; use Tbuild;
-with Uintp; use Uintp;
-with Validsw; use Validsw;
+with Atree; use Atree;
+with Aspects; use Aspects;
+with Checks; use Checks;
+with Contracts; use Contracts;
+with Debug; use Debug;
+with Einfo; use Einfo;
+with Einfo.Entities; use Einfo.Entities;
+with Einfo.Utils; use Einfo.Utils;
+with Errout; use Errout;
+with Elists; use Elists;
+with Expander; use Expander;
+with Exp_Aggr; use Exp_Aggr;
+with Exp_Atag; use Exp_Atag;
+with Exp_Ch3; use Exp_Ch3;
+with Exp_Ch7; use Exp_Ch7;
+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_Intr; use Exp_Intr;
+with Exp_Pakd; use Exp_Pakd;
+with Exp_Tss; use Exp_Tss;
+with Exp_Util; use Exp_Util;
+with Freeze; use Freeze;
+with Inline; use Inline;
+with Itypes; use Itypes;
+with Lib; use Lib;
+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 Rtsfind; use Rtsfind;
+with Sem; use Sem;
+with Sem_Aux; use Sem_Aux;
+with Sem_Ch6; use Sem_Ch6;
+with Sem_Ch8; use Sem_Ch8;
+with Sem_Ch13; use Sem_Ch13;
+with Sem_Dim; use Sem_Dim;
+with Sem_Disp; use Sem_Disp;
+with Sem_Dist; use Sem_Dist;
+with Sem_Eval; use Sem_Eval;
+with Sem_Mech; use Sem_Mech;
+with Sem_Res; use Sem_Res;
+with Sem_SCIL; use Sem_SCIL;
+with Sem_Util; use Sem_Util;
+with Sinfo; use Sinfo;
+with Sinfo.Nodes; use Sinfo.Nodes;
+with Sinfo.Utils; use Sinfo.Utils;
+with Snames; use Snames;
+with Stand; use Stand;
+with Tbuild; use Tbuild;
+with Uintp; use Uintp;
+with Validsw; use Validsw;
package body Exp_Ch6 is
@@ -598,7 +602,7 @@ package body Exp_Ch6 is
-- Use a dummy _master actual in case of No_Task_Hierarchy
if Restriction_Active (No_Task_Hierarchy) then
- Actual := New_Occurrence_Of (RTE (RE_Library_Task_Level), Loc);
+ Actual := Make_Integer_Literal (Loc, Library_Task_Level);
-- In the case where we use the master associated with an access type,
-- the actual is an entity and requires an explicit reference.
@@ -1799,6 +1803,7 @@ package body Exp_Ch6 is
and then Is_Entity_Name (Lhs)
and then
Present (Effective_Extra_Accessibility (Entity (Lhs)))
+ and then not No_Dynamic_Accessibility_Checks_Enabled (Lhs)
then
-- Copyback target is an Ada 2012 stand-alone object of an
-- anonymous access type.
@@ -2209,7 +2214,7 @@ package body Exp_Ch6 is
-- Check for volatility mismatch
- if Is_Volatile_Object (Actual) and then not Is_Volatile (E_Formal)
+ if Is_Volatile_Object_Ref (Actual) and then not Is_Volatile (E_Formal)
then
if Comes_From_Source (N) then
Error_Msg_N
@@ -2661,7 +2666,7 @@ package body Exp_Ch6 is
-- itself must not be rewritten, to prevent infinite recursion).
Must_Rewrite_Indirect_Call : constant Boolean :=
- Ada_Version >= Ada_2020
+ Ada_Version >= Ada_2022
and then Nkind (Name (N)) = N_Explicit_Dereference
and then Ekind (Etype (Name (N))) = E_Subprogram_Type
and then Present
@@ -2925,7 +2930,9 @@ package body Exp_Ch6 is
Name => New_Occurrence_Of (Lvl, Loc),
Expression =>
Accessibility_Level
- (Expression (Res_Assn), Dynamic_Level)));
+ (Expr => Expression (Res_Assn),
+ Level => Dynamic_Level,
+ Allow_Alt_Model => False)));
end if;
end Expand_Branch;
@@ -3473,12 +3480,6 @@ package body Exp_Ch6 is
Scop : Entity_Id;
Subp : Entity_Id;
- Prev_Orig : Node_Id;
- -- Original node for an actual, which may have been rewritten. If the
- -- actual is a function call that has been transformed from a selected
- -- component, the original node is unanalyzed. Otherwise, it carries
- -- semantic information used to generate additional actuals.
-
CW_Interface_Formals_Present : Boolean := False;
-- Start of processing for Expand_Call_Helper
@@ -3591,7 +3592,9 @@ package body Exp_Ch6 is
Ren_Root := Alias (Ren_Root);
end if;
- if Present (Original_Node (Parent (Parent (Ren_Root)))) then
+ if Present (Parent (Ren_Root))
+ and then Present (Original_Node (Parent (Parent (Ren_Root))))
+ then
Ren_Decl := Original_Node (Parent (Parent (Ren_Root)));
if Nkind (Ren_Decl) = N_Subprogram_Renaming_Declaration then
@@ -3739,7 +3742,6 @@ package body Exp_Ch6 is
-- Prepare to examine current entry
Prev := Actual;
- Prev_Orig := Original_Node (Prev);
-- Ada 2005 (AI-251): Check if any formal is a class-wide interface
-- to expand it in a further round.
@@ -3759,7 +3761,7 @@ package body Exp_Ch6 is
-- because the object has underlying discriminants with defaults.
if Present (Extra_Constrained (Formal)) then
- if Ekind (Etype (Prev)) in Private_Kind
+ if Is_Private_Type (Etype (Prev))
and then not Has_Discriminants (Base_Type (Etype (Prev)))
then
Add_Extra_Actual
@@ -3801,7 +3803,7 @@ package body Exp_Ch6 is
-- is internally generated code that manipulates addresses,
-- e.g. when building interface tables. No check should
-- occur in this case, and the discriminated object is not
- -- directly a hand.
+ -- directly at hand.
if not Comes_From_Source (Actual)
and then Nkind (Actual) = N_Unchecked_Type_Conversion
@@ -3828,63 +3830,6 @@ package body Exp_Ch6 is
-- Create possible extra actual for accessibility level
if Present (Extra_Accessibility (Formal)) then
-
- -- Ada 2005 (AI-252): If the actual was rewritten as an Access
- -- attribute, then the original actual may be an aliased object
- -- occurring as the prefix in a call using "Object.Operation"
- -- notation. In that case we must pass the level of the object,
- -- so Prev_Orig is reset to Prev and the attribute will be
- -- processed by the code for Access attributes further below.
-
- if Prev_Orig /= Prev
- and then Nkind (Prev) = N_Attribute_Reference
- and then Get_Attribute_Id (Attribute_Name (Prev)) =
- Attribute_Access
- and then Is_Aliased_View (Prev_Orig)
- then
- Prev_Orig := Prev;
-
- -- A class-wide precondition generates a test in which formals of
- -- the subprogram are replaced by actuals that came from source.
- -- In that case as well, the accessiblity comes from the actual.
- -- This is the one case in which there are references to formals
- -- outside of their subprogram.
-
- elsif Prev_Orig /= Prev
- and then Is_Entity_Name (Prev_Orig)
- and then Present (Entity (Prev_Orig))
- and then Is_Formal (Entity (Prev_Orig))
- and then not In_Open_Scopes (Scope (Entity (Prev_Orig)))
- then
- Prev_Orig := Prev;
-
- -- If the actual is a formal of an enclosing subprogram it is
- -- the right entity, even if it is a rewriting. This happens
- -- when the call is within an inherited condition or predicate.
-
- elsif Is_Entity_Name (Actual)
- and then Is_Formal (Entity (Actual))
- and then In_Open_Scopes (Scope (Entity (Actual)))
- 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;
-
-- Ada 2005 (AI-251): Thunks must propagate the extra actuals of
-- accessibility levels.
@@ -3915,9 +3860,10 @@ package body Exp_Ch6 is
end if;
Add_Extra_Actual
- (Expr =>
- New_Occurrence_Of
- (Get_Dynamic_Accessibility (Parm_Ent), Loc),
+ (Expr => Accessibility_Level
+ (Expr => Parm_Ent,
+ Level => Dynamic_Level,
+ Allow_Alt_Model => False),
EF => Extra_Accessibility (Formal));
end;
@@ -3929,11 +3875,39 @@ package body Exp_Ch6 is
then
Add_Cond_Expression_Extra_Actual (Formal);
+ -- Internal constant generated to remove side effects (normally
+ -- from the expansion of dispatching calls).
+
+ -- First verify the actual is internal
+
+ elsif not Comes_From_Source (Prev)
+ and then Original_Node (Prev) = Prev
+
+ -- Next check that the actual is a constant
+
+ and then Nkind (Prev) = N_Identifier
+ and then Ekind (Entity (Prev)) = E_Constant
+ and then Nkind (Parent (Entity (Prev))) = N_Object_Declaration
+ then
+ -- Generate the accessibility level based on the expression in
+ -- the constant's declaration.
+
+ Add_Extra_Actual
+ (Expr => Accessibility_Level
+ (Expr => Expression
+ (Parent (Entity (Prev))),
+ Level => Dynamic_Level,
+ Allow_Alt_Model => False),
+ EF => Extra_Accessibility (Formal));
+
-- Normal case
else
Add_Extra_Actual
- (Expr => Accessibility_Level (Prev, Dynamic_Level),
+ (Expr => Accessibility_Level
+ (Expr => Prev,
+ Level => Dynamic_Level,
+ Allow_Alt_Model => False),
EF => Extra_Accessibility (Formal));
end if;
end if;
@@ -4177,8 +4151,10 @@ package body Exp_Ch6 is
-- Otherwise get the level normally based on the call node
else
- Level := Accessibility_Level (Call_Node, Dynamic_Level);
-
+ Level := Accessibility_Level
+ (Expr => Call_Node,
+ Level => Dynamic_Level,
+ Allow_Alt_Model => False);
end if;
-- It may be possible that we are re-expanding an already
@@ -4285,6 +4261,16 @@ package body Exp_Ch6 is
if Nkind (Call_Node) in N_Subprogram_Call
and then Present (Controlling_Argument (Call_Node))
then
+ if Tagged_Type_Expansion then
+ Expand_Dispatching_Call (Call_Node);
+
+ -- Expand_Dispatching_Call takes care of all the needed processing
+
+ return;
+ end if;
+
+ -- VM targets
+
declare
Call_Typ : constant Entity_Id := Etype (Call_Node);
Typ : constant Entity_Id := Find_Dispatching_Type (Subp);
@@ -4294,69 +4280,56 @@ package body Exp_Ch6 is
Prev_Call : Node_Id;
begin
+ Apply_Tag_Checks (Call_Node);
+
if not Is_Limited_Type (Typ) then
Eq_Prim_Op := Find_Prim_Op (Typ, Name_Op_Eq);
end if;
- if Tagged_Type_Expansion then
- Expand_Dispatching_Call (Call_Node);
-
- -- The following return is worrisome. Is it really OK to skip
- -- all remaining processing in this procedure ???
-
- return;
-
- -- VM targets
-
- else
- Apply_Tag_Checks (Call_Node);
-
- -- If this is a dispatching "=", we must first compare the
- -- tags so we generate: x.tag = y.tag and then x = y
-
- if Subp = Eq_Prim_Op then
-
- -- Mark the node as analyzed to avoid reanalyzing this
- -- dispatching call (which would cause a never-ending loop)
+ -- If this is a dispatching "=", we must first compare the
+ -- tags so we generate: x.tag = y.tag and then x = y
- Prev_Call := Relocate_Node (Call_Node);
- Set_Analyzed (Prev_Call);
+ if Subp = Eq_Prim_Op then
- Param := First_Actual (Call_Node);
- New_Call :=
- Make_And_Then (Loc,
- Left_Opnd =>
- Make_Op_Eq (Loc,
- Left_Opnd =>
- Make_Selected_Component (Loc,
- Prefix => New_Value (Param),
- Selector_Name =>
- New_Occurrence_Of
- (First_Tag_Component (Typ), Loc)),
+ -- Mark the node as analyzed to avoid reanalyzing this
+ -- dispatching call (which would cause a never-ending loop)
+
+ Prev_Call := Relocate_Node (Call_Node);
+ Set_Analyzed (Prev_Call);
+
+ Param := First_Actual (Call_Node);
+ New_Call :=
+ Make_And_Then (Loc,
+ Left_Opnd =>
+ Make_Op_Eq (Loc,
+ Left_Opnd =>
+ Make_Selected_Component (Loc,
+ Prefix => New_Value (Param),
+ Selector_Name =>
+ New_Occurrence_Of
+ (First_Tag_Component (Typ), Loc)),
+
+ Right_Opnd =>
+ Make_Selected_Component (Loc,
+ Prefix =>
+ Unchecked_Convert_To (Typ,
+ New_Value (Next_Actual (Param))),
+ Selector_Name =>
+ New_Occurrence_Of
+ (First_Tag_Component (Typ), Loc))),
+ Right_Opnd => Prev_Call);
- Right_Opnd =>
- Make_Selected_Component (Loc,
- Prefix =>
- Unchecked_Convert_To (Typ,
- New_Value (Next_Actual (Param))),
- Selector_Name =>
- New_Occurrence_Of
- (First_Tag_Component (Typ), Loc))),
- Right_Opnd => Prev_Call);
-
- Rewrite (Call_Node, New_Call);
-
- Analyze_And_Resolve
- (Call_Node, Call_Typ, Suppress => All_Checks);
- end if;
+ Rewrite (Call_Node, New_Call);
+ Analyze_And_Resolve
+ (Call_Node, Call_Typ, Suppress => All_Checks);
+ end if;
- -- Expansion of a dispatching call results in an indirect call,
- -- which in turn causes current values to be killed (see
- -- Resolve_Call), so on VM targets we do the call here to
- -- ensure consistent warnings between VM and non-VM targets.
+ -- Expansion of a dispatching call results in an indirect call,
+ -- which in turn causes current values to be killed (see
+ -- Resolve_Call), so on VM targets we do the call here to
+ -- ensure consistent warnings between VM and non-VM targets.
- Kill_Current_Values;
- end if;
+ Kill_Current_Values;
-- If this is a dispatching "=" then we must update the reference
-- to the call node because we generated:
@@ -4940,7 +4913,7 @@ package body Exp_Ch6 is
-- Optimization, if the returned value (which is on the sec-stack) is
-- returned again, no need to copy/readjust/finalize, we can just pass
-- the value thru (see Expand_N_Simple_Return_Statement), and thus no
- -- attachment is needed
+ -- attachment is needed.
if Nkind (Parent (N)) = N_Simple_Return_Statement then
return;
@@ -5164,7 +5137,7 @@ package body Exp_Ch6 is
-- Perform minor decoration in order to set the master and the
-- storage pool attributes.
- Set_Ekind (Ptr_Typ, E_Access_Type);
+ Mutate_Ekind (Ptr_Typ, E_Access_Type);
Set_Finalization_Master (Ptr_Typ, Fin_Mas_Id);
Set_Associated_Storage_Pool (Ptr_Typ, Pool_Id);
@@ -5879,11 +5852,9 @@ package body Exp_Ch6 is
Name =>
New_Occurrence_Of (Alloc_Obj_Id, Loc),
Expression =>
- Make_Unchecked_Type_Conversion (Loc,
- Subtype_Mark =>
- New_Occurrence_Of (Ref_Type, Loc),
- Expression =>
- New_Occurrence_Of (Obj_Acc_Formal, Loc)))),
+ Unchecked_Convert_To
+ (Ref_Type,
+ New_Occurrence_Of (Obj_Acc_Formal, Loc)))),
Elsif_Parts => New_List (
Make_Elsif_Part (Loc,
@@ -6024,11 +5995,9 @@ package body Exp_Ch6 is
Object_Definition =>
New_Occurrence_Of (Ref_Type, Loc),
Expression =>
- Make_Unchecked_Type_Conversion (Loc,
- Subtype_Mark =>
- New_Occurrence_Of (Ref_Type, Loc),
- Expression =>
- New_Occurrence_Of (Obj_Acc_Formal, Loc)));
+ Unchecked_Convert_To
+ (Ref_Type,
+ New_Occurrence_Of (Obj_Acc_Formal, Loc)));
Insert_Before (Ret_Obj_Decl, Alloc_Obj_Decl);
@@ -6073,6 +6042,7 @@ package body Exp_Ch6 is
-- Set the flag to prevent infinite recursion
Set_Comes_From_Extended_Return_Statement (Return_Stmt);
+ Set_Return_Statement (Ret_Obj_Id, Return_Stmt);
Rewrite (N, Result);
@@ -6103,6 +6073,23 @@ package body Exp_Ch6 is
Expand_Call (N);
end Expand_N_Procedure_Call_Statement;
+ ------------------------------------
+ -- Expand_N_Return_When_Statement --
+ ------------------------------------
+
+ procedure Expand_N_Return_When_Statement (N : Node_Id) is
+ Loc : constant Source_Ptr := Sloc (N);
+ begin
+ Rewrite (N,
+ Make_If_Statement (Loc,
+ Condition => Condition (N),
+ Then_Statements => New_List (
+ Make_Simple_Return_Statement (Loc,
+ Expression => Expression (N)))));
+
+ Analyze (N);
+ end Expand_N_Return_When_Statement;
+
--------------------------------------
-- Expand_N_Simple_Return_Statement --
--------------------------------------
@@ -6246,7 +6233,8 @@ package body Exp_Ch6 is
-- has contract assertions that need to be verified on exit.
-- Also, mark the successful return to signal that postconditions
- -- need to be evaluated when finalization occurs.
+ -- need to be evaluated when finalization occurs by setting
+ -- Return_Success_For_Postcond to be True.
if Ekind (Spec_Id) = E_Procedure
and then Present (Postconditions_Proc (Spec_Id))
@@ -6254,22 +6242,33 @@ package body Exp_Ch6 is
-- Generate:
--
-- Return_Success_For_Postcond := True;
- -- _postconditions;
+ -- if Postcond_Enabled then
+ -- _postconditions;
+ -- end if;
Insert_Action (Stmt,
Make_Assignment_Statement (Loc,
Name =>
New_Occurrence_Of
- (Get_Return_Success_For_Postcond (Spec_Id), Loc),
+ (Get_Return_Success_For_Postcond (Spec_Id), Loc),
Expression => New_Occurrence_Of (Standard_True, Loc)));
+ -- Wrap the call to _postconditions within a test of the
+ -- Postcond_Enabled flag to delay postcondition evaluation
+ -- until after finalization when required.
+
Insert_Action (Stmt,
- Make_Procedure_Call_Statement (Loc,
- Name =>
- New_Occurrence_Of (Postconditions_Proc (Spec_Id), Loc)));
+ Make_If_Statement (Loc,
+ Condition =>
+ New_Occurrence_Of (Get_Postcond_Enabled (Spec_Id), Loc),
+ Then_Statements => New_List (
+ Make_Procedure_Call_Statement (Loc,
+ Name =>
+ New_Occurrence_Of
+ (Postconditions_Proc (Spec_Id), Loc)))));
end if;
- -- Ada 2020 (AI12-0279): append the call to 'Yield unless this is
+ -- Ada 2022 (AI12-0279): append the call to 'Yield unless this is
-- a generic subprogram (since in such case it will be added to
-- the instantiations).
@@ -6439,18 +6438,7 @@ package body Exp_Ch6 is
-- Returns_By_Ref flag is normally set when the subprogram is frozen but
-- subprograms with no specs are not frozen.
- declare
- Typ : constant Entity_Id := Etype (Spec_Id);
- Utyp : constant Entity_Id := Underlying_Type (Typ);
-
- begin
- if Is_Limited_View (Typ) then
- Set_Returns_By_Ref (Spec_Id);
-
- elsif Present (Utyp) and then CW_Or_Has_Controlled_Part (Utyp) then
- Set_Returns_By_Ref (Spec_Id);
- end if;
- end;
+ Compute_Returns_By_Ref (Spec_Id);
-- For a procedure, we add a return for all possible syntactic ends of
-- the subprogram.
@@ -6699,7 +6687,9 @@ package body Exp_Ch6 is
-- Generate:
--
-- Return_Success_For_Postcond := True;
- -- _postconditions;
+ -- if Postcond_Enabled then
+ -- _postconditions;
+ -- end if;
Insert_Action (N,
Make_Assignment_Statement (Loc,
@@ -6708,12 +6698,22 @@ package body Exp_Ch6 is
(Get_Return_Success_For_Postcond (Scope_Id), Loc),
Expression => New_Occurrence_Of (Standard_True, Loc)));
+ -- Wrap the call to _postconditions within a test of the
+ -- Postcond_Enabled flag to delay postcondition evaluation until
+ -- after finalization when required.
+
Insert_Action (N,
- Make_Procedure_Call_Statement (Loc,
- Name => New_Occurrence_Of (Postconditions_Proc (Scope_Id), Loc)));
+ Make_If_Statement (Loc,
+ Condition =>
+ New_Occurrence_Of (Get_Postcond_Enabled (Scope_Id), Loc),
+ Then_Statements => New_List (
+ Make_Procedure_Call_Statement (Loc,
+ Name =>
+ New_Occurrence_Of
+ (Postconditions_Proc (Scope_Id), Loc)))));
end if;
- -- Ada 2020 (AI12-0279)
+ -- Ada 2022 (AI12-0279)
if Has_Yield_Aspect (Scope_Id)
and then RTE_Available (RE_Yield)
@@ -7310,15 +7310,16 @@ package body Exp_Ch6 is
Set_Enclosing_Sec_Stack_Return (N);
- -- Optimize the case where the result is a function call. In this
- -- case the result is already on the secondary stack and no further
- -- processing is required except to set the By_Ref flag to ensure
- -- that gigi does not attempt an extra unnecessary copy. (Actually
- -- not just unnecessary but wrong in the case of a controlled type,
- -- where gigi does not know how to do a copy.)
+ -- Optimize the case where the result is a function call that also
+ -- returns on the secondary stack. In this case the result is already
+ -- on the secondary stack and no further processing is required
+ -- except to set the By_Ref flag to ensure that gigi does not attempt
+ -- an extra unnecessary copy. (Actually not just unnecessary but
+ -- wrong in the case of a controlled type, where gigi does not know
+ -- how to do a copy.)
- if Requires_Transient_Scope (Exp_Typ)
- and then Exp_Is_Function_Call
+ pragma Assert (Requires_Transient_Scope (R_Type));
+ if Exp_Is_Function_Call and then Requires_Transient_Scope (Exp_Typ)
then
Set_By_Ref (N);
@@ -7358,7 +7359,7 @@ package body Exp_Ch6 is
Temp : Entity_Id;
begin
- Set_Ekind (Acc_Typ, E_Access_Type);
+ Mutate_Ekind (Acc_Typ, E_Access_Type);
Set_Associated_Storage_Pool (Acc_Typ, RTE (RE_SS_Pool));
@@ -7547,6 +7548,13 @@ package body Exp_Ch6 is
Suppress => All_Checks);
end if;
+ -- If the result is of an unconstrained array subtype with fixed lower
+ -- bound, then sliding to that bound may be needed.
+
+ if Is_Fixed_Lower_Bound_Array_Subtype (R_Type) then
+ Expand_Sliding_Conversion (Exp, R_Type);
+ end if;
+
-- If we are returning a nonscalar object that is possibly unaligned,
-- then copy the value into a temporary first. This copy may need to
-- expand to a loop of component operations.
@@ -7621,6 +7629,9 @@ package body Exp_Ch6 is
-- Generate:
--
-- Return_Success_For_Postcond := True;
+ -- if Postcond_Enabled then
+ -- _Postconditions ([exp]);
+ -- end if;
Insert_Action (Exp,
Make_Assignment_Statement (Loc,
@@ -7629,13 +7640,20 @@ package body Exp_Ch6 is
(Get_Return_Success_For_Postcond (Scope_Id), Loc),
Expression => New_Occurrence_Of (Standard_True, Loc)));
- -- Generate call to _Postconditions
+ -- Wrap the call to _postconditions within a test of the
+ -- Postcond_Enabled flag to delay postcondition evaluation until
+ -- after finalization when required.
Insert_Action (Exp,
- Make_Procedure_Call_Statement (Loc,
- Name =>
- New_Occurrence_Of (Postconditions_Proc (Scope_Id), Loc),
- Parameter_Associations => New_List (New_Copy_Tree (Exp))));
+ Make_If_Statement (Loc,
+ Condition =>
+ New_Occurrence_Of (Get_Postcond_Enabled (Scope_Id), Loc),
+ Then_Statements => New_List (
+ Make_Procedure_Call_Statement (Loc,
+ Name =>
+ New_Occurrence_Of
+ (Postconditions_Proc (Scope_Id), Loc),
+ Parameter_Associations => New_List (New_Copy_Tree (Exp))))));
end if;
-- Ada 2005 (AI-251): If this return statement corresponds with an
@@ -7653,7 +7671,7 @@ package body Exp_Ch6 is
Analyze_And_Resolve (Exp);
end if;
- -- Ada 2020 (AI12-0279)
+ -- Ada 2022 (AI12-0279)
if Has_Yield_Aspect (Scope_Id)
and then RTE_Available (RE_Yield)
@@ -7830,20 +7848,9 @@ package body Exp_Ch6 is
-- of the normal semantic analysis of the spec since the underlying
-- returned type may not be known yet (for private types).
- declare
- Typ : constant Entity_Id := Etype (Subp);
- Utyp : constant Entity_Id := Underlying_Type (Typ);
-
- begin
- if Is_Limited_View (Typ) then
- Set_Returns_By_Ref (Subp);
+ Compute_Returns_By_Ref (Subp);
- elsif Present (Utyp) and then CW_Or_Has_Controlled_Part (Utyp) then
- Set_Returns_By_Ref (Subp);
- end if;
- end;
-
- -- Wnen freezing a null procedure, analyze its delayed aspects now
+ -- When freezing a null procedure, analyze its delayed aspects now
-- because we may not have reached the end of the declarative list when
-- delayed aspects are normally analyzed. This ensures that dispatching
-- calls are properly rewritten when the generated _Postcondition
@@ -8213,10 +8220,6 @@ package body Exp_Ch6 is
return False;
end if;
- -- For now we test whether E denotes a function or access-to-function
- -- type whose result subtype is inherently limited. Later this test
- -- may be revised to allow composite nonlimited types.
-
if Ekind (E) in E_Function | E_Generic_Function
or else (Ekind (E) = E_Subprogram_Type
and then Etype (E) /= Standard_Void_Type)
@@ -8272,6 +8275,15 @@ package body Exp_Ch6 is
-- This may be a call to a protected function.
elsif Nkind (Name (Exp_Node)) = N_Selected_Component then
+ -- The selector in question might not have been analyzed due to a
+ -- previous error, so analyze it here to output the appropriate
+ -- error message instead of crashing when attempting to fetch its
+ -- entity.
+
+ if not Analyzed (Selector_Name (Name (Exp_Node))) then
+ Analyze (Selector_Name (Name (Exp_Node)));
+ end if;
+
Function_Id := Etype (Entity (Selector_Name (Name (Exp_Node))));
else
@@ -8504,12 +8516,10 @@ package body Exp_Ch6 is
Alloc_Form := Caller_Allocation;
Pool := Make_Null (No_Location);
- Return_Obj_Actual :=
- Make_Unchecked_Type_Conversion (Loc,
- Subtype_Mark => New_Occurrence_Of (Result_Subt, Loc),
- Expression =>
- Make_Explicit_Dereference (Loc,
- Prefix => New_Occurrence_Of (Return_Obj_Access, Loc)));
+ Return_Obj_Actual := Unchecked_Convert_To
+ (Result_Subt,
+ Make_Explicit_Dereference (Loc,
+ Prefix => New_Occurrence_Of (Return_Obj_Access, Loc)));
-- When the result subtype is unconstrained, the function itself must
-- perform the allocation of the return object, so we pass parameters
@@ -8823,11 +8833,7 @@ package body Exp_Ch6 is
-- the caller's return object.
Add_Access_Actual_To_Build_In_Place_Call
- (Func_Call,
- Func_Id,
- Make_Unchecked_Type_Conversion (Loc,
- Subtype_Mark => New_Occurrence_Of (Result_Subt, Loc),
- Expression => Relocate_Node (Lhs)));
+ (Func_Call, Func_Id, Unchecked_Convert_To (Result_Subt, Lhs));
-- Create an access type designating the function's result subtype
@@ -8851,11 +8857,7 @@ package body Exp_Ch6 is
-- Add a conversion if it's the wrong type
- if Etype (New_Expr) /= Ptr_Typ then
- New_Expr :=
- Make_Unchecked_Type_Conversion (Loc,
- New_Occurrence_Of (Ptr_Typ, Loc), New_Expr);
- end if;
+ New_Expr := Unchecked_Convert_To (Ptr_Typ, New_Expr);
Obj_Id := Make_Temporary (Loc, 'R', New_Expr);
Set_Etype (Obj_Id, Ptr_Typ);
@@ -9114,16 +9116,10 @@ package body Exp_Ch6 is
-- it to the access type of the callee's BIP_Object_Access formal.
Caller_Object :=
- Make_Unchecked_Type_Conversion (Loc,
- Subtype_Mark =>
- New_Occurrence_Of
- (Etype (Build_In_Place_Formal
- (Function_Id, BIP_Object_Access)),
- Loc),
- Expression =>
- New_Occurrence_Of
- (Build_In_Place_Formal (Encl_Func, BIP_Object_Access),
- Loc));
+ Unchecked_Convert_To
+ (Etype (Build_In_Place_Formal (Function_Id, BIP_Object_Access)),
+ New_Occurrence_Of
+ (Build_In_Place_Formal (Encl_Func, BIP_Object_Access), Loc));
-- In the definite case, add an implicit actual to the function call
-- that provides access to the declared object. An unchecked conversion
@@ -9131,10 +9127,8 @@ package body Exp_Ch6 is
-- the case where the object is declared with a class-wide type.
elsif Definite then
- Caller_Object :=
- Make_Unchecked_Type_Conversion (Loc,
- Subtype_Mark => New_Occurrence_Of (Result_Subt, Loc),
- Expression => New_Occurrence_Of (Obj_Def_Id, Loc));
+ Caller_Object := Unchecked_Convert_To
+ (Result_Subt, New_Occurrence_Of (Obj_Def_Id, Loc));
-- When the function has a controlling result, an allocation-form
-- parameter must be passed indicating that the caller is allocating
@@ -9242,9 +9236,8 @@ package body Exp_Ch6 is
Constant_Present => True,
Object_Definition => New_Occurrence_Of (Ptr_Typ, Loc),
Expression =>
- Make_Unchecked_Type_Conversion (Loc,
- New_Occurrence_Of (Ptr_Typ, Loc),
- Make_Reference (Loc, Relocate_Node (Func_Call))));
+ Unchecked_Convert_To
+ (Ptr_Typ, Make_Reference (Loc, Relocate_Node (Func_Call))));
else
Res_Decl :=
Make_Object_Declaration (Loc,
@@ -9616,7 +9609,9 @@ package body Exp_Ch6 is
and then not No_Run_Time_Mode
and then (Has_Task (Typ)
or else (Is_Class_Wide_Type (Typ)
- and then Is_Limited_Record (Typ)));
+ and then Is_Limited_Record (Typ)
+ and then not Has_Aspect
+ (Etype (Typ), Aspect_No_Task_Parts)));
end Might_Have_Tasks;
----------------------------
@@ -9976,8 +9971,6 @@ package body Exp_Ch6 is
elsif Nkind (Expr) = N_Function_Call
and then Nkind (Name (Expr)) in N_Has_Entity
and then Present (Entity (Name (Expr)))
- and then RTU_Loaded (Ada_Tags)
- and then RTE_Available (RE_Displace)
and then Is_RTE (Entity (Name (Expr)), RE_Displace)
then
Has_Pointer_Displacement := True;
diff --git a/gcc/ada/exp_ch6.ads b/gcc/ada/exp_ch6.ads
index 272f893..76cec4d 100644
--- a/gcc/ada/exp_ch6.ads
+++ b/gcc/ada/exp_ch6.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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 @@ package Exp_Ch6 is
procedure Expand_N_Extended_Return_Statement (N : Node_Id);
procedure Expand_N_Function_Call (N : Node_Id);
procedure Expand_N_Procedure_Call_Statement (N : Node_Id);
+ procedure Expand_N_Return_When_Statement (N : Node_Id);
procedure Expand_N_Simple_Return_Statement (N : Node_Id);
procedure Expand_N_Subprogram_Body (N : Node_Id);
procedure Expand_N_Subprogram_Body_Stub (N : Node_Id);
@@ -133,8 +134,11 @@ package Exp_Ch6 is
--
-- For inherently limited types in Ada 2005, True means that calls will
-- actually be build-in-place in all cases. For other types, build-in-place
- -- will be used when possible, but we need to make a copy at the call site
- -- in some cases, notably assignment statements.
+ -- will be used when possible, but we need to make a copy in some
+ -- cases. For example, for "X := F(...);" if F can see X, or if F can
+ -- propagate exceptions, we need to store its result in a temp in general,
+ -- and copy the temp into X. Also, for "return Global_Var;" Global_Var
+ -- needs to be copied into the function result object.
function Is_Build_In_Place_Function (E : Entity_Id) return Boolean;
-- Ada 2005 (AI-318-02): Returns True if E denotes a function, generic
diff --git a/gcc/ada/exp_ch7.adb b/gcc/ada/exp_ch7.adb
index 5d8ad7d..f7807ac 100644
--- a/gcc/ada/exp_ch7.adb
+++ b/gcc/ada/exp_ch7.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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,43 +27,48 @@
-- - controlled types
-- - transient scopes
-with Atree; use Atree;
-with Contracts; use Contracts;
-with Debug; use Debug;
-with Einfo; use Einfo;
-with Elists; use Elists;
-with Errout; use Errout;
-with Exp_Ch6; use Exp_Ch6;
-with Exp_Ch9; use Exp_Ch9;
-with Exp_Ch11; use Exp_Ch11;
-with Exp_Dbug; use Exp_Dbug;
-with Exp_Dist; use Exp_Dist;
-with Exp_Disp; use Exp_Disp;
-with Exp_Prag; use Exp_Prag;
-with Exp_Tss; use Exp_Tss;
-with Exp_Util; use Exp_Util;
-with Freeze; use Freeze;
-with Lib; use Lib;
-with Nlists; use Nlists;
-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 Sinfo; use Sinfo;
-with Sem; use Sem;
-with Sem_Aux; use Sem_Aux;
-with Sem_Ch3; use Sem_Ch3;
-with Sem_Ch7; use Sem_Ch7;
-with Sem_Ch8; use Sem_Ch8;
-with Sem_Res; use Sem_Res;
-with Sem_Util; use Sem_Util;
-with Snames; use Snames;
-with Stand; use Stand;
-with Tbuild; use Tbuild;
-with Ttypes; use Ttypes;
-with Uintp; use Uintp;
+with Atree; use Atree;
+with Contracts; use Contracts;
+with Debug; use Debug;
+with Einfo; use Einfo;
+with Einfo.Entities; use Einfo.Entities;
+with Einfo.Utils; use Einfo.Utils;
+with Elists; use Elists;
+with Errout; use Errout;
+with Exp_Ch6; use Exp_Ch6;
+with Exp_Ch9; use Exp_Ch9;
+with Exp_Ch11; use Exp_Ch11;
+with Exp_Dbug; use Exp_Dbug;
+with Exp_Dist; use Exp_Dist;
+with Exp_Disp; use Exp_Disp;
+with Exp_Prag; use Exp_Prag;
+with Exp_Tss; use Exp_Tss;
+with Exp_Util; use Exp_Util;
+with Freeze; use Freeze;
+with GNAT_CUDA; use GNAT_CUDA;
+with Lib; use Lib;
+with Nlists; use Nlists;
+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 Sinfo; use Sinfo;
+with Sinfo.Nodes; use Sinfo.Nodes;
+with Sinfo.Utils; use Sinfo.Utils;
+with Sem; use Sem;
+with Sem_Aux; use Sem_Aux;
+with Sem_Ch3; use Sem_Ch3;
+with Sem_Ch7; use Sem_Ch7;
+with Sem_Ch8; use Sem_Ch8;
+with Sem_Res; use Sem_Res;
+with Sem_Util; use Sem_Util;
+with Snames; use Snames;
+with Stand; use Stand;
+with Tbuild; use Tbuild;
+with Ttypes; use Ttypes;
+with Uintp; use Uintp;
package body Exp_Ch7 is
@@ -126,11 +131,6 @@ package body Exp_Ch7 is
-- Transient Blocks and Finalization Management --
--------------------------------------------------
- function Find_Transient_Context (N : Node_Id) return Node_Id;
- -- Locate a suitable context for arbitrary node N which may need to be
- -- serviced by a transient scope. Return Empty if no suitable context is
- -- available.
-
procedure Insert_Actions_In_Scope_Around
(N : Node_Id;
Clean : Boolean;
@@ -150,12 +150,6 @@ package body Exp_Ch7 is
-- involves controlled objects or secondary stack usage, the corresponding
-- cleanup actions are performed at the end of the block.
- procedure Set_Node_To_Be_Wrapped (N : Node_Id);
- -- Set the field Node_To_Be_Wrapped of the current scope
-
- -- ??? The entire comment needs to be rewritten
- -- ??? which entire comment?
-
procedure Store_Actions_In_Scope (AK : Scope_Action_Kind; L : List_Id);
-- Shared processing for Store_xxx_Actions_In_Scope
@@ -486,7 +480,7 @@ package body Exp_Ch7 is
Skip_Self : Boolean := False) return Node_Id;
-- Subsidiary to Make_Adjust_Call and Make_Final_Call. Given the entity of
-- routine [Deep_]Adjust or [Deep_]Finalize and an object parameter, create
- -- an adjust or finalization call. Wnen flag Skip_Self is set, the related
+ -- an adjust or finalization call. When flag Skip_Self is set, the related
-- action has an effect on the components only (if any).
function Make_Deep_Proc
@@ -1550,6 +1544,11 @@ package body Exp_Ch7 is
-- Create the spec and body of the finalizer and insert them in the
-- proper place in the tree depending on the context.
+ function New_Finalizer_Name
+ (Spec_Id : Node_Id; For_Spec : Boolean) return Name_Id;
+ -- Create a fully qualified name of a package spec or body finalizer.
+ -- The generated name is of the form: xx__yy__finalize_[spec|body].
+
procedure Process_Declarations
(Decls : List_Id;
Preprocess : Boolean := False;
@@ -1557,7 +1556,8 @@ package body Exp_Ch7 is
-- Inspect a list of declarations or statements which may contain
-- objects that need finalization. When flag Preprocess is set, the
-- routine will simply count the total number of controlled objects in
- -- Decls. Flag Top_Level denotes whether the processing is done for
+ -- Decls and set Counter_Val accordingly. Top_Level is only relevant
+ -- when Preprocess is set and if True, the processing is performed for
-- objects in nested package declarations or instances.
procedure Process_Object_Declaration
@@ -1692,58 +1692,6 @@ package body Exp_Ch7 is
----------------------
procedure Create_Finalizer is
- function New_Finalizer_Name return Name_Id;
- -- Create a fully qualified name of a package spec or body finalizer.
- -- The generated name is of the form: xx__yy__finalize_[spec|body].
-
- ------------------------
- -- New_Finalizer_Name --
- ------------------------
-
- function New_Finalizer_Name return Name_Id is
- procedure New_Finalizer_Name (Id : Entity_Id);
- -- Place "__<name-of-Id>" in the name buffer. If the identifier
- -- has a non-standard scope, process the scope first.
-
- ------------------------
- -- New_Finalizer_Name --
- ------------------------
-
- procedure New_Finalizer_Name (Id : Entity_Id) is
- begin
- if Scope (Id) = Standard_Standard then
- Get_Name_String (Chars (Id));
-
- else
- New_Finalizer_Name (Scope (Id));
- Add_Str_To_Name_Buffer ("__");
- Add_Str_To_Name_Buffer (Get_Name_String (Chars (Id)));
- end if;
- end New_Finalizer_Name;
-
- -- Start of processing for New_Finalizer_Name
-
- begin
- -- Create the fully qualified name of the enclosing scope
-
- New_Finalizer_Name (Spec_Id);
-
- -- Generate:
- -- __finalize_[spec|body]
-
- Add_Str_To_Name_Buffer ("__finalize_");
-
- if For_Package_Spec then
- Add_Str_To_Name_Buffer ("spec");
- else
- Add_Str_To_Name_Buffer ("body");
- end if;
-
- return Name_Find;
- end New_Finalizer_Name;
-
- -- Local variables
-
Body_Id : Entity_Id;
Fin_Body : Node_Id;
Fin_Spec : Node_Id;
@@ -1751,8 +1699,6 @@ package body Exp_Ch7 is
Label : Node_Id;
Label_Id : Entity_Id;
- -- Start of processing for Create_Finalizer
-
begin
-- Step 1: Creation of the finalizer name
@@ -1763,7 +1709,8 @@ package body Exp_Ch7 is
-- xx__yy__finalize_[spec|body]
if For_Package then
- Fin_Id := Make_Defining_Identifier (Loc, New_Finalizer_Name);
+ Fin_Id := Make_Defining_Identifier
+ (Loc, New_Finalizer_Name (Spec_Id, For_Package_Spec));
Set_Has_Qualified_Name (Fin_Id);
Set_Has_Fully_Qualified_Name (Fin_Id);
@@ -1839,10 +1786,22 @@ package body Exp_Ch7 is
Make_Procedure_Specification (Loc,
Defining_Unit_Name => Fin_Id));
+ if For_Package then
+ Set_Is_Exported (Fin_Id);
+ Set_Interface_Name (Fin_Id,
+ Make_String_Literal (Loc,
+ Strval => Get_Name_String (Chars (Fin_Id))));
+ end if;
+
-- Step 3: Creation of the finalizer body
- if Has_Ctrl_Objs then
+ -- Has_Ctrl_Objs might be set because of a generic package body having
+ -- controlled objects. In this case, Jump_Alts may be empty and no
+ -- case nor goto statements are needed.
+ if Has_Ctrl_Objs
+ and then not Is_Empty_List (Jump_Alts)
+ then
-- Add L0, the default destination to the jump block
Label_Id := Make_Identifier (Loc, New_External_Name ('L', 0));
@@ -2164,6 +2123,54 @@ package body Exp_Ch7 is
Set_Is_Checked_Ghost_Entity (Fin_Id, False);
end Create_Finalizer;
+ ------------------------
+ -- New_Finalizer_Name --
+ ------------------------
+
+ function New_Finalizer_Name
+ (Spec_Id : Node_Id; For_Spec : Boolean) return Name_Id
+ is
+ procedure New_Finalizer_Name (Id : Entity_Id);
+ -- Place "__<name-of-Id>" in the name buffer. If the identifier
+ -- has a non-standard scope, process the scope first.
+
+ ------------------------
+ -- New_Finalizer_Name --
+ ------------------------
+
+ procedure New_Finalizer_Name (Id : Entity_Id) is
+ begin
+ if Scope (Id) = Standard_Standard then
+ Get_Name_String (Chars (Id));
+
+ else
+ New_Finalizer_Name (Scope (Id));
+ Add_Str_To_Name_Buffer ("__");
+ Get_Name_String_And_Append (Chars (Id));
+ end if;
+ end New_Finalizer_Name;
+
+ -- Start of processing for New_Finalizer_Name
+
+ begin
+ -- Create the fully qualified name of the enclosing scope
+
+ New_Finalizer_Name (Spec_Id);
+
+ -- Generate:
+ -- __finalize_[spec|body]
+
+ Add_Str_To_Name_Buffer ("__finalize_");
+
+ if For_Spec then
+ Add_Str_To_Name_Buffer ("spec");
+ else
+ Add_Str_To_Name_Buffer ("body");
+ end if;
+
+ return Name_Find;
+ end New_Finalizer_Name;
+
--------------------------
-- Process_Declarations --
--------------------------
@@ -2543,6 +2550,73 @@ package body Exp_Ch7 is
end if;
end if;
+ -- Call the xxx__finalize_body procedure of a library level
+ -- package instantiation if the body contains finalization
+ -- statements.
+
+ if Present (Generic_Parent (Spec))
+ and then Is_Library_Level_Entity (Pack_Id)
+ and then Present (Body_Entity (Generic_Parent (Spec)))
+ then
+ if Preprocess then
+ declare
+ P : Node_Id;
+ begin
+ P := Parent (Body_Entity (Generic_Parent (Spec)));
+ while Present (P)
+ and then Nkind (P) /= N_Package_Body
+ loop
+ P := Parent (P);
+ end loop;
+
+ if Present (P) then
+ Old_Counter_Val := Counter_Val;
+ Process_Declarations (Declarations (P), Preprocess);
+
+ -- Note that we are processing the generic body
+ -- template and not the actually instantiation
+ -- (which is generated too late for us to process
+ -- it), so there is no need to update in particular
+ -- to update Last_Top_Level_Ctrl_Construct here.
+
+ if Counter_Val > Old_Counter_Val then
+ Counter_Val := Old_Counter_Val;
+ Set_Has_Controlled_Component (Pack_Id);
+ end if;
+ end if;
+ end;
+
+ elsif Has_Controlled_Component (Pack_Id) then
+
+ -- We import the xxx__finalize_body routine since the
+ -- generic body will be instantiated later.
+
+ declare
+ Id : constant Node_Id :=
+ Make_Defining_Identifier (Loc,
+ New_Finalizer_Name (Defining_Unit_Name (Spec),
+ For_Spec => False));
+
+ begin
+ Set_Has_Qualified_Name (Id);
+ Set_Has_Fully_Qualified_Name (Id);
+ Set_Is_Imported (Id);
+ Set_Has_Completion (Id);
+ Set_Interface_Name (Id,
+ Make_String_Literal (Loc,
+ Strval => Get_Name_String (Chars (Id))));
+
+ Append_New_To (Finalizer_Stmts,
+ Make_Subprogram_Declaration (Loc,
+ Make_Procedure_Specification (Loc,
+ Defining_Unit_Name => Id)));
+ Append_To (Finalizer_Stmts,
+ Make_Procedure_Call_Statement (Loc,
+ Name => New_Occurrence_Of (Id, Loc)));
+ end;
+ end if;
+ end if;
+
-- Nested package bodies, avoid generics
elsif Nkind (Decl) = N_Package_Body then
@@ -2553,8 +2627,7 @@ package body Exp_Ch7 is
if Is_Ignored_Ghost_Entity (Defining_Entity (Decl)) then
null;
- elsif Ekind (Corresponding_Spec (Decl)) /=
- E_Generic_Package
+ elsif Ekind (Corresponding_Spec (Decl)) /= E_Generic_Package
then
Old_Counter_Val := Counter_Val;
Process_Declarations (Declarations (Decl), Preprocess);
@@ -2729,7 +2802,7 @@ package body Exp_Ch7 is
-- Perform minor decoration in order to set the master and the
-- storage pool attributes.
- Set_Ekind (Ptr_Typ, E_Access_Type);
+ Mutate_Ekind (Ptr_Typ, E_Access_Type);
Set_Finalization_Master (Ptr_Typ, Fin_Mas_Id);
Set_Associated_Storage_Pool (Ptr_Typ, Pool_Id);
@@ -3044,6 +3117,8 @@ package body Exp_Ch7 is
-- Otherwise the initialization calls follow the related object
else
+ pragma Assert (Present (Stmt));
+
Stmt_2 := Next_Suitable_Statement (Stmt);
-- Check for an optional call to Deep_Initialize which may
@@ -3545,6 +3620,14 @@ package body Exp_Ch7 is
or else Scope_Depth_Value (Spec_Id) /= Uint_1
or else (Is_Generic_Instance (Spec_Id)
and then Package_Instantiation (Spec_Id) /= N))
+
+ -- Still need to process package body instantiations which may
+ -- contain objects requiring finalization.
+
+ and then not
+ (For_Package_Body
+ and then Is_Library_Level_Entity (Spec_Id)
+ and then Is_Generic_Instance (Spec_Id))
then
return;
end if;
@@ -3626,7 +3709,7 @@ package body Exp_Ch7 is
-- Step 3: Finalizer creation
- if Acts_As_Clean or else Has_Ctrl_Objs or else Has_Tagged_Types then
+ if Acts_As_Clean or Has_Ctrl_Objs or Has_Tagged_Types then
Create_Finalizer;
end if;
end Build_Finalizer_Helper;
@@ -3798,7 +3881,9 @@ package body Exp_Ch7 is
-- -- Perform postcondition checks after general finalization, but
-- -- before finalization of 'Old related objects.
--
- -- if not Raised_Finalization_Exception then
+ -- if not Raised_Finalization_Exception
+ -- and then Return_Success_For_Postcond
+ -- then
-- begin
-- -- Re-enable postconditions and check them
--
@@ -3976,7 +4061,9 @@ package body Exp_Ch7 is
-- Generate:
--
- -- if not Raised_Finalization_Exception then
+ -- if not Raised_Finalization_Exception
+ -- and then Return_Success_For_Postcond
+ -- then
-- begin
-- Postcond_Enabled := True;
-- _postconditions [(Result_Obj_For_Postcond[.all])];
@@ -3991,10 +4078,15 @@ package body Exp_Ch7 is
Append_To (Fin_Controller_Stmts,
Make_If_Statement (Loc,
Condition =>
- Make_Op_Not (Loc,
+ Make_And_Then (Loc,
+ Left_Opnd =>
+ Make_Op_Not (Loc,
+ Right_Opnd =>
+ New_Occurrence_Of
+ (Raised_Finalization_Exception_Id, Loc)),
Right_Opnd =>
New_Occurrence_Of
- (Raised_Finalization_Exception_Id, Loc)),
+ (Get_Return_Success_For_Postcond (Def_Ent), Loc)),
Then_Statements => New_List (
Make_Block_Statement (Loc,
Handled_Statement_Sequence =>
@@ -5018,15 +5110,6 @@ package body Exp_Ch7 is
end if;
end Convert_View;
- -------------------------------
- -- CW_Or_Has_Controlled_Part --
- -------------------------------
-
- function CW_Or_Has_Controlled_Part (T : Entity_Id) return Boolean is
- begin
- return Is_Class_Wide_Type (T) or else Needs_Finalization (T);
- end CW_Or_Has_Controlled_Part;
-
------------------------
-- Enclosing_Function --
------------------------
@@ -5060,37 +5143,47 @@ package body Exp_Ch7 is
(N : Node_Id;
Manage_Sec_Stack : Boolean)
is
- procedure Create_Transient_Scope (Constr : Node_Id);
- -- Place a new scope on the scope stack in order to service construct
- -- Constr. The new scope may also manage the secondary stack.
+ function Is_Package_Or_Subprogram (Id : Entity_Id) return Boolean;
+ -- Determine whether arbitrary Id denotes a package or subprogram [body]
+
+ function Find_Enclosing_Transient_Scope return Entity_Id;
+ -- Examine the scope stack looking for the nearest enclosing transient
+ -- scope within the innermost enclosing package or subprogram. Return
+ -- Empty if no such scope exists.
+
+ function Find_Transient_Context (N : Node_Id) return Node_Id;
+ -- Locate a suitable context for arbitrary node N which may need to be
+ -- serviced by a transient scope. Return Empty if no suitable context
+ -- is available.
procedure Delegate_Sec_Stack_Management;
-- Move the management of the secondary stack to the nearest enclosing
-- suitable scope.
- function Find_Enclosing_Transient_Scope return Entity_Id;
- -- Examine the scope stack looking for the nearest enclosing transient
- -- scope. Return Empty if no such scope exists.
-
- function Is_Package_Or_Subprogram (Id : Entity_Id) return Boolean;
- -- Determine whether arbitrary Id denotes a package or subprogram [body]
+ procedure Create_Transient_Scope (Context : Node_Id);
+ -- Place a new scope on the scope stack in order to service construct
+ -- Context. Context is the node found by Find_Transient_Context. The
+ -- new scope may also manage the secondary stack.
----------------------------
-- Create_Transient_Scope --
----------------------------
- procedure Create_Transient_Scope (Constr : Node_Id) is
+ procedure Create_Transient_Scope (Context : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
Iter_Loop : Entity_Id;
- Trans_Scop : Entity_Id;
+ Trans_Scop : constant Entity_Id :=
+ New_Internal_Entity (E_Block, Current_Scope, Loc, 'B');
begin
- Trans_Scop := New_Internal_Entity (E_Block, Current_Scope, Loc, 'B');
Set_Etype (Trans_Scop, Standard_Void_Type);
+ -- Push a new scope, and set its Node_To_Be_Wrapped and Is_Transient
+ -- fields.
+
Push_Scope (Trans_Scop);
- Set_Node_To_Be_Wrapped (Constr);
+ Scope_Stack.Table (Scope_Stack.Last).Node_To_Be_Wrapped := Context;
Set_Scope_Is_Transient;
-- The transient scope must also manage the secondary stack
@@ -5141,37 +5234,34 @@ package body Exp_Ch7 is
-----------------------------------
procedure Delegate_Sec_Stack_Management is
- Scop_Id : Entity_Id;
- Scop_Rec : Scope_Stack_Entry;
-
begin
for Index in reverse Scope_Stack.First .. Scope_Stack.Last loop
- Scop_Rec := Scope_Stack.Table (Index);
- Scop_Id := Scop_Rec.Entity;
-
- -- Prevent the search from going too far or within the scope space
- -- of another unit.
+ declare
+ Scope : Scope_Stack_Entry renames Scope_Stack.Table (Index);
+ begin
+ -- Prevent the search from going too far or within the scope
+ -- space of another unit.
- if Scop_Id = Standard_Standard then
- return;
+ if Scope.Entity = Standard_Standard then
+ return;
- -- No transient scope should be encountered during the traversal
- -- because Establish_Transient_Scope should have already handled
- -- this case.
+ -- No transient scope should be encountered during the
+ -- traversal because Establish_Transient_Scope should have
+ -- already handled this case.
- elsif Scop_Rec.Is_Transient then
- pragma Assert (False);
- return;
+ elsif Scope.Is_Transient then
+ raise Program_Error;
- -- The construct which requires secondary stack management is
- -- always enclosed by a package or subprogram scope.
+ -- The construct that requires secondary stack management is
+ -- always enclosed by a package or subprogram scope.
- elsif Is_Package_Or_Subprogram (Scop_Id) then
- Set_Uses_Sec_Stack (Scop_Id);
- Check_Restriction (No_Secondary_Stack, N);
+ elsif Is_Package_Or_Subprogram (Scope.Entity) then
+ Set_Uses_Sec_Stack (Scope.Entity);
+ Check_Restriction (No_Secondary_Stack, N);
- return;
- end if;
+ return;
+ end if;
+ end;
end loop;
-- At this point no suitable scope was found. This should never occur
@@ -5186,30 +5276,198 @@ package body Exp_Ch7 is
------------------------------------
function Find_Enclosing_Transient_Scope return Entity_Id is
- Scop_Id : Entity_Id;
- Scop_Rec : Scope_Stack_Entry;
-
begin
for Index in reverse Scope_Stack.First .. Scope_Stack.Last loop
- Scop_Rec := Scope_Stack.Table (Index);
- Scop_Id := Scop_Rec.Entity;
-
- -- Prevent the search from going too far or within the scope space
- -- of another unit.
+ declare
+ Scope : Scope_Stack_Entry renames Scope_Stack.Table (Index);
+ begin
+ -- Prevent the search from going too far or within the scope
+ -- space of another unit.
- if Scop_Id = Standard_Standard
- or else Is_Package_Or_Subprogram (Scop_Id)
- then
- exit;
+ if Scope.Entity = Standard_Standard
+ or else Is_Package_Or_Subprogram (Scope.Entity)
+ then
+ exit;
- elsif Scop_Rec.Is_Transient then
- return Scop_Id;
- end if;
+ elsif Scope.Is_Transient then
+ return Scope.Entity;
+ end if;
+ end;
end loop;
return Empty;
end Find_Enclosing_Transient_Scope;
+ ----------------------------
+ -- Find_Transient_Context --
+ ----------------------------
+
+ function Find_Transient_Context (N : Node_Id) return Node_Id is
+ Curr : Node_Id := N;
+ Prev : Node_Id := Empty;
+
+ begin
+ while Present (Curr) loop
+ case Nkind (Curr) is
+
+ -- Declarations
+
+ -- Declarations act as a boundary for a transient scope even if
+ -- they are not wrapped, see Wrap_Transient_Declaration.
+
+ when N_Object_Declaration
+ | N_Object_Renaming_Declaration
+ | N_Subtype_Declaration
+ =>
+ return Curr;
+
+ -- Statements
+
+ -- Statements and statement-like constructs act as a boundary
+ -- for a transient scope.
+
+ when N_Accept_Alternative
+ | N_Attribute_Definition_Clause
+ | N_Case_Statement
+ | N_Case_Statement_Alternative
+ | N_Code_Statement
+ | N_Delay_Alternative
+ | N_Delay_Until_Statement
+ | N_Delay_Relative_Statement
+ | N_Discriminant_Association
+ | N_Elsif_Part
+ | N_Entry_Body_Formal_Part
+ | N_Exit_Statement
+ | N_If_Statement
+ | N_Iteration_Scheme
+ | N_Terminate_Alternative
+ =>
+ pragma Assert (Present (Prev));
+ return Prev;
+
+ when N_Assignment_Statement =>
+ return Curr;
+
+ when N_Entry_Call_Statement
+ | N_Procedure_Call_Statement
+ =>
+ -- When an entry or procedure call acts as the alternative
+ -- of a conditional or timed entry call, the proper context
+ -- is that of the alternative.
+
+ if Nkind (Parent (Curr)) = N_Entry_Call_Alternative
+ and then Nkind (Parent (Parent (Curr))) in
+ N_Conditional_Entry_Call | N_Timed_Entry_Call
+ then
+ return Parent (Parent (Curr));
+
+ -- General case for entry or procedure calls
+
+ else
+ return Curr;
+ end if;
+
+ when N_Pragma =>
+
+ -- Pragma Check is not a valid transient context in
+ -- GNATprove mode because the pragma must remain unchanged.
+
+ if GNATprove_Mode
+ and then Get_Pragma_Id (Curr) = Pragma_Check
+ then
+ return Empty;
+
+ -- General case for pragmas
+
+ else
+ return Curr;
+ end if;
+
+ when N_Raise_Statement =>
+ return Curr;
+
+ when N_Simple_Return_Statement =>
+
+ -- A return statement is not a valid transient context when
+ -- the function itself requires transient scope management
+ -- because the result will be reclaimed too early.
+
+ if Requires_Transient_Scope (Etype
+ (Return_Applies_To (Return_Statement_Entity (Curr))))
+ then
+ return Empty;
+
+ -- General case for return statements
+
+ else
+ return Curr;
+ end if;
+
+ -- Special
+
+ when N_Attribute_Reference =>
+ if Is_Procedure_Attribute_Name (Attribute_Name (Curr)) then
+ return Curr;
+ end if;
+
+ -- An Ada 2012 iterator specification is not a valid context
+ -- because Analyze_Iterator_Specification already employs
+ -- special processing for it.
+
+ when N_Iterator_Specification =>
+ return Empty;
+
+ when N_Loop_Parameter_Specification =>
+
+ -- An iteration scheme is not a valid context because
+ -- routine Analyze_Iteration_Scheme already employs
+ -- special processing.
+
+ if Nkind (Parent (Curr)) = N_Iteration_Scheme then
+ return Empty;
+ else
+ return Parent (Curr);
+ end if;
+
+ -- Termination
+
+ -- The following nodes represent "dummy contexts" which do not
+ -- need to be wrapped.
+
+ when N_Component_Declaration
+ | N_Discriminant_Specification
+ | N_Parameter_Specification
+ =>
+ return Empty;
+
+ -- If the traversal leaves a scope without having been able to
+ -- find a construct to wrap, something is going wrong, but this
+ -- can happen in error situations that are not detected yet
+ -- (such as a dynamic string in a pragma Export).
+
+ when N_Block_Statement
+ | N_Entry_Body
+ | N_Package_Body
+ | N_Package_Declaration
+ | N_Protected_Body
+ | N_Subprogram_Body
+ | N_Task_Body
+ =>
+ return Empty;
+
+ -- Default
+
+ when others =>
+ null;
+ end case;
+
+ Prev := Curr;
+ Curr := Parent (Curr);
+ end loop;
+
+ return Empty;
+ end Find_Transient_Context;
+
------------------------------
-- Is_Package_Or_Subprogram --
------------------------------
@@ -5232,8 +5490,8 @@ package body Exp_Ch7 is
-- Start of processing for Establish_Transient_Scope
begin
- -- Do not create a new transient scope if there is an existing transient
- -- scope on the stack.
+ -- Do not create a new transient scope if there is already an enclosing
+ -- transient scope within the innermost enclosing package or subprogram.
if Present (Trans_Id) then
@@ -5247,9 +5505,8 @@ package body Exp_Ch7 is
return;
end if;
- -- At this point it is known that the scope stack is free of transient
- -- scopes. Locate the proper construct which must be serviced by a new
- -- transient scope.
+ -- Find the construct that must be serviced by a new transient scope, if
+ -- it exists.
Context := Find_Transient_Context (N);
@@ -5661,6 +5918,13 @@ package body Exp_Ch7 is
Build_Static_Dispatch_Tables (N);
end if;
+ -- If procedures marked with CUDA_Global have been defined within N,
+ -- we need to register them with the CUDA runtime at program startup.
+ -- This requires multiple declarations and function calls which need
+ -- to be appended to N's declarations.
+
+ Build_And_Insert_CUDA_Initialization (N);
+
Build_Task_Activation_Call (N);
-- Verify the run-time semantics of pragma Initial_Condition at the
@@ -5852,208 +6116,6 @@ package body Exp_Ch7 is
end if;
end Expand_N_Package_Declaration;
- ----------------------------
- -- Find_Transient_Context --
- ----------------------------
-
- function Find_Transient_Context (N : Node_Id) return Node_Id is
- Curr : Node_Id;
- Prev : Node_Id;
-
- begin
- Curr := N;
- Prev := Empty;
- while Present (Curr) loop
- case Nkind (Curr) is
-
- -- Declarations
-
- -- Declarations act as a boundary for a transient scope even if
- -- they are not wrapped, see Wrap_Transient_Declaration.
-
- when N_Object_Declaration
- | N_Object_Renaming_Declaration
- | N_Subtype_Declaration
- =>
- return Curr;
-
- -- Statements
-
- -- Statements and statement-like constructs act as a boundary for
- -- a transient scope.
-
- when N_Accept_Alternative
- | N_Attribute_Definition_Clause
- | N_Case_Statement
- | N_Case_Statement_Alternative
- | N_Code_Statement
- | N_Delay_Alternative
- | N_Delay_Until_Statement
- | N_Delay_Relative_Statement
- | N_Discriminant_Association
- | N_Elsif_Part
- | N_Entry_Body_Formal_Part
- | N_Exit_Statement
- | N_If_Statement
- | N_Iteration_Scheme
- | N_Terminate_Alternative
- =>
- pragma Assert (Present (Prev));
- return Prev;
-
- when N_Assignment_Statement =>
- return Curr;
-
- when N_Entry_Call_Statement
- | N_Procedure_Call_Statement
- =>
- -- When an entry or procedure call acts as the alternative of a
- -- conditional or timed entry call, the proper context is that
- -- of the alternative.
-
- if Nkind (Parent (Curr)) = N_Entry_Call_Alternative
- and then Nkind (Parent (Parent (Curr))) in
- N_Conditional_Entry_Call | N_Timed_Entry_Call
- then
- return Parent (Parent (Curr));
-
- -- General case for entry or procedure calls
-
- else
- return Curr;
- end if;
-
- when N_Pragma =>
-
- -- Pragma Check is not a valid transient context in GNATprove
- -- mode because the pragma must remain unchanged.
-
- if GNATprove_Mode
- and then Get_Pragma_Id (Curr) = Pragma_Check
- then
- return Empty;
-
- -- General case for pragmas
-
- else
- return Curr;
- end if;
-
- when N_Raise_Statement =>
- return Curr;
-
- when N_Simple_Return_Statement =>
-
- -- A return statement is not a valid transient context when the
- -- function itself requires transient scope management because
- -- the result will be reclaimed too early.
-
- if Requires_Transient_Scope (Etype
- (Return_Applies_To (Return_Statement_Entity (Curr))))
- then
- return Empty;
-
- -- General case for return statements
-
- else
- return Curr;
- end if;
-
- -- Special
-
- when N_Attribute_Reference =>
- if Is_Procedure_Attribute_Name (Attribute_Name (Curr)) then
- return Curr;
- end if;
-
- -- An Ada 2012 iterator specification is not a valid context
- -- because Analyze_Iterator_Specification already employs special
- -- processing for it.
-
- when N_Iterator_Specification =>
- return Empty;
-
- when N_Loop_Parameter_Specification =>
-
- -- An iteration scheme is not a valid context because routine
- -- Analyze_Iteration_Scheme already employs special processing.
-
- if Nkind (Parent (Curr)) = N_Iteration_Scheme then
- return Empty;
- else
- return Parent (Curr);
- end if;
-
- -- Termination
-
- -- The following nodes represent "dummy contexts" which do not
- -- need to be wrapped.
-
- when N_Component_Declaration
- | N_Discriminant_Specification
- | N_Parameter_Specification
- =>
- return Empty;
-
- -- If the traversal leaves a scope without having been able to
- -- find a construct to wrap, something is going wrong, but this
- -- can happen in error situations that are not detected yet (such
- -- as a dynamic string in a pragma Export).
-
- when N_Block_Statement
- | N_Entry_Body
- | N_Package_Body
- | N_Package_Declaration
- | N_Protected_Body
- | N_Subprogram_Body
- | N_Task_Body
- =>
- return Empty;
-
- -- Default
-
- when others =>
- null;
- end case;
-
- Prev := Curr;
- Curr := Parent (Curr);
- end loop;
-
- return Empty;
- end Find_Transient_Context;
-
- ----------------------------------
- -- Has_New_Controlled_Component --
- ----------------------------------
-
- function Has_New_Controlled_Component (E : Entity_Id) return Boolean is
- Comp : Entity_Id;
-
- begin
- if not Is_Tagged_Type (E) then
- return Has_Controlled_Component (E);
- elsif not Is_Derived_Type (E) then
- return Has_Controlled_Component (E);
- end if;
-
- Comp := First_Component (E);
- while Present (Comp) loop
- if Chars (Comp) = Name_uParent then
- null;
-
- elsif Scope (Original_Record_Component (Comp)) = E
- and then Needs_Finalization (Etype (Comp))
- then
- return True;
- end if;
-
- Next_Component (Comp);
- end loop;
-
- return False;
- end Has_New_Controlled_Component;
-
---------------------------------
-- Has_Simple_Protected_Object --
---------------------------------
@@ -8064,7 +8126,7 @@ package body Exp_Ch7 is
-- end if;
-- ...
- -- When Deep_Adjust is invokes for field _parent, a value of False is
+ -- When Deep_Adjust is invoked for field _parent, a value of False is
-- provided for the flag:
-- Deep_Adjust (Obj._parent, False);
@@ -8219,7 +8281,7 @@ package body Exp_Ch7 is
Loc : constant Source_Ptr := Sloc (Typ);
Typ_Def : constant Node_Id := Type_Definition (Parent (Typ));
- Counter : Int := 0;
+ Counter : Nat := 0;
Finalizer_Data : Finalization_Exception_Data;
function Process_Component_List_For_Finalize
@@ -9282,7 +9344,7 @@ package body Exp_Ch7 is
Dope_Id : Entity_Id;
begin
- -- Ensure that Ptr_Typ a thin pointer, generate:
+ -- Ensure that Ptr_Typ is a thin pointer; generate:
-- for Ptr_Typ'Size use System.Address'Size;
Append_To (Decls,
@@ -9824,15 +9886,6 @@ package body Exp_Ch7 is
end Node_To_Be_Wrapped;
----------------------------
- -- Set_Node_To_Be_Wrapped --
- ----------------------------
-
- procedure Set_Node_To_Be_Wrapped (N : Node_Id) is
- begin
- Scope_Stack.Table (Scope_Stack.Last).Node_To_Be_Wrapped := N;
- end Set_Node_To_Be_Wrapped;
-
- ----------------------------
-- Store_Actions_In_Scope --
----------------------------
@@ -9841,7 +9894,7 @@ package body Exp_Ch7 is
Actions : List_Id renames SE.Actions_To_Be_Wrapped (AK);
begin
- if No (Actions) then
+ if Is_Empty_List (Actions) then
Actions := L;
if Is_List_Member (SE.Node_To_Be_Wrapped) then
diff --git a/gcc/ada/exp_ch7.ads b/gcc/ada/exp_ch7.ads
index 5f75ab6..ef1bf67 100644
--- a/gcc/ada/exp_ch7.ads
+++ b/gcc/ada/exp_ch7.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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,17 +153,6 @@ package Exp_Ch7 is
-- triggered by an abort, E_Id denotes the defining identifier of a local
-- exception occurrence, Raised_Id is the entity of a local boolean flag.
- function CW_Or_Has_Controlled_Part (T : Entity_Id) return Boolean;
- -- True if T is a class-wide type, or if it has controlled parts ("part"
- -- means T or any of its subcomponents). Same as Needs_Finalization, except
- -- when pragma Restrictions (No_Finalization) applies, in which case we
- -- know that class-wide objects do not contain controlled parts.
-
- function Has_New_Controlled_Component (E : Entity_Id) return Boolean;
- -- E is a type entity. Give the same result as Has_Controlled_Component
- -- except for tagged extensions where the result is True only if the
- -- latest extension contains a controlled component.
-
function Make_Adjust_Call
(Obj_Ref : Node_Id;
Typ : Entity_Id;
diff --git a/gcc/ada/exp_ch8.adb b/gcc/ada/exp_ch8.adb
index facd12e..dba21ed 100644
--- a/gcc/ada/exp_ch8.adb
+++ b/gcc/ada/exp_ch8.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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,26 +23,30 @@
-- --
------------------------------------------------------------------------------
-with Atree; use Atree;
-with Einfo; use Einfo;
-with Exp_Ch3; use Exp_Ch3;
-with Exp_Ch4; use Exp_Ch4;
-with Exp_Ch6; use Exp_Ch6;
-with Exp_Dbug; use Exp_Dbug;
-with Exp_Util; use Exp_Util;
-with Freeze; use Freeze;
-with Namet; use Namet;
-with Nmake; use Nmake;
-with Nlists; use Nlists;
-with Opt; use Opt;
-with Sem; use Sem;
-with Sem_Aux; use Sem_Aux;
-with Sem_Ch8; use Sem_Ch8;
-with Sem_Util; use Sem_Util;
-with Sinfo; use Sinfo;
-with Snames; use Snames;
-with Stand; use Stand;
-with Tbuild; use Tbuild;
+with Atree; use Atree;
+with Einfo; use Einfo;
+with Einfo.Entities; use Einfo.Entities;
+with Einfo.Utils; use Einfo.Utils;
+with Exp_Ch3; use Exp_Ch3;
+with Exp_Ch4; use Exp_Ch4;
+with Exp_Ch6; use Exp_Ch6;
+with Exp_Dbug; use Exp_Dbug;
+with Exp_Util; use Exp_Util;
+with Freeze; use Freeze;
+with Namet; use Namet;
+with Nmake; use Nmake;
+with Nlists; use Nlists;
+with Opt; use Opt;
+with Sem; use Sem;
+with Sem_Aux; use Sem_Aux;
+with Sem_Ch8; use Sem_Ch8;
+with Sem_Util; use Sem_Util;
+with Sinfo; use Sinfo;
+with Sinfo.Nodes; use Sinfo.Nodes;
+with Sinfo.Utils; use Sinfo.Utils;
+with Snames; use Snames;
+with Stand; use Stand;
+with Tbuild; use Tbuild;
package body Exp_Ch8 is
@@ -72,7 +76,7 @@ package body Exp_Ch8 is
-- clause applies (that can specify an arbitrary bit boundary), or where
-- the enclosing record itself has a non-standard representation.
- -- In Ada 2020, a third case arises when the renamed object is a nonatomic
+ -- In Ada 2022, a third case arises when the renamed object is a nonatomic
-- subcomponent of an atomic object, because reads of or writes to it must
-- access the enclosing atomic object. That's also the case for an object
-- subject to the Volatile_Full_Access GNAT aspect/pragma in any language
diff --git a/gcc/ada/exp_ch8.ads b/gcc/ada/exp_ch8.ads
index f3c5343..64ffae1 100644
--- a/gcc/ada/exp_ch8.ads
+++ b/gcc/ada/exp_ch8.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute 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 b055b27..427b430 100644
--- a/gcc/ada/exp_ch9.adb
+++ b/gcc/ada/exp_ch9.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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,49 +23,53 @@
-- --
------------------------------------------------------------------------------
-with Atree; use Atree;
-with Aspects; use Aspects;
-with Checks; use Checks;
-with Einfo; use Einfo;
-with Elists; use Elists;
-with Errout; use Errout;
-with Exp_Ch3; use Exp_Ch3;
-with Exp_Ch6; use Exp_Ch6;
-with Exp_Ch11; use Exp_Ch11;
-with Exp_Dbug; use Exp_Dbug;
-with Exp_Sel; use Exp_Sel;
-with Exp_Smem; use Exp_Smem;
-with Exp_Tss; use Exp_Tss;
-with Exp_Util; use Exp_Util;
-with Freeze; use Freeze;
+with Atree; use Atree;
+with Aspects; use Aspects;
+with Checks; use Checks;
+with Einfo; use Einfo;
+with Einfo.Entities; use Einfo.Entities;
+with Einfo.Utils; use Einfo.Utils;
+with Elists; use Elists;
+with Errout; use Errout;
+with Exp_Ch3; use Exp_Ch3;
+with Exp_Ch6; use Exp_Ch6;
+with Exp_Ch11; use Exp_Ch11;
+with Exp_Dbug; use Exp_Dbug;
+with Exp_Sel; use Exp_Sel;
+with Exp_Smem; use Exp_Smem;
+with Exp_Tss; use Exp_Tss;
+with Exp_Util; use Exp_Util;
+with Freeze; use Freeze;
with Hostparm;
-with Itypes; use Itypes;
-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 Rtsfind; use Rtsfind;
-with Sem; use Sem;
-with Sem_Aux; use Sem_Aux;
-with Sem_Ch5; use Sem_Ch5;
-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_Res; use Sem_Res;
-with Sem_Util; use Sem_Util;
-with Sinfo; use Sinfo;
-with Snames; use Snames;
-with Stand; use Stand;
-with Targparm; use Targparm;
-with Tbuild; use Tbuild;
-with Uintp; use Uintp;
-with Validsw; use Validsw;
+with Itypes; use Itypes;
+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 Rtsfind; use Rtsfind;
+with Sem; use Sem;
+with Sem_Aux; use Sem_Aux;
+with Sem_Ch5; use Sem_Ch5;
+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_Res; use Sem_Res;
+with Sem_Util; use Sem_Util;
+with Sinfo; use Sinfo;
+with Sinfo.Nodes; use Sinfo.Nodes;
+with Sinfo.Utils; use Sinfo.Utils;
+with Snames; use Snames;
+with Stand; use Stand;
+with Targparm; use Targparm;
+with Tbuild; use Tbuild;
+with Uintp; use Uintp;
+with Validsw; use Validsw;
package body Exp_Ch9 is
@@ -120,7 +124,7 @@ package body Exp_Ch9 is
function Build_Barrier_Function
(N : Node_Id;
Ent : Entity_Id;
- Pid : Node_Id) return Node_Id;
+ Pid : Entity_Id) return Node_Id;
-- Build the function body returning the value of the barrier expression
-- for the specified entry body.
@@ -278,7 +282,11 @@ package body Exp_Ch9 is
Concval : Node_Id;
Ename : Node_Id;
Index : Node_Id);
- -- Some comments here would be useful ???
+ -- Build the call corresponding to the task entry call. N is the task entry
+ -- call, Concval is the concurrent object, Ename is the entry name and
+ -- Index is the entry family index.
+ -- Note that N might be expanded into an N_Block_Statement if it gets
+ -- inlined.
function Build_Task_Proc_Specification (T : Entity_Id) return Node_Id;
-- This routine constructs a specification for the procedure that we will
@@ -735,9 +743,9 @@ package body Exp_Ch9 is
Set_Debug_Info_Needed (New_F);
if Ekind (Formal) = E_In_Parameter then
- Set_Ekind (New_F, E_Constant);
+ Mutate_Ekind (New_F, E_Constant);
else
- Set_Ekind (New_F, E_Variable);
+ Mutate_Ekind (New_F, E_Variable);
Set_Extra_Constrained (New_F, Extra_Constrained (Formal));
end if;
@@ -837,7 +845,7 @@ package body Exp_Ch9 is
Insert_Before (Last (Statements (Stats)), Call);
Analyze (Call);
- -- Ada 2020 (AI12-0279)
+ -- Ada 2022 (AI12-0279)
if Has_Yield_Aspect (Entity (Entry_Direct_Name (Astat)))
and then RTE_Available (RE_Yield)
@@ -860,7 +868,7 @@ package body Exp_Ch9 is
Append (Call, Statements (Hand));
Analyze (Call);
- -- Ada 2020 (AI12-0279)
+ -- Ada 2022 (AI12-0279)
if Has_Yield_Aspect (Entity (Entry_Direct_Name (Astat)))
and then RTE_Available (RE_Yield)
@@ -913,7 +921,7 @@ package body Exp_Ch9 is
Statements => New_List (Call))));
- -- Ada 2020 (AI12-0279)
+ -- Ada 2022 (AI12-0279)
if Has_Yield_Aspect (Entity (Entry_Direct_Name (Astat)))
and then RTE_Available (RE_Yield)
@@ -1052,7 +1060,7 @@ package body Exp_Ch9 is
function Build_Barrier_Function
(N : Node_Id;
Ent : Entity_Id;
- Pid : Node_Id) return Node_Id
+ Pid : Entity_Id) return Node_Id
is
Ent_Formals : constant Node_Id := Entry_Body_Formal_Part (N);
Cond : constant Node_Id := Condition (Ent_Formals);
@@ -1589,7 +1597,7 @@ package body Exp_Ch9 is
begin
Set_Corresponding_Record_Type (Ctyp, Rec_Ent);
- Set_Ekind (Rec_Ent, E_Record_Type);
+ Mutate_Ekind (Rec_Ent, E_Record_Type);
Set_Has_Delayed_Freeze (Rec_Ent, Has_Delayed_Freeze (Ctyp));
Set_Is_Concurrent_Record_Type (Rec_Ent, True);
Set_Corresponding_Concurrent_Type (Rec_Ent, Ctyp);
@@ -1752,34 +1760,21 @@ package body Exp_Ch9 is
-- Generate a dummy master if tasks or tasking hierarchies are
-- prohibited.
- -- _Master : constant Master_Id := 3;
+ -- _Master : constant Integer := Library_Task_Level;
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;
+ 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_Integer_Literal (Loc, Library_Task_Level));
-- Generate:
-- _master : constant Integer := Current_Master.all;
@@ -2449,9 +2444,9 @@ package body Exp_Ch9 is
-- Sem_Ch6.Override_Dispatching_Operation.
if Ekind (Subp_Id) = E_Function then
- Set_Ekind (Wrapper_Id, E_Function);
+ Mutate_Ekind (Wrapper_Id, E_Function);
else
- Set_Ekind (Wrapper_Id, E_Procedure);
+ Mutate_Ekind (Wrapper_Id, E_Procedure);
end if;
Set_Is_Primitive_Wrapper (Wrapper_Id);
@@ -3624,7 +3619,8 @@ package body Exp_Ch9 is
Master_Decl :=
Make_Object_Renaming_Declaration (Loc,
Defining_Identifier => Master_Id,
- Subtype_Mark => New_Occurrence_Of (RTE (RE_Master_Id), Loc),
+ Subtype_Mark =>
+ New_Occurrence_Of (Standard_Integer, Loc),
Name => Make_Identifier (Loc, Name_uMaster));
Insert_Action (Context, Master_Decl);
@@ -3775,10 +3771,6 @@ package body Exp_Ch9 is
raise Program_Error;
end case;
- -- Establish link between subprogram body entity and source entry
-
- Set_Corresponding_Protected_Entry (Bod_Id, Ent);
-
-- Create body of entry procedure. The renaming declarations are
-- placed ahead of the block that contains the actual entry body.
@@ -3812,6 +3804,10 @@ package body Exp_Ch9 is
New_Occurrence_Of
(RTE (RE_Get_GNAT_Exception), Loc)))))))));
+ -- Establish link between subprogram body and source entry body
+
+ Set_Corresponding_Entry_Body (Proc_Body, N);
+
Reset_Scopes_To (Proc_Body, Protected_Body_Subprogram (Ent));
return Proc_Body;
end if;
@@ -3889,7 +3885,7 @@ package body Exp_Ch9 is
if Unprotected then
Set_Protected_Formal (Formal, Defining_Identifier (New_Param));
- Set_Ekind (Defining_Identifier (New_Param), Ekind (Formal));
+ Mutate_Ekind (Defining_Identifier (New_Param), Ekind (Formal));
end if;
Append (New_Param, New_Plist);
@@ -3960,14 +3956,14 @@ package body Exp_Ch9 is
-- Sem_Ch4.Names_Match).
if Mode = Dispatching_Mode then
- Set_Ekind (New_Id, Ekind (Def_Id));
+ Mutate_Ekind (New_Id, Ekind (Def_Id));
Set_Original_Protected_Subprogram (New_Id, Def_Id);
end if;
-- Link the protected or unprotected version to the original subprogram
-- it emulates.
- Set_Ekind (New_Id, Ekind (Def_Id));
+ Mutate_Ekind (New_Id, Ekind (Def_Id));
Set_Protected_Subprogram (New_Id, Def_Id);
-- The unprotected operation carries the user code, and debugging
@@ -6003,9 +5999,9 @@ package body Exp_Ch9 is
Set_Debug_Info_Needed (New_F);
if Ekind (Formal) = E_In_Parameter then
- Set_Ekind (New_F, E_Constant);
+ Mutate_Ekind (New_F, E_Constant);
else
- Set_Ekind (New_F, E_Variable);
+ Mutate_Ekind (New_F, E_Variable);
Set_Extra_Constrained (New_F, Extra_Constrained (Formal));
end if;
@@ -6205,11 +6201,11 @@ package body Exp_Ch9 is
begin
if Is_Static_Expression (N) then
return True;
- elsif Ada_Version >= Ada_2020
+ elsif Ada_Version >= Ada_2022
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
+ -- Restriction relaxed in Ada 2022 to allow statically named
-- subcomponents.
return Is_Simple_Barrier (Prefix (N));
end if;
@@ -6322,8 +6318,8 @@ package body Exp_Ch9 is
end if;
when N_Short_Circuit
- | N_If_Expression
- | N_Case_Expression
+ | N_If_Expression
+ | N_Case_Expression
=>
return OK;
@@ -6514,14 +6510,12 @@ package body Exp_Ch9 is
-- Task_Id (Tasknm._disp_get_task_id)
- Make_Unchecked_Type_Conversion (Loc,
- Subtype_Mark =>
- New_Occurrence_Of (RTE (RO_ST_Task_Id), Loc),
- Expression =>
- Make_Selected_Component (Loc,
- Prefix => New_Copy_Tree (Tasknm),
- Selector_Name =>
- Make_Identifier (Loc, Name_uDisp_Get_Task_Id)))));
+ Unchecked_Convert_To
+ (RTE (RO_ST_Task_Id),
+ Make_Selected_Component (Loc,
+ Prefix => New_Copy_Tree (Tasknm),
+ Selector_Name =>
+ Make_Identifier (Loc, Name_uDisp_Get_Task_Id)))));
else
Append_To (Component_Associations (Aggr),
@@ -6664,7 +6658,7 @@ package body Exp_Ch9 is
Analyze (N);
- -- Ada 2020 (AI12-0279)
+ -- Ada 2022 (AI12-0279)
if Has_Yield_Aspect (Eent)
and then RTE_Available (RE_Yield)
@@ -6689,7 +6683,7 @@ package body Exp_Ch9 is
-- statement if any to initialize the declarations of the block.
Blkent := Make_Temporary (Loc, 'A');
- Set_Ekind (Blkent, E_Block);
+ Mutate_Ekind (Blkent, E_Block);
Set_Etype (Blkent, Standard_Void_Type);
Set_Scope (Blkent, Current_Scope);
@@ -7246,10 +7240,9 @@ package body Exp_Ch9 is
Make_Assignment_Statement (Loc,
Name => New_Occurrence_Of (Bnn, Loc),
Expression =>
- Make_Unchecked_Type_Conversion (Loc,
- Subtype_Mark =>
- New_Occurrence_Of (RTE (RE_Communication_Block), Loc),
- Expression => Make_Identifier (Loc, Name_uD))));
+ Unchecked_Convert_To
+ (RTE (RE_Communication_Block),
+ Make_Identifier (Loc, Name_uD))));
-- Generate:
-- _Disp_Asynchronous_Select (<object>, S, P'Address, D, B);
@@ -7365,10 +7358,9 @@ package body Exp_Ch9 is
Name =>
New_Occurrence_Of (Bnn, Loc),
Expression =>
- Make_Unchecked_Type_Conversion (Loc,
- Subtype_Mark =>
- New_Occurrence_Of (RTE (RE_Communication_Block), Loc),
- Expression => Make_Identifier (Loc, Name_uD))));
+ Unchecked_Convert_To
+ (RTE (RE_Communication_Block),
+ Make_Identifier (Loc, Name_uD))));
-- Generate:
-- _Disp_Asynchronous_Select (<object>, S, P'Address, D, B);
@@ -10881,7 +10873,7 @@ package body Exp_Ch9 is
-- Link the acceptor to the original receiving entry
- Set_Ekind (PB_Ent, E_Procedure);
+ Mutate_Ekind (PB_Ent, E_Procedure);
Set_Receiving_Entry (PB_Ent, Eent);
if Comes_From_Source (Alt) then
@@ -11001,7 +10993,7 @@ package body Exp_Ch9 is
Entry_Id : constant Entity_Id :=
Entity (Entry_Direct_Name (Accept_Statement (Alt)));
begin
- -- Ada 2020 (AI12-0279)
+ -- Ada 2022 (AI12-0279)
if Has_Yield_Aspect (Entry_Id)
and then RTE_Available (RE_Yield)
@@ -13816,9 +13808,9 @@ package body Exp_Ch9 is
-- Minimal decoration
if Ekind (Spec_Id) = E_Function then
- Set_Ekind (Decl_Id, E_Constant);
+ Mutate_Ekind (Decl_Id, E_Constant);
else
- Set_Ekind (Decl_Id, E_Variable);
+ Mutate_Ekind (Decl_Id, E_Variable);
end if;
Set_Prival (Comp_Id, Decl_Id);
@@ -13868,7 +13860,7 @@ package body Exp_Ch9 is
begin
-- Minimal decoration
- Set_Ekind (Index_Con, E_Constant);
+ Mutate_Ekind (Index_Con, E_Constant);
Set_Entry_Index_Constant (Index, Index_Con);
Set_Discriminal_Link (Index_Con, Index);
@@ -13972,9 +13964,7 @@ package body Exp_Ch9 is
begin
return Scope (Base_Index) = Standard_Standard
and then Base_Index = Base_Type (Standard_Integer)
- and then Has_Discriminants (Conctyp)
- and then
- Present (Discriminant_Default_Value (First_Discriminant (Conctyp)))
+ and then Has_Defaulted_Discriminants (Conctyp)
and then
(Denotes_Discriminant (Lo, True)
or else
@@ -14708,8 +14698,7 @@ package body Exp_Ch9 is
if Restriction_Active (No_Task_Hierarchy) = False then
Append_To (Args, Make_Identifier (Loc, Name_uMaster));
else
- Append_To (Args,
- New_Occurrence_Of (RTE (RE_Library_Task_Level), Loc));
+ Append_To (Args, Make_Integer_Literal (Loc, Library_Task_Level));
end if;
end if;
@@ -15142,7 +15131,7 @@ package body Exp_Ch9 is
Make_Defining_Identifier (Sloc (D),
Chars => New_External_Name (Chars (D), 'D'));
- Set_Ekind (D_Minal, E_Constant);
+ Mutate_Ekind (D_Minal, E_Constant);
Set_Etype (D_Minal, Etype (D));
Set_Scope (D_Minal, Pdef);
Set_Discriminal (D, D_Minal);
diff --git a/gcc/ada/exp_ch9.ads b/gcc/ada/exp_ch9.ads
index 59930a6..ae3054d 100644
--- a/gcc/ada/exp_ch9.ads
+++ b/gcc/ada/exp_ch9.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute 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.adb b/gcc/ada/exp_code.adb
index 4f4f763..50d45bc 100644
--- a/gcc/ada/exp_code.adb
+++ b/gcc/ada/exp_code.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1996-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1996-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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,22 +23,26 @@
-- --
------------------------------------------------------------------------------
-with Atree; use Atree;
-with Einfo; use Einfo;
-with Errout; use Errout;
-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_Eval; use Sem_Eval;
-with Sem_Util; use Sem_Util;
-with Sem_Warn; use Sem_Warn;
-with Sinfo; use Sinfo;
-with Stringt; use Stringt;
-with Tbuild; use Tbuild;
+with Atree; use Atree;
+with Einfo; use Einfo;
+with Einfo.Entities; use Einfo.Entities;
+with Einfo.Utils; use Einfo.Utils;
+with Errout; use Errout;
+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_Eval; use Sem_Eval;
+with Sem_Util; use Sem_Util;
+with Sem_Warn; use Sem_Warn;
+with Sinfo; use Sinfo;
+with Sinfo.Nodes; use Sinfo.Nodes;
+with Sinfo.Utils; use Sinfo.Utils;
+with Stringt; use Stringt;
+with Tbuild; use Tbuild;
package body Exp_Code is
diff --git a/gcc/ada/exp_code.ads b/gcc/ada/exp_code.ads
index 80f6535..474eafc 100644
--- a/gcc/ada/exp_code.ads
+++ b/gcc/ada/exp_code.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1996-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1996-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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,7 @@ package Exp_Code is
-- with subsequent calls to Clobber_Get_Next.
function Clobber_Get_Next return System.Address;
+ pragma Convention (C, Clobber_Get_Next);
-- Can only be called after a previous call to Clobber_Setup. The
-- returned value is a pointer to a null terminated (C format) string
-- for the next register argument. Null_Address is returned when there
diff --git a/gcc/ada/exp_dbug.adb b/gcc/ada/exp_dbug.adb
index bb0003d..bfc3b33 100644
--- a/gcc/ada/exp_dbug.adb
+++ b/gcc/ada/exp_dbug.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1996-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1996-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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,23 +24,27 @@
------------------------------------------------------------------------------
with Alloc;
-with Atree; use Atree;
-with Debug; use Debug;
-with Einfo; use Einfo;
-with Exp_Util; use Exp_Util;
-with Nlists; use Nlists;
-with Nmake; use Nmake;
-with Opt; use Opt;
-with Output; use Output;
-with Sem_Aux; use Sem_Aux;
-with Sem_Eval; use Sem_Eval;
-with Sem_Util; use Sem_Util;
-with Sinfo; use Sinfo;
-with Stand; use Stand;
-with Stringt; use Stringt;
+with Atree; use Atree;
+with Debug; use Debug;
+with Einfo; use Einfo;
+with Einfo.Entities; use Einfo.Entities;
+with Einfo.Utils; use Einfo.Utils;
+with Exp_Util; use Exp_Util;
+with Nlists; use Nlists;
+with Nmake; use Nmake;
+with Opt; use Opt;
+with Output; use Output;
+with Sem_Aux; use Sem_Aux;
+with Sem_Eval; use Sem_Eval;
+with Sem_Util; use Sem_Util;
+with Sinfo; use Sinfo;
+with Sinfo.Nodes; use Sinfo.Nodes;
+with Sinfo.Utils; use Sinfo.Utils;
+with Stand; use Stand;
+with Stringt; use Stringt;
with Table;
-with Tbuild; use Tbuild;
-with Urealp; use Urealp;
+with Tbuild; use Tbuild;
+with Urealp; use Urealp;
package body Exp_Dbug is
@@ -315,8 +319,11 @@ package body Exp_Dbug is
-- output in one of these two forms. The result is prepended to the
-- name stored in Name_Buffer.
- function Scope_Contains (Sc : Node_Id; Ent : Entity_Id) return Boolean;
- -- Return whether Ent belong to the Sc scope
+ function Scope_Contains
+ (Outer : Entity_Id;
+ Inner : Entity_Id)
+ return Boolean;
+ -- Return whether Inner belongs to the Outer scope
----------------------------
-- Enable_If_Packed_Array --
@@ -344,8 +351,7 @@ package body Exp_Dbug is
elsif Nkind (N) = N_Identifier
and then Scope_Contains (Scope (Entity (N)), Ent)
- and then (Ekind (Entity (N)) = E_Constant
- or else Ekind (Entity (N)) = E_In_Parameter)
+ and then Ekind (Entity (N)) in E_Constant | E_In_Parameter
then
Prepend_String_To_Buffer (Get_Name_String (Chars (Entity (N))));
@@ -361,12 +367,16 @@ package body Exp_Dbug is
-- Scope_Contains --
--------------------
- function Scope_Contains (Sc : Node_Id; Ent : Entity_Id) return Boolean is
- Cur : Node_Id := Scope (Ent);
+ function Scope_Contains
+ (Outer : Entity_Id;
+ Inner : Entity_Id)
+ return Boolean
+ is
+ Cur : Entity_Id := Scope (Inner);
begin
while Present (Cur) loop
- if Cur = Sc then
+ if Cur = Outer then
return True;
end if;
@@ -645,10 +655,10 @@ package body Exp_Dbug is
Has_Suffix := True;
- -- Fixed-point case: generate GNAT encodings when asked to
+ -- Generate GNAT encodings when asked to for fixed-point case
- if Is_Fixed_Point_Type (E)
- and then GNAT_Encodings = DWARF_GNAT_Encodings_All
+ if GNAT_Encodings = DWARF_GNAT_Encodings_All
+ and then Is_Fixed_Point_Type (E)
then
Get_External_Name (E, True, "XF_");
Add_Real_To_Buffer (Delta_Value (E));
@@ -658,10 +668,9 @@ package body Exp_Dbug is
Add_Real_To_Buffer (Small_Value (E));
end if;
- -- Discrete case where bounds do not match size. Not necessary if we can
- -- emit standard DWARF.
+ -- Likewise for discrete case where bounds do not match size
- elsif GNAT_Encodings /= DWARF_GNAT_Encodings_Minimal
+ elsif GNAT_Encodings = DWARF_GNAT_Encodings_All
and then Is_Discrete_Type (E)
and then not Bounds_Match_Size (E)
then
@@ -1547,7 +1556,7 @@ package body Exp_Dbug is
then
Set_BNPE_Suffix (Ent);
- -- Strip trailing n's and last trailing b as required. note that
+ -- Strip trailing n's and last trailing b as required. Note that
-- we know there is at least one b, or no suffix would be generated.
while Name_Buffer (Name_Len) = 'n' loop
diff --git a/gcc/ada/exp_dbug.ads b/gcc/ada/exp_dbug.ads
index 1461f6d..09921f0 100644
--- a/gcc/ada/exp_dbug.ads
+++ b/gcc/ada/exp_dbug.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1996-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1996-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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,9 +23,11 @@
-- --
------------------------------------------------------------------------------
--- Expand routines for generation of special declarations used by the
--- debugger. In accordance with the Dwarf 2.2 specification, certain
--- type names are encoded to provide information to the debugger.
+-- Expand routines for the generation of special declarations used by the
+-- debugger. In accordance with the DWARF specification, certain type names
+-- may also be encoded to provide additional information to the debugger, but
+-- this practice is being deprecated and some encodings described below are no
+-- longer generated by default (they are marked OBSOLETE).
with Namet; use Namet;
with Types; use Types;
@@ -496,53 +498,104 @@ package Exp_Dbug is
-- corresponding positive value followed by a lower case m for minus to
-- indicate that the value is negative (e.g. 2m for -2).
- -------------------------
- -- Type Name Encodings --
- -------------------------
+ ------------------------
+ -- Encapsulated Types --
+ ------------------------
+
+ -- In some cases, the compiler may encapsulate a type by wrapping it in a
+ -- record. For example, this is used when a size or alignment specification
+ -- requires a larger type. Consider:
+
+ -- type x is mod 2 ** 64;
+ -- for x'size use 256;
+
+ -- In this case, the compiler generates a record type x___PAD, which has
+ -- a single field whose name is F. This single field is 64-bit long and
+ -- contains the actual value. This kind of padding is used when the logical
+ -- value to be stored is shorter than the object in which it is allocated.
+
+ -- A similar encapsulation is done for some packed array types, in which
+ -- case the record type is x___JM and the field name is OBJECT. This is
+ -- used in the case of a packed array stored using modular representation
+ -- (see the section on representation of packed array objects). In this
+ -- case the wrapping is used to achieve correct positioning of the packed
+ -- array value (left/right justified in its field depending on endianness).
+
+ -- When the debugger sees an object of a type whose name has a suffix of
+ -- ___PAD or ___JM, the type will be a record containing a single field,
+ -- and the name of that field will be all upper case. In this case, it
+ -- should look inside to get the value of the inner field, and neither
+ -- the outer structure name, nor the field name should appear when the
+ -- value is printed.
+
+ -- Similarly, when the debugger sees a record named REP being the type of
+ -- a field inside another record type, it should treat the fields inside
+ -- REP as being part of the outer record (this REP field is only present
+ -- for code generation purposes). The REP record should not appear in the
+ -- values printed by the debugger.
+
+ --------------------
+ -- Implicit Types --
+ --------------------
+
+ -- The compiler creates implicit type names in many situations where a
+ -- type is present semantically, but no specific name is present. For
+ -- example:
+
+ -- S : Integer range M .. N;
+
+ -- Here the subtype of S is not integer, but rather an anonymous subtype
+ -- of Integer. Where possible, the compiler generates names for such
+ -- anonymous types that are related to the type from which the subtype
+ -- is obtained as follows:
+
+ -- T name suffix
+
+ -- where name is the name from which the subtype is obtained, using
+ -- lower case letters and underscores, and suffix starts with an upper
+ -- case letter. For example the name for the above declaration might be:
+
+ -- TintegerS4b
+
+ -- If the debugger is asked to give the type of an entity and the type
+ -- has the form T name suffix, it is probably appropriate to just use
+ -- "name" in the response since this is what is meaningful to the
+ -- programmer.
+
+ -------------------
+ -- Modular Types --
+ -------------------
+
+ -- A type declared
+
+ -- type x is mod N;
+
+ -- is encoded as a subrange of an unsigned base type with lower bound zero
+ -- and upper bound N - 1. Thus we give these types a somewhat nonstandard
+ -- interpretation: the standard interpretation would not, in general, imply
+ -- that arithmetic operations on type x are performed modulo N (especially
+ -- not when N is not a power of 2).
+
+ --------------------------------------
+ -- Tagged Types and Type Extensions --
+ --------------------------------------
+
+ -- A type D derived from a tagged type P has a field named "_parent" of
+ -- type P that contains its inherited fields. The type of this field is
+ -- usually P, but may be a more distant ancestor, if P is a null extension
+ -- of that type.
+
+ -- The type tag of a tagged type is a field named "_tag" of a pointer type.
+ -- If the type is derived from another tagged type, its _tag field is found
+ -- in its _parent field.
+
+ ------------------------------------
+ -- Type Name Encodings (OBSOLETE) --
+ ------------------------------------
-- In the following typ is the name of the type as normally encoded by the
-- debugger rules, i.e. a non-qualified name, all in lower case, with
- -- standard encoding of upper half and wide characters
-
- ------------------------
- -- Encapsulated Types --
- ------------------------
-
- -- In some cases, the compiler encapsulates a type by wrapping it in a
- -- structure. For example, this is used when a size or alignment
- -- specification requires a larger type. Consider:
-
- -- type y is mod 2 ** 64;
- -- for y'size use 256;
-
- -- In this case the compile generates a structure type y___PAD, which
- -- has a single field whose name is F. This single field is 64 bits
- -- long and contains the actual value. This kind of padding is used
- -- when the logical value to be stored is shorter than the object in
- -- which it is allocated. For example if a size clause is used to set
- -- a size of 256 for a signed integer value, then a typical choice is
- -- to wrap a 64-bit integer in a 256 bit PAD structure.
-
- -- A similar encapsulation is done for some packed array types, in which
- -- case the structure type is y___JM and the field name is OBJECT.
- -- This is used in the case of a packed array stored using modular
- -- representation (see section on representation of packed array
- -- objects). In this case the JM wrapping is used to achieve correct
- -- positioning of the packed array value (left or right justified in its
- -- field depending on endianness.
-
- -- When the debugger sees an object of a type whose name has a suffix of
- -- ___PAD or ___JM, the type will be a record containing a single field,
- -- and the name of that field will be all upper case. In this case, it
- -- should look inside to get the value of the inner field, and neither
- -- the outer structure name, nor the field name should appear when the
- -- value is printed.
-
- -- When the debugger sees a record named REP being a field inside
- -- another record, it should treat the fields inside REP as being part
- -- of the outer record (this REP field is only present for code
- -- generation purposes). The REP record should not appear in the values
- -- printed by the debugger.
+ -- standard encoding of upper half and wide characters.
-----------------------
-- Fixed-Point Types --
@@ -613,22 +666,6 @@ package Exp_Dbug is
-- or compile time known values, with the encoding first for the lower
-- bound, then for the upper bound, as previously described.
- -------------------
- -- Modular Types --
- -------------------
-
- -- A type declared
-
- -- type x is mod N;
-
- -- Is encoded as a subrange of an unsigned base type with lower bound
- -- zero and upper bound N. That is, there is no name encoding. We use
- -- the standard encodings provided by the debugging format. Thus we
- -- give these types a non-standard interpretation: the standard
- -- interpretation of our encoding would not, in general, imply that
- -- arithmetic on type x was to be performed modulo N (especially not
- -- when N is not a power of 2).
-
------------------
-- Biased Types --
------------------
@@ -887,34 +924,6 @@ package Exp_Dbug is
-- redundantly, particularly in the fixed-point case, but this
-- information can in any case be ignored by the debugger.
- ----------------------------
- -- Note on Implicit Types --
- ----------------------------
-
- -- The compiler creates implicit type names in many situations where a
- -- type is present semantically, but no specific name is present. For
- -- example:
-
- -- S : Integer range M .. N;
-
- -- Here the subtype of S is not integer, but rather an anonymous subtype
- -- of Integer. Where possible, the compiler generates names for such
- -- anonymous types that are related to the type from which the subtype
- -- is obtained as follows:
-
- -- T name suffix
-
- -- where name is the name from which the subtype is obtained, using
- -- lower case letters and underscores, and suffix starts with an upper
- -- case letter. For example the name for the above declaration might be:
-
- -- TintegerS4b
-
- -- If the debugger is asked to give the type of an entity and the type
- -- has the form T name suffix, it is probably appropriate to just use
- -- "name" in the response since this is what is meaningful to the
- -- programmer.
-
-------------------------------------------------
-- Subprograms for Handling Encoded Type Names --
-------------------------------------------------
@@ -1062,51 +1071,6 @@ package Exp_Dbug is
-- debug declaration, then Empty is returned. This function also takes care
-- of setting Materialize_Entity on the renamed entity where required.
- ---------------------------
- -- Packed Array Encoding --
- ---------------------------
-
- -- For every constrained packed array, two types are created, and both
- -- appear in the debugging output:
-
- -- The original declared array type is a perfectly normal array type, and
- -- its index bounds indicate the original bounds of the array.
-
- -- The corresponding packed array type, which may be a modular type, or
- -- may be an array of bytes type (see Exp_Pakd for full details). This is
- -- the type that is actually used in the generated code and for debugging
- -- information for all objects of the packed type.
-
- -- The name of the corresponding packed array type is:
-
- -- ttt___XPnnn
-
- -- where
-
- -- ttt is the name of the original declared array
- -- nnn is the component size in bits (1-31)
-
- -- Note that if the packed array is not bit-packed, the name will simply
- -- be tttP.
-
- -- When the debugger sees that an object is of a type that is encoded in
- -- this manner, it can use the original type to determine the bounds and
- -- the component type, and the component size to determine the packing
- -- details.
-
- -- For an unconstrained packed array, the corresponding packed array type
- -- is neither used in the generated code nor for debugging information,
- -- only the original type is used. In order to convey the packing in the
- -- debugging information, the compiler generates the associated fat- and
- -- thin-pointer types (see the Pointers to Unconstrained Array section
- -- below) using the name of the corresponding packed array type as the
- -- base name, i.e. ttt___XPnnn___XUP and ttt___XPnnn___XUT respectively.
-
- -- When the debugger sees that an object is of a type that is encoded in
- -- this manner, it can use the type of the fields to determine the bounds
- -- and the component type, and the component size to determine the packing
- -- details.
-
-------------------------------------------
-- Packed Array Representation in Memory --
-------------------------------------------
@@ -1204,6 +1168,51 @@ package Exp_Dbug is
-- would mean that an assignment such as a := above would require shifts
-- when one value is in a register and the other value is in memory.
+ -------------------------------------------
+ -- Packed Array Name Encoding (OBSOLETE) --
+ -------------------------------------------
+
+ -- For every constrained packed array, two types are created, and both
+ -- appear in the debugging output:
+
+ -- The original declared array type is a perfectly normal array type, and
+ -- its index bounds indicate the original bounds of the array.
+
+ -- The corresponding packed array type, which may be a modular type, or
+ -- may be an array of bytes type (see Exp_Pakd for full details). This is
+ -- the type that is actually used in the generated code and for debugging
+ -- information for all objects of the packed type.
+
+ -- The name of the corresponding packed array type is:
+
+ -- ttt___XPnnn
+
+ -- where
+
+ -- ttt is the name of the original declared array
+ -- nnn is the component size in bits (1-31)
+
+ -- Note that if the packed array is not bit-packed, the name will simply
+ -- be tttP.
+
+ -- When the debugger sees that an object is of a type that is encoded in
+ -- this manner, it can use the original type to determine the bounds and
+ -- the component type, and the component size to determine the packing
+ -- details.
+
+ -- For an unconstrained packed array, the corresponding packed array type
+ -- is neither used in the generated code nor for debugging information,
+ -- only the original type is used. In order to convey the packing in the
+ -- debugging information, the compiler generates the associated fat- and
+ -- thin-pointer types (see the Pointers to Unconstrained Array section
+ -- below) using the name of the corresponding packed array type as the
+ -- base name, i.e. ttt___XPnnn___XUP and ttt___XPnnn___XUT respectively.
+
+ -- When the debugger sees that an object is of a type that is encoded in
+ -- this manner, it can use the type of the fields to determine the bounds
+ -- and the component type, and the component size to determine the packing
+ -- details.
+
------------------------------------------------------
-- Subprograms for Handling Packed Array Type Names --
------------------------------------------------------
@@ -1219,58 +1228,67 @@ package Exp_Dbug is
-- Pointers to Unconstrained Arrays --
--------------------------------------
- -- There are two kinds of pointers to arrays. The debugger can tell which
- -- format is in use by the form of the type of the pointer.
+ -- There are two kinds of pointer to unconstrained arrays. The debugger can
+ -- tell which format is in use by the form of the type of the pointer.
-- Fat Pointers
- -- Fat pointers are represented as a struct with two fields. This
- -- struct has two distinguished field names:
+ -- Fat pointers are represented as a structure with two fields. This
+ -- structure has two distinguished field names:
-- P_ARRAY is a pointer to the array type. The name of this type is
- -- the unconstrained type followed by "___XUA". This array will have
- -- bounds which are the discriminants, and hence are unparsable, but
- -- will give the number of subscripts and the component type.
+ -- the unconstrained type followed by "___XUA". The bounds of this
+ -- array will be obtained through dereferences of P_BOUNDS below.
- -- P_BOUNDS is a pointer to a struct, the name of whose type is the
- -- unconstrained array name followed by "___XUB" and which has
- -- fields of the form
+ -- P_BOUNDS is a pointer to a structure. The name of this type is
+ -- the unconstrained array name followed by "___XUB" and it has
+ -- fields of the form:
-- LBn (n a decimal integer) lower bound of n'th dimension
-- UBn (n a decimal integer) upper bound of n'th dimension
- -- The bounds may be any integral type. In the case of an enumeration
- -- type, Enum_Rep values are used.
+ -- The bounds may be of any integral type. In the case of enumeration
+ -- types, Enum_Rep values are used.
+
+ -- For a given unconstrained array type, the compiler will generate a
+ -- fat pointer type whose name is the name of the array type, and use
+ -- it to represent the array type itself in the debugging information.
- -- For a given unconstrained array type, the compiler will generate one
- -- fat-pointer type whose name is "arr___XUP", where "arr" is the name
- -- of the array type, and use it to represent the array type itself in
- -- the debugging information.
+ -- This name was historically followed by "___XUP" (OBSOLETE).
-- For each pointer to this unconstrained array type, the compiler will
- -- generate a typedef that points to the above "arr___XUP" fat-pointer
- -- type. As a consequence, when it comes to fat-pointer types:
+ -- generate a typedef that points to the above fat pointer type. As a
+ -- consequence, when it comes to fat pointer types:
- -- 1. The type name is given by the typedef
+ -- 1. The type name is given by the typedef, if any
-- 2. If the debugger is asked to output the type, the appropriate
- -- form is "access arr", except if the type name is "arr___XUP"
- -- for which it is the array definition.
+ -- form is "access arr" if there is the typedef, otherwise it is
+ -- the array definition.
-- Thin Pointers
-- The value of a thin pointer is a pointer to the second field of a
+ -- structure with two fields. The first field of the structure is of
+ -- the type ___XUB described for fat pointer types above. The second
+ -- field of the structure contains the actual array.
+
+ -- Thin pointers are represented as a regular pointer to array in the
+ -- debugging information. The bounds of this array will be the contents
+ -- of the first field above obtained through (shifted) dereferences.
+
+ -- Thin Pointers (OBSOLETE)
+
+ -- The value of a thin pointer is a pointer to the second field of a
-- structure with two fields. The name of this structure's type is
-- "arr___XUT", where "arr" is the name of the unconstrained array
- -- type. Even though it actually points into middle of this structure,
- -- the thin pointer's type in debugging information is
- -- pointer-to-arr___XUT.
+ -- type. Even though it points into the middle of this structure,
+ -- the type in the debugging information is pointer to structure.
- -- The first field of arr___XUT is named BOUNDS, and has a type named
- -- arr___XUB, with the structure described for such types in fat
- -- pointers, as described above.
+ -- The first field of the structure is named BOUNDS and is of the type
+ -- ___XUB described for fat pointer types above.
- -- The second field of arr___XUT is named ARRAY, and contains the
+ -- The second field of the structure is named ARRAY, and contains the
-- actual array. Because this array has a dynamic size, determined by
-- the BOUNDS field that precedes it, all of the information about
-- arr___XUT is encoded in a parallel type named arr___XUT___XVE, with
@@ -1279,19 +1297,6 @@ package Exp_Dbug is
-- type in this case is named arr___XUA and only its element type is
-- meaningful, just as described for fat pointers.
- --------------------------------------
- -- Tagged Types and Type Extensions --
- --------------------------------------
-
- -- A type C derived from a tagged type P has a field named "_parent" of
- -- type P that contains its inherited fields. The type of this field is
- -- usually P (encoded as usual if it has a dynamic size), but may be a more
- -- distant ancestor, if P is a null extension of that type.
-
- -- The type tag of a tagged type is a field named _tag, of type void*. If
- -- the type is derived from another tagged type, its _tag field is found in
- -- its _parent field.
-
-----------------------------
-- Variant Record Encoding --
-----------------------------
@@ -1311,8 +1316,7 @@ package Exp_Dbug is
-- union, in which each member of the union corresponds to one variant.
-- However, unlike a C union, the size of the type may be variable even if
-- each of the components are fixed size, since it includes a computation
- -- of which variant is present. In that case, it will be encoded as above
- -- and a type with the suffix "___XVN___XVU" will be present.
+ -- of which variant is present.
-- The name of the union member is encoded to indicate the choices, and
-- is a string given by the following grammar:
@@ -1335,9 +1339,7 @@ package Exp_Dbug is
-- to the use of the Enum_Rep attribute).
-- The type of the inner record is given by the name of the union type (as
- -- above) concatenated with the above string. Since that type may itself be
- -- variable-sized, it may also be encoded as above with a new type with a
- -- further suffix of "___XVU".
+ -- above) concatenated with the above string.
-- As an example, consider:
@@ -1375,9 +1377,7 @@ package Exp_Dbug is
-- be encoded, as in ordinary C unions, as a single field of the
-- enclosing union type named "x" of type "T", dispensing with the
-- enclosing struct. In this case, of course, the discriminant values
- -- corresponding to the variant are unavailable. As for normal
- -- variants, the field name "x" may be suffixed with ___XVL if it
- -- has dynamic size.
+ -- corresponding to the variant are unavailable.
-- For example, the type Var in the preceding section, if followed by
-- "pragma Unchecked_Union (Var);" may be encoded as a struct with two
@@ -1549,46 +1549,19 @@ package Exp_Dbug is
-- are missing and deal as best as it can with the limited information
-- available.
- ---------------------------------
- -- GNAT Extensions to DWARF2/3 --
- ---------------------------------
-
- -- If the compiler switch "-gdwarf+" is specified, GNAT Vendor extensions
- -- to DWARF2/3 are generated, with the following variations from the above
- -- specification.
-
- -- Change in the contents of the DW_AT_name attribute
-
- -- The operators are represented in their natural form. (for example,
- -- the addition operator is written as "+" instead of "Oadd"). The
- -- component separator is "." instead of "__"
+ -----------------------------------------
+ -- GNAT Extensions to DWARF (OBSOLETE) --
+ -----------------------------------------
- -- Introduction of DW_AT_GNAT_encoding, encoded with value 0x2301
+ -- DW_AT_use_GNAT_descriptive_type, encoded with value 0x2301
- -- Any debugging information entry representing a program entity, named
- -- or implicit, may have a DW_AT_GNAT_encoding attribute. The value of
- -- this attribute is a string representing the suffix internally added
- -- by GNAT for various purposes, mainly for representing debug
- -- information compatible with other formats. In particular this is
- -- useful for IDEs which need to filter out information internal to
- -- GNAT from their graphical interfaces.
+ -- This extension has never been implemented in the compiler.
- -- If a debugging information entry has multiple encodings, all of them
- -- will be listed in DW_AT_GNAT_encoding using the list separator ':'.
-
- -- Introduction of DW_AT_GNAT_descriptive_type, encoded with value 0x2302
+ -- DW_AT_GNAT_descriptive_type, encoded with value 0x2302
-- Any debugging information entry representing a type may have a
-- DW_AT_GNAT_descriptive_type attribute whose value is a reference,
-- pointing to a debugging information entry representing another type
-- associated to the type.
- -- Modification of the contents of the DW_AT_producer string
-
- -- When emitting full GNAT Vendor extensions to DWARF2/3, "-gdwarf+"
- -- is appended to the DW_AT_producer string.
- --
- -- When emitting only DW_AT_GNAT_descriptive_type, "-gdwarf+-" is
- -- appended to the DW_AT_producer string.
-
end Exp_Dbug;
diff --git a/gcc/ada/exp_disp.adb b/gcc/ada/exp_disp.adb
index 14f25db..e9d6e74 100644
--- a/gcc/ada/exp_disp.adb
+++ b/gcc/ada/exp_disp.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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,48 +23,52 @@
-- --
------------------------------------------------------------------------------
-with Atree; use Atree;
-with Checks; use Checks;
-with Debug; use Debug;
-with Einfo; use Einfo;
-with Elists; use Elists;
-with Errout; use Errout;
-with Expander; use Expander;
-with Exp_Atag; use Exp_Atag;
-with Exp_Ch6; use Exp_Ch6;
-with Exp_CG; use Exp_CG;
-with Exp_Dbug; use Exp_Dbug;
-with Exp_Tss; use Exp_Tss;
-with Exp_Util; use Exp_Util;
-with Freeze; use Freeze;
-with Ghost; use Ghost;
-with Itypes; use Itypes;
-with Layout; use Layout;
-with Nlists; use Nlists;
-with Nmake; use Nmake;
-with Namet; use Namet;
-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;
-with Sem_Ch6; use Sem_Ch6;
-with Sem_Ch7; use Sem_Ch7;
-with Sem_Ch8; use Sem_Ch8;
-with Sem_Disp; use Sem_Disp;
-with Sem_Eval; use Sem_Eval;
-with Sem_Res; use Sem_Res;
-with Sem_Type; use Sem_Type;
-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;
-with SCIL_LL; use SCIL_LL;
-with Tbuild; use Tbuild;
+with Atree; use Atree;
+with Checks; use Checks;
+with Debug; use Debug;
+with Einfo; use Einfo;
+with Einfo.Entities; use Einfo.Entities;
+with Einfo.Utils; use Einfo.Utils;
+with Elists; use Elists;
+with Errout; use Errout;
+with Expander; use Expander;
+with Exp_Atag; use Exp_Atag;
+with Exp_Ch6; use Exp_Ch6;
+with Exp_CG; use Exp_CG;
+with Exp_Dbug; use Exp_Dbug;
+with Exp_Tss; use Exp_Tss;
+with Exp_Util; use Exp_Util;
+with Freeze; use Freeze;
+with Ghost; use Ghost;
+with Itypes; use Itypes;
+with Layout; use Layout;
+with Nlists; use Nlists;
+with Nmake; use Nmake;
+with Namet; use Namet;
+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;
+with Sem_Ch6; use Sem_Ch6;
+with Sem_Ch7; use Sem_Ch7;
+with Sem_Ch8; use Sem_Ch8;
+with Sem_Disp; use Sem_Disp;
+with Sem_Eval; use Sem_Eval;
+with Sem_Res; use Sem_Res;
+with Sem_Type; use Sem_Type;
+with Sem_Util; use Sem_Util;
+with Sinfo; use Sinfo;
+with Sinfo.Nodes; use Sinfo.Nodes;
+with Sinfo.Utils; use Sinfo.Utils;
+with Sinput; use Sinput;
+with Snames; use Snames;
+with Stand; use Stand;
+with Stringt; use Stringt;
+with SCIL_LL; use SCIL_LL;
+with Tbuild; use Tbuild;
package body Exp_Disp is
@@ -161,9 +165,8 @@ package body Exp_Disp is
-- This capability of dispatching directly by tag is also needed by the
-- implementation of AI-260 (for the generic dispatching constructors).
- if Ctrl_Typ = RTE (RE_Tag)
- or else (RTE_Available (RE_Interface_Tag)
- and then Ctrl_Typ = RTE (RE_Interface_Tag))
+ if Is_RTE (Ctrl_Typ, RE_Tag)
+ or else Is_RTE (Ctrl_Typ, RE_Interface_Tag)
then
CW_Typ := Class_Wide_Type (Find_Dispatching_Type (Subp));
@@ -527,8 +530,7 @@ package body Exp_Disp is
and then Is_Tag (Entity (Selector_Name (Expr))))
or else
(Nkind (Expr) = N_Function_Call
- and then RTE_Available (RE_Displace)
- and then Entity (Name (Expr)) = RTE (RE_Displace))));
+ and then Is_RTE (Entity (Name (Expr)), RE_Displace))));
Anon_Type := Create_Itype (E_Anonymous_Access_Type, Expr);
Set_Directly_Designated_Type (Anon_Type, Typ);
@@ -586,19 +588,7 @@ package body Exp_Disp is
-- Otherwise, count the primitives of the enclosing CPP type
else
- declare
- Count : Nat := 0;
- Elmt : Elmt_Id;
-
- begin
- Elmt := First_Elmt (Primitive_Operations (CPP_Typ));
- while Present (Elmt) loop
- Count := Count + 1;
- Next_Elmt (Elmt);
- end loop;
-
- return Count;
- end;
+ return List_Length (Primitive_Operations (CPP_Typ));
end if;
end if;
end CPP_Num_Prims;
@@ -711,10 +701,13 @@ package body Exp_Disp is
Eq_Prim_Op : Entity_Id := Empty;
Controlling_Tag : Node_Id;
- procedure Build_Class_Wide_Check;
+ procedure Build_Class_Wide_Check (E : Entity_Id);
-- If the denoted subprogram has a class-wide precondition, generate a
-- check using that precondition before the dispatching call, because
- -- this is the only class-wide precondition that applies to the call.
+ -- this is the only class-wide precondition that applies to the call;
+ -- otherwise climb to the ancestors searching for the enclosing
+ -- overridden primitive of E that has a class-wide precondition (and
+ -- use it to generate the check).
function New_Value (From : Node_Id) return Node_Id;
-- From is the original Expression. New_Value is equivalent to a call
@@ -725,7 +718,14 @@ package body Exp_Disp is
-- Build_Class_Wide_Check --
----------------------------
- procedure Build_Class_Wide_Check is
+ procedure Build_Class_Wide_Check (E : Entity_Id) is
+ Subp : Entity_Id := E;
+
+ function Has_Class_Wide_Precondition
+ (Subp : Entity_Id) return Boolean;
+ -- Evaluates if the dispatching subprogram Subp has a class-wide
+ -- precondition.
+
function Replace_Formals (N : Node_Id) return Traverse_Result;
-- Replace occurrences of the formals of the subprogram by the
-- corresponding actuals in the call, given that this check is
@@ -737,6 +737,32 @@ package body Exp_Disp is
-- has not been analyzed yet, in which case we use the Chars
-- field to recognize intended occurrences of the formals.
+ ---------------------------------
+ -- Has_Class_Wide_Precondition --
+ ---------------------------------
+
+ function Has_Class_Wide_Precondition
+ (Subp : Entity_Id) return Boolean
+ is
+ Prec : Node_Id := Empty;
+
+ begin
+ if Present (Contract (Subp))
+ and then Present (Pre_Post_Conditions (Contract (Subp)))
+ then
+ Prec := Pre_Post_Conditions (Contract (Subp));
+
+ while Present (Prec) loop
+ exit when Pragma_Name (Prec) = Name_Precondition
+ and then Class_Present (Prec);
+ Prec := Next_Pragma (Prec);
+ end loop;
+ end if;
+
+ return Present (Prec)
+ and then not Is_Ignored (Prec);
+ end Has_Class_Wide_Precondition;
+
---------------------
-- Replace_Formals --
---------------------
@@ -752,27 +778,46 @@ package body Exp_Disp is
if Present (Entity (N)) and then Is_Formal (Entity (N)) then
while Present (F) loop
if F = Entity (N) then
- Rewrite (N, New_Copy_Tree (A));
-
- -- If the formal is class-wide, and thus not a
- -- controlling argument, preserve its type because
- -- it may appear in a nested call with a class-wide
- -- parameter.
+ if not Is_Controlling_Actual (N) then
+ Rewrite (N, New_Copy_Tree (A));
+
+ -- If the formal is class-wide, and thus not a
+ -- controlling argument, preserve its type because
+ -- it may appear in a nested call with a class-wide
+ -- parameter.
+
+ if Is_Class_Wide_Type (Etype (F)) then
+ Set_Etype (N, Etype (F));
+
+ -- Conversely, if this is a controlling argument
+ -- (in a dispatching call in the condition) that
+ -- is a dereference, the source is an access-to-
+ -- -class-wide type, so preserve the dispatching
+ -- nature of the call in the rewritten condition.
+
+ elsif Nkind (Parent (N)) = N_Explicit_Dereference
+ and then Is_Controlling_Actual (Parent (N))
+ then
+ Set_Controlling_Argument (Parent (Parent (N)),
+ Parent (N));
+ end if;
- if Is_Class_Wide_Type (Etype (F)) then
- Set_Etype (N, Etype (F));
+ -- Ensure that the type of the controlling actual
+ -- matches the type of the controlling formal of the
+ -- parent primitive Subp defining the class-wide
+ -- precondition.
- -- Conversely, if this is a controlling argument
- -- (in a dispatching call in the condition) that is a
- -- dereference, the source is an access-to-class-wide
- -- type, so preserve the dispatching nature of the
- -- call in the rewritten condition.
+ elsif Is_Class_Wide_Type (Etype (A)) then
+ Rewrite (N,
+ Convert_To
+ (Class_Wide_Type (Etype (F)),
+ New_Copy_Tree (A)));
- elsif Nkind (Parent (N)) = N_Explicit_Dereference
- and then Is_Controlling_Actual (Parent (N))
- then
- Set_Controlling_Argument (Parent (Parent (N)),
- Parent (N));
+ else
+ Rewrite (N,
+ Convert_To
+ (Etype (F),
+ New_Copy_Tree (A)));
end if;
exit;
@@ -811,6 +856,7 @@ package body Exp_Disp is
Str_Loc : constant String := Build_Location_String (Loc);
+ A : Node_Id;
Cond : Node_Id;
Msg : Node_Id;
Prec : Node_Id;
@@ -818,6 +864,13 @@ package body Exp_Disp is
-- Start of processing for Build_Class_Wide_Check
begin
+ -- Climb searching for the enclosing class-wide precondition
+
+ while not Has_Class_Wide_Precondition (Subp)
+ and then Present (Overridden_Operation (Subp))
+ loop
+ Subp := Overridden_Operation (Subp);
+ end loop;
-- Locate class-wide precondition, if any
@@ -836,6 +889,15 @@ package body Exp_Disp is
return;
end if;
+ -- Ensure that the evaluation of the actuals will not produce side
+ -- effects (since the check will use a copy of the actuals).
+
+ A := First_Actual (Call_Node);
+ while Present (A) loop
+ Remove_Side_Effects (A);
+ Next_Actual (A);
+ end loop;
+
-- The expression for the precondition is analyzed within the
-- generated pragma. The message text is the last parameter of
-- the generated pragma, indicating source of precondition.
@@ -926,7 +988,7 @@ package body Exp_Disp is
Subp := Alias (Subp);
end if;
- Build_Class_Wide_Check;
+ Build_Class_Wide_Check (Subp);
-- Definition of the class-wide type and the tagged type
@@ -939,9 +1001,8 @@ package body Exp_Disp is
-- This capability of dispatching directly by tag is also needed by the
-- implementation of AI-260 (for the generic dispatching constructors).
- if Ctrl_Typ = RTE (RE_Tag)
- or else (RTE_Available (RE_Interface_Tag)
- and then Ctrl_Typ = RTE (RE_Interface_Tag))
+ if Is_RTE (Ctrl_Typ, RE_Tag)
+ or else Is_RTE (Ctrl_Typ, RE_Interface_Tag)
then
CW_Typ := Class_Wide_Type (Find_Dispatching_Type (Subp));
@@ -1124,9 +1185,8 @@ package body Exp_Disp is
-- interface class-wide type then use it directly. Otherwise, the tag
-- must be extracted from the controlling object.
- if Ctrl_Typ = RTE (RE_Tag)
- or else (RTE_Available (RE_Interface_Tag)
- and then Ctrl_Typ = RTE (RE_Interface_Tag))
+ if Is_RTE (Ctrl_Typ, RE_Tag)
+ or else Is_RTE (Ctrl_Typ, RE_Interface_Tag)
then
Controlling_Tag := Duplicate_Subexpr (Ctrl_Arg);
@@ -1138,11 +1198,9 @@ package body Exp_Disp is
elsif Nkind (Ctrl_Arg) = N_Unchecked_Type_Conversion
and then
- (Etype (Expression (Ctrl_Arg)) = RTE (RE_Tag)
+ (Is_RTE (Etype (Expression (Ctrl_Arg)), RE_Tag)
or else
- (RTE_Available (RE_Interface_Tag)
- and then
- Etype (Expression (Ctrl_Arg)) = RTE (RE_Interface_Tag)))
+ Is_RTE (Etype (Expression (Ctrl_Arg)), RE_Interface_Tag))
then
Controlling_Tag := Duplicate_Subexpr (Expression (Ctrl_Arg));
@@ -2187,7 +2245,7 @@ package body Exp_Disp is
-- with GNATcoverage, as that tool relies on it to identify
-- thunks and exclude them from source coverage analysis.
- Set_Ekind (Thunk_Id, Ekind (Prim));
+ Mutate_Ekind (Thunk_Id, Ekind (Prim));
Set_Is_Thunk (Thunk_Id);
Set_Convention (Thunk_Id, Convention (Prim));
Set_Needs_Debug_Info (Thunk_Id, Needs_Debug_Info (Target));
@@ -2505,11 +2563,9 @@ package body Exp_Disp is
New_List (
Obj_Ref,
- Make_Unchecked_Type_Conversion (Loc, -- entry index
- Subtype_Mark =>
- New_Occurrence_Of
- (RTE (RE_Protected_Entry_Index), Loc),
- Expression => Make_Identifier (Loc, Name_uI)),
+ Unchecked_Convert_To ( -- entry index
+ RTE (RE_Protected_Entry_Index),
+ Make_Identifier (Loc, Name_uI)),
Make_Identifier (Loc, Name_uP), -- parameter block
New_Occurrence_Of -- Asynchronous_Call
@@ -2528,11 +2584,9 @@ package body Exp_Disp is
Make_Assignment_Statement (Loc,
Name => Make_Identifier (Loc, Name_uB),
Expression =>
- Make_Unchecked_Type_Conversion (Loc,
- Subtype_Mark =>
- New_Occurrence_Of
- (RTE (RE_Dummy_Communication_Block), Loc),
- Expression => New_Occurrence_Of (Com_Block, Loc))));
+ Unchecked_Convert_To
+ (RTE (RE_Dummy_Communication_Block),
+ New_Occurrence_Of (Com_Block, Loc))));
-- Generate:
-- F := False;
@@ -2566,10 +2620,9 @@ package body Exp_Disp is
Prefix => Make_Identifier (Loc, Name_uT),
Selector_Name => Make_Identifier (Loc, Name_uTask_Id)),
- Make_Unchecked_Type_Conversion (Loc, -- entry index
- Subtype_Mark =>
- New_Occurrence_Of (RTE (RE_Task_Entry_Index), Loc),
- Expression => Make_Identifier (Loc, Name_uI)),
+ Unchecked_Convert_To ( -- entry index
+ RTE (RE_Task_Entry_Index),
+ Make_Identifier (Loc, Name_uI)),
Make_Identifier (Loc, Name_uP), -- parameter block
New_Occurrence_Of -- Asynchronous_Call
@@ -2859,11 +2912,9 @@ package body Exp_Disp is
Parameter_Associations => New_List (
Obj_Ref,
- Make_Unchecked_Type_Conversion (Loc, -- entry index
- Subtype_Mark =>
- New_Occurrence_Of
- (RTE (RE_Protected_Entry_Index), Loc),
- Expression => Make_Identifier (Loc, Name_uI)),
+ Unchecked_Convert_To ( -- entry index
+ RTE (RE_Protected_Entry_Index),
+ Make_Identifier (Loc, Name_uI)),
Make_Identifier (Loc, Name_uP), -- parameter block
@@ -2936,10 +2987,9 @@ package body Exp_Disp is
Prefix => Make_Identifier (Loc, Name_uT),
Selector_Name => Make_Identifier (Loc, Name_uTask_Id)),
- Make_Unchecked_Type_Conversion (Loc, -- entry index
- Subtype_Mark =>
- New_Occurrence_Of (RTE (RE_Task_Entry_Index), Loc),
- Expression => Make_Identifier (Loc, Name_uI)),
+ Unchecked_Convert_To ( -- entry index
+ RTE (RE_Task_Entry_Index),
+ Make_Identifier (Loc, Name_uI)),
Make_Identifier (Loc, Name_uP), -- parameter block
New_Occurrence_Of -- Conditional_Call
@@ -3149,12 +3199,11 @@ package body Exp_Disp is
Ret :=
Make_Simple_Return_Statement (Loc,
Expression =>
- Make_Unchecked_Type_Conversion (Loc,
- Subtype_Mark => New_Occurrence_Of (RTE (RE_Address), Loc),
- Expression =>
- Make_Selected_Component (Loc,
- Prefix => Make_Identifier (Loc, Name_uT),
- Selector_Name => Make_Identifier (Loc, Name_uTask_Id))));
+ Unchecked_Convert_To
+ (RTE (RE_Address),
+ Make_Selected_Component (Loc,
+ Prefix => Make_Identifier (Loc, Name_uT),
+ Selector_Name => Make_Identifier (Loc, Name_uTask_Id))));
-- A null body is constructed for non-task types
@@ -3267,12 +3316,9 @@ package body Exp_Disp is
Parameter_Associations =>
New_List (
- Make_Unchecked_Type_Conversion (Loc, -- PEA (P)
- Subtype_Mark =>
- New_Occurrence_Of (
- RTE (RE_Protection_Entries_Access), Loc),
- Expression =>
- Make_Identifier (Loc, Name_uP)),
+ Unchecked_Convert_To ( -- PEA (P)
+ RTE (RE_Protection_Entries_Access),
+ Make_Identifier (Loc, Name_uP)),
Make_Attribute_Reference (Loc, -- O._object'Acc
Attribute_Name =>
@@ -3284,11 +3330,9 @@ package body Exp_Disp is
Selector_Name =>
Make_Identifier (Loc, Name_uObject))),
- Make_Unchecked_Type_Conversion (Loc, -- entry index
- Subtype_Mark =>
- New_Occurrence_Of
- (RTE (RE_Protected_Entry_Index), Loc),
- Expression => Make_Identifier (Loc, Name_uI)),
+ Unchecked_Convert_To ( -- entry index
+ RTE (RE_Protected_Entry_Index),
+ Make_Identifier (Loc, Name_uI)),
Make_Identifier (Loc, Name_uA)))), -- abort status
@@ -3313,11 +3357,9 @@ package body Exp_Disp is
Selector_Name =>
Make_Identifier (Loc, Name_uObject))),
- Make_Unchecked_Type_Conversion (Loc, -- entry index
- Subtype_Mark =>
- New_Occurrence_Of
- (RTE (RE_Protected_Entry_Index), Loc),
- Expression => Make_Identifier (Loc, Name_uI)),
+ Unchecked_Convert_To ( -- entry index
+ RTE (RE_Protected_Entry_Index),
+ Make_Identifier (Loc, Name_uI)),
Make_Identifier (Loc, Name_uA)))))); -- abort status
end if;
@@ -3354,20 +3396,17 @@ package body Exp_Disp is
Parameter_Associations => New_List (
- Make_Unchecked_Type_Conversion (Loc, -- PEA (P)
- Subtype_Mark =>
- New_Occurrence_Of
- (RTE (RE_Protection_Entries_Access), Loc),
- Expression => Make_Identifier (Loc, Name_uP)),
+ Unchecked_Convert_To ( -- PEA (P)
+ RTE (RE_Protection_Entries_Access),
+ Make_Identifier (Loc, Name_uP)),
Make_Selected_Component (Loc, -- O._task_id
Prefix => Make_Identifier (Loc, Name_uO),
Selector_Name => Make_Identifier (Loc, Name_uTask_Id)),
- Make_Unchecked_Type_Conversion (Loc, -- entry index
- Subtype_Mark =>
- New_Occurrence_Of (RTE (RE_Task_Entry_Index), Loc),
- Expression => Make_Identifier (Loc, Name_uI)),
+ Unchecked_Convert_To ( -- entry index
+ RTE (RE_Task_Entry_Index),
+ Make_Identifier (Loc, Name_uI)),
Make_Identifier (Loc, Name_uA)))), -- abort status
@@ -3385,10 +3424,9 @@ package body Exp_Disp is
Prefix => Make_Identifier (Loc, Name_uO),
Selector_Name => Make_Identifier (Loc, Name_uTask_Id)),
- Make_Unchecked_Type_Conversion (Loc, -- entry index
- Subtype_Mark =>
- New_Occurrence_Of (RTE (RE_Task_Entry_Index), Loc),
- Expression => Make_Identifier (Loc, Name_uI)),
+ Unchecked_Convert_To ( -- entry index
+ RTE (RE_Task_Entry_Index),
+ Make_Identifier (Loc, Name_uI)),
Make_Identifier (Loc, Name_uA)))))); -- abort status
end if;
@@ -3673,11 +3711,9 @@ package body Exp_Disp is
Parameter_Associations => New_List (
Obj_Ref,
- Make_Unchecked_Type_Conversion (Loc, -- entry index
- Subtype_Mark =>
- New_Occurrence_Of
- (RTE (RE_Protected_Entry_Index), Loc),
- Expression => Make_Identifier (Loc, Name_uI)),
+ Unchecked_Convert_To ( -- entry index
+ RTE (RE_Protected_Entry_Index),
+ Make_Identifier (Loc, Name_uI)),
Make_Identifier (Loc, Name_uP), -- parameter block
Make_Identifier (Loc, Name_uD), -- delay
@@ -3716,10 +3752,9 @@ package body Exp_Disp is
Prefix => Make_Identifier (Loc, Name_uT),
Selector_Name => Make_Identifier (Loc, Name_uTask_Id)),
- Make_Unchecked_Type_Conversion (Loc, -- entry index
- Subtype_Mark =>
- New_Occurrence_Of (RTE (RE_Task_Entry_Index), Loc),
- Expression => Make_Identifier (Loc, Name_uI)),
+ Unchecked_Convert_To ( -- entry index
+ RTE (RE_Task_Entry_Index),
+ Make_Identifier (Loc, Name_uI)),
Make_Identifier (Loc, Name_uP), -- parameter block
Make_Identifier (Loc, Name_uD), -- delay
@@ -3982,6 +4017,7 @@ package body Exp_Disp is
if Present (N)
and then Is_Private_Type (Typ)
and then No (Full_View (Typ))
+ and then not Has_Private_Declaration (Typ)
and then not Is_Generic_Type (Typ)
and then not Is_Tagged_Type (Typ)
and then not Is_Frozen (Typ)
@@ -4000,6 +4036,7 @@ package body Exp_Disp is
if not Is_Tagged_Type (Typ)
and then Present (Comp)
and then not Is_Frozen (Comp)
+ and then not Has_Private_Declaration (Comp)
and then not Is_Actual_For_Formal_Incomplete_Type (Comp)
then
Error_Msg_Sloc := Sloc (Subp);
@@ -4011,7 +4048,7 @@ package body Exp_Disp is
Error_Msg_NE
("\which is a component of untagged type& in the profile "
& "of primitive & of type % that is frozen by the "
- & "declaration ", N, Typ);
+ & "declaration", N, Typ);
end if;
end if;
end Check_Premature_Freezing;
@@ -4037,7 +4074,10 @@ package body Exp_Disp is
Count := Count + 1;
end loop;
- pragma Assert (Related_Type (Node (Elmt)) = Typ);
+ -- Related_Type (Node (Elmt)) should be equal to Typ here, but we
+ -- can't assert that, because it is sometimes false in illegal
+ -- programs. We can't check Serious_Errors_Detected, because the
+ -- errors have not yet been detected.
Get_External_Name (Node (Elmt));
Set_Interface_Name (DT,
@@ -4087,18 +4127,18 @@ package body Exp_Disp is
-- dispatch tables.
if not Building_Static_DT (Typ) then
- Set_Ekind (Predef_Prims, E_Variable);
- Set_Ekind (Iface_DT, E_Variable);
+ Mutate_Ekind (Predef_Prims, E_Variable);
+ Mutate_Ekind (Iface_DT, E_Variable);
-- Statically allocated dispatch tables and related entities are
-- constants.
else
- Set_Ekind (Predef_Prims, E_Constant);
+ Mutate_Ekind (Predef_Prims, E_Constant);
Set_Is_Statically_Allocated (Predef_Prims);
Set_Is_True_Constant (Predef_Prims);
- Set_Ekind (Iface_DT, E_Constant);
+ Mutate_Ekind (Iface_DT, E_Constant);
Set_Is_Statically_Allocated (Iface_DT);
Set_Is_True_Constant (Iface_DT);
end if;
@@ -4638,8 +4678,8 @@ package body Exp_Disp is
Discard_Names : constant Boolean :=
Present (No_Tagged_Streams_Pragma (Typ))
- and then (Global_Discard_Names
- or else Einfo.Discard_Names (Typ));
+ and then
+ (Global_Discard_Names or else Einfo.Entities.Discard_Names (Typ));
-- The following name entries are used by Make_DT to generate a number
-- of entities related to a tagged type. These entities may be generated
@@ -4835,7 +4875,7 @@ package body Exp_Disp is
-- objects by making them volatile.
Set_Is_Imported (Dummy_Object);
- Set_Ekind (Dummy_Object, E_Constant);
+ Mutate_Ekind (Dummy_Object, E_Constant);
Set_Is_True_Constant (Dummy_Object);
Set_Related_Type (Dummy_Object, Typ);
@@ -6646,28 +6686,25 @@ package body Exp_Disp is
----------------------
function Find_Entry_Index (E : Entity_Id) return Uint is
- Index : Uint := Uint_1;
- Subp_Decl : Entity_Id;
+ Index : Uint := Uint_0;
+ Subp_Decl : Node_Id;
begin
- if Present (Decls)
- and then not Is_Empty_List (Decls)
- then
- Subp_Decl := First (Decls);
- while Present (Subp_Decl) loop
- if Nkind (Subp_Decl) = N_Entry_Declaration then
- if Defining_Identifier (Subp_Decl) = E then
- return Index;
- end if;
+ Subp_Decl := First (Decls);
+ while Present (Subp_Decl) loop
+ if Nkind (Subp_Decl) = N_Entry_Declaration then
+ Index := Index + 1;
- Index := Index + 1;
+ if Defining_Identifier (Subp_Decl) = E then
+ exit;
end if;
- Next (Subp_Decl);
- end loop;
- end if;
+ end if;
+
+ Next (Subp_Decl);
+ end loop;
- return Uint_0;
+ return Index;
end Find_Entry_Index;
-- Local variables
@@ -6838,7 +6875,7 @@ package body Exp_Disp is
begin
Set_Is_Imported (DT);
- Set_Ekind (DT, E_Constant);
+ Mutate_Ekind (DT, E_Constant);
Set_Related_Type (DT, Typ);
-- The scope must be set now to call Get_External_Name
@@ -6949,7 +6986,7 @@ package body Exp_Disp is
-- Minimum decoration
- Set_Ekind (DT_Ptr, E_Variable);
+ Mutate_Ekind (DT_Ptr, E_Variable);
Set_Related_Type (DT_Ptr, Typ);
-- Notify back end that the types are associated with a dispatch table
@@ -7103,7 +7140,7 @@ package body Exp_Disp is
Make_Defining_Identifier (Loc,
Chars => New_External_Name (Typ_Name, 'P'));
Set_Etype (Iface_DT_Ptr, RTE (RE_Interface_Tag));
- Set_Ekind (Iface_DT_Ptr, E_Variable);
+ Mutate_Ekind (Iface_DT_Ptr, E_Variable);
Set_Is_Tag (Iface_DT_Ptr);
Set_Has_Thunks (Iface_DT_Ptr);
@@ -7152,7 +7189,7 @@ package body Exp_Disp is
Make_Defining_Identifier (Loc,
Chars => New_External_Name (Typ_Name, 'P'));
Set_Etype (Iface_DT_Ptr, RTE (RE_Interface_Tag));
- Set_Ekind (Iface_DT_Ptr, E_Constant);
+ Mutate_Ekind (Iface_DT_Ptr, E_Constant);
Set_Is_Tag (Iface_DT_Ptr);
Set_Has_Thunks (Iface_DT_Ptr);
Set_Is_Statically_Allocated (Iface_DT_Ptr,
@@ -7190,7 +7227,7 @@ package body Exp_Disp is
Make_Defining_Identifier (Loc,
Chars => New_External_Name (Typ_Name, 'Y'));
Set_Etype (Iface_DT_Ptr, RTE (RE_Address));
- Set_Ekind (Iface_DT_Ptr, E_Constant);
+ Mutate_Ekind (Iface_DT_Ptr, E_Constant);
Set_Is_Tag (Iface_DT_Ptr);
Set_Has_Thunks (Iface_DT_Ptr);
Set_Is_Statically_Allocated (Iface_DT_Ptr,
@@ -7207,7 +7244,7 @@ package body Exp_Disp is
Make_Defining_Identifier (Loc,
Chars => New_External_Name (Typ_Name, 'D'));
Set_Etype (Iface_DT_Ptr, RTE (RE_Interface_Tag));
- Set_Ekind (Iface_DT_Ptr, E_Constant);
+ Mutate_Ekind (Iface_DT_Ptr, E_Constant);
Set_Is_Tag (Iface_DT_Ptr);
Set_Is_Statically_Allocated (Iface_DT_Ptr,
Is_Library_Level_Tagged_Type (Typ));
@@ -7222,7 +7259,7 @@ package body Exp_Disp is
Make_Defining_Identifier (Loc,
Chars => New_External_Name (Typ_Name, 'Z'));
Set_Etype (Iface_DT_Ptr, RTE (RE_Address));
- Set_Ekind (Iface_DT_Ptr, E_Constant);
+ Mutate_Ekind (Iface_DT_Ptr, E_Constant);
Set_Is_Tag (Iface_DT_Ptr);
Set_Is_Statically_Allocated (Iface_DT_Ptr,
Is_Library_Level_Tagged_Type (Typ));
@@ -7332,9 +7369,9 @@ package body Exp_Disp is
end if;
if Is_CPP_Class (Root_Type (Typ)) then
- Set_Ekind (DT_Ptr, E_Variable);
+ Mutate_Ekind (DT_Ptr, E_Variable);
else
- Set_Ekind (DT_Ptr, E_Constant);
+ Mutate_Ekind (DT_Ptr, E_Constant);
end if;
Set_Is_Tag (DT_Ptr);
@@ -8692,7 +8729,7 @@ package body Exp_Disp is
-- with an abstract interface type
if Present (DTC_Entity (Prim)) then
- if Etype (DTC_Entity (Prim)) = RTE (RE_Tag) then
+ if Is_RTE (Etype (DTC_Entity (Prim)), RE_Tag) then
Write_Str ("[P] ");
else
Write_Str ("[s] ");
diff --git a/gcc/ada/exp_disp.ads b/gcc/ada/exp_disp.ads
index fb1de72..9d9811b 100644
--- a/gcc/ada/exp_disp.ads
+++ b/gcc/ada/exp_disp.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute 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.adb b/gcc/ada/exp_dist.adb
index 2d3f75d..5cb8fb5 100644
--- a/gcc/ada/exp_dist.adb
+++ b/gcc/ada/exp_dist.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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,35 +23,39 @@
-- --
------------------------------------------------------------------------------
-with Atree; use Atree;
-with Einfo; use Einfo;
-with Elists; use Elists;
-with Exp_Atag; use Exp_Atag;
-with Exp_Strm; use Exp_Strm;
-with Exp_Tss; use Exp_Tss;
-with Exp_Util; use Exp_Util;
-with Lib; use Lib;
-with Nlists; use Nlists;
-with Nmake; use Nmake;
-with Opt; use Opt;
-with Rtsfind; use Rtsfind;
-with Sem; use Sem;
-with Sem_Aux; use Sem_Aux;
-with Sem_Cat; use Sem_Cat;
-with Sem_Ch3; use Sem_Ch3;
-with Sem_Ch8; use Sem_Ch8;
-with Sem_Ch12; use Sem_Ch12;
-with Sem_Dist; use Sem_Dist;
-with Sem_Eval; use Sem_Eval;
-with Sem_Util; use Sem_Util;
-with Sinfo; use Sinfo;
-with Stand; use Stand;
-with Stringt; use Stringt;
-with Tbuild; use Tbuild;
-with Ttypes; use Ttypes;
-with Uintp; use Uintp;
-
-with GNAT.HTable; use GNAT.HTable;
+with Atree; use Atree;
+with Einfo; use Einfo;
+with Einfo.Entities; use Einfo.Entities;
+with Einfo.Utils; use Einfo.Utils;
+with Elists; use Elists;
+with Exp_Atag; use Exp_Atag;
+with Exp_Strm; use Exp_Strm;
+with Exp_Tss; use Exp_Tss;
+with Exp_Util; use Exp_Util;
+with Lib; use Lib;
+with Nlists; use Nlists;
+with Nmake; use Nmake;
+with Opt; use Opt;
+with Rtsfind; use Rtsfind;
+with Sem; use Sem;
+with Sem_Aux; use Sem_Aux;
+with Sem_Cat; use Sem_Cat;
+with Sem_Ch3; use Sem_Ch3;
+with Sem_Ch8; use Sem_Ch8;
+with Sem_Ch12; use Sem_Ch12;
+with Sem_Dist; use Sem_Dist;
+with Sem_Eval; use Sem_Eval;
+with Sem_Util; use Sem_Util;
+with Sinfo; use Sinfo;
+with Sinfo.Nodes; use Sinfo.Nodes;
+with Sinfo.Utils; use Sinfo.Utils;
+with Stand; use Stand;
+with Stringt; use Stringt;
+with Tbuild; use Tbuild;
+with Ttypes; use Ttypes;
+with Uintp; use Uintp;
+
+with GNAT.HTable; use GNAT.HTable;
package body Exp_Dist is
@@ -1420,6 +1424,7 @@ package body Exp_Dist is
and then Chars (Current_Primitive) /= Name_uAlignment
and then not
(Is_TSS (Current_Primitive, TSS_Deep_Finalize) or else
+ Is_TSS (Current_Primitive, TSS_Put_Image) or else
Is_TSS (Current_Primitive, TSS_Stream_Input) or else
Is_TSS (Current_Primitive, TSS_Stream_Output) or else
Is_TSS (Current_Primitive, TSS_Stream_Read) or else
@@ -1728,7 +1733,7 @@ package body Exp_Dist is
New_Occurrence_Of (
Entity (Result_Definition (Spec)), Loc));
- Set_Ekind (Proc, E_Function);
+ Mutate_Ekind (Proc, E_Function);
Set_Etype (Proc,
New_Occurrence_Of (Entity (Result_Definition (Spec)), Loc));
@@ -1738,7 +1743,7 @@ package body Exp_Dist is
Defining_Unit_Name => Proc,
Parameter_Specifications => Param_Specs);
- Set_Ekind (Proc, E_Procedure);
+ Mutate_Ekind (Proc, E_Procedure);
Set_Etype (Proc, Standard_Void_Type);
end if;
@@ -1975,7 +1980,7 @@ package body Exp_Dist is
Existing := False;
Stub_Type := Make_Temporary (Loc, 'S');
- Set_Ekind (Stub_Type, E_Record_Type);
+ Mutate_Ekind (Stub_Type, E_Record_Type);
Set_Is_RACW_Stub_Type (Stub_Type);
Stub_Type_Access :=
Make_Defining_Identifier (Loc,
@@ -2165,7 +2170,7 @@ package body Exp_Dist is
Object_Definition =>
New_Occurrence_Of
(Defining_Identifier (Last (Decls)), Loc)));
- Set_Ekind (Object, E_Variable);
+ Mutate_Ekind (Object, E_Variable);
-- Suppress default initialization:
-- pragma Import (Ada, Object);
@@ -2209,9 +2214,9 @@ package body Exp_Dist is
Expression => Expr));
if Constant_Present (Last (Decls)) then
- Set_Ekind (Object, E_Constant);
+ Mutate_Ekind (Object, E_Constant);
else
- Set_Ekind (Object, E_Variable);
+ Mutate_Ekind (Object, E_Variable);
end if;
end if;
end Build_Actual_Object_Declaration;
@@ -2855,9 +2860,9 @@ package body Exp_Dist is
if E_Calling_Stubs = Empty then
RCI_Locator := RCI_Locator_Table.Get (RCI_Package);
- -- The RCI_Locator package and calling stub are is inserted at the
- -- top level in the current unit, and must appear in the proper scope
- -- so that it is not prematurely removed by the GCC back end.
+ -- The RCI_Locator package and calling stub are inserted at the top
+ -- level in the current unit, and must appear in the proper scope so
+ -- that it is not prematurely removed by the GCC back end.
declare
Scop : constant Entity_Id := Cunit_Entity (Current_Sem_Unit);
@@ -3723,7 +3728,7 @@ package body Exp_Dist is
-- Set the kind and return type of the function to prevent
-- ambiguities between Ras_Type and Fat_Type in subsequent analysis.
- Set_Ekind (Proc, E_Function);
+ Mutate_Ekind (Proc, E_Function);
Set_Etype (Proc, Fat_Type);
Discard_Node (
@@ -6468,7 +6473,7 @@ package body Exp_Dist is
-- Set the kind and return type of the function to prevent
-- ambiguities between Ras_Type and Fat_Type in subsequent analysis.
- Set_Ekind (Proc, E_Function);
+ Mutate_Ekind (Proc, E_Function);
Set_Etype (Proc, Fat_Type);
Discard_Node (
@@ -8261,7 +8266,7 @@ package body Exp_Dist is
with procedure Add_Process_Element
(Stmts : List_Id;
Container : Node_Or_Entity_Id;
- Counter : in out Int;
+ Counter : in out Nat;
Rec : Entity_Id;
Field : Node_Id);
-- Rec is the instance of the record type, or Empty.
@@ -8272,7 +8277,7 @@ package body Exp_Dist is
(Stmts : List_Id;
Clist : Node_Id;
Container : Node_Or_Entity_Id;
- Counter : in out Int);
+ Counter : in out Nat);
-- Process component list Clist. Individual fields are passed
-- to Field_Processing. Each variant part is also processed.
-- Container is the outer Any (for From_Any/To_Any),
@@ -8286,7 +8291,7 @@ package body Exp_Dist is
(Stmts : List_Id;
Clist : Node_Id;
Container : Node_Or_Entity_Id;
- Counter : in out Int)
+ Counter : in out Nat)
is
CI : List_Id;
VP : Node_Id;
@@ -8444,9 +8449,9 @@ package body Exp_Dist is
is
Loc : constant Source_Ptr := Sloc (N);
- U_Type : Entity_Id := Underlying_Type (Typ);
+ U_Type : Entity_Id := Underlying_Type (Typ);
- Fnam : Entity_Id := Empty;
+ Fnam : Entity_Id;
Lib_RE : RE_Id := RE_Null;
Result : Node_Id;
@@ -8516,7 +8521,7 @@ package body Exp_Dist is
-- Integer types
elsif U_Type = RTE (RE_Integer_8) then
- Lib_RE := RE_FA_I8;
+ Lib_RE := RE_FA_I8;
elsif U_Type = RTE (RE_Integer_16) then
Lib_RE := RE_FA_I16;
@@ -8674,7 +8679,7 @@ package body Exp_Dist is
Rdef : constant Node_Id :=
Type_Definition
(Declaration_Node (Typ));
- Component_Counter : Int := 0;
+ Component_Counter : Nat := 0;
-- The returned object
@@ -8685,7 +8690,7 @@ package body Exp_Dist is
procedure FA_Rec_Add_Process_Element
(Stmts : List_Id;
Any : Entity_Id;
- Counter : in out Int;
+ Counter : in out Nat;
Rec : Entity_Id;
Field : Node_Id);
@@ -8701,7 +8706,7 @@ package body Exp_Dist is
procedure FA_Rec_Add_Process_Element
(Stmts : List_Id;
Any : Entity_Id;
- Counter : in out Int;
+ Counter : in out Nat;
Rec : Entity_Id;
Field : Node_Id)
is
@@ -8735,7 +8740,7 @@ package body Exp_Dist is
declare
Variant : Node_Id;
- Struct_Counter : Int := 0;
+ Struct_Counter : Nat := 0;
Block_Decls : constant List_Id := New_List;
Block_Stmts : constant List_Id := New_List;
@@ -9243,7 +9248,7 @@ package body Exp_Dist is
Typ : Entity_Id := Etype (N);
U_Type : Entity_Id;
C_Type : Entity_Id;
- Fnam : Entity_Id := Empty;
+ Fnam : Entity_Id;
Lib_RE : RE_Id := RE_Null;
begin
@@ -9540,13 +9545,13 @@ package body Exp_Dist is
Disc : Entity_Id := Empty;
Rdef : constant Node_Id :=
Type_Definition (Declaration_Node (Typ));
- Counter : Int := 0;
+ Counter : Nat := 0;
Elements : constant List_Id := New_List;
procedure TA_Rec_Add_Process_Element
(Stmts : List_Id;
Container : Node_Or_Entity_Id;
- Counter : in out Int;
+ Counter : in out Nat;
Rec : Entity_Id;
Field : Node_Id);
-- Processing routine for traversal below
@@ -9563,7 +9568,7 @@ package body Exp_Dist is
procedure TA_Rec_Add_Process_Element
(Stmts : List_Id;
Container : Node_Or_Entity_Id;
- Counter : in out Int;
+ Counter : in out Nat;
Rec : Entity_Id;
Field : Node_Id)
is
@@ -9593,7 +9598,7 @@ package body Exp_Dist is
Variant_Part : declare
Variant : Node_Id;
- Struct_Counter : Int := 0;
+ Struct_Counter : Nat := 0;
Block_Decls : constant List_Id := New_List;
Block_Stmts : constant List_Id := New_List;
@@ -10101,7 +10106,7 @@ package body Exp_Dist is
-- The full view, if Typ is private; the completion,
-- if Typ is incomplete.
- Fnam : Entity_Id := Empty;
+ Fnam : Entity_Id;
Lib_RE : RE_Id := RE_Null;
Expr : Node_Id;
@@ -10396,7 +10401,7 @@ package body Exp_Dist is
procedure TC_Rec_Add_Process_Element
(Params : List_Id;
Any : Entity_Id;
- Counter : in out Int;
+ Counter : in out Nat;
Rec : Entity_Id;
Field : Node_Id);
@@ -10412,7 +10417,7 @@ package body Exp_Dist is
procedure TC_Rec_Add_Process_Element
(Params : List_Id;
Any : Entity_Id;
- Counter : in out Int;
+ Counter : in out Nat;
Rec : Entity_Id;
Field : Node_Id)
is
@@ -10451,7 +10456,7 @@ package body Exp_Dist is
Default : constant Node_Id :=
Make_Integer_Literal (Loc, -1);
- Dummy_Counter : Int := 0;
+ Dummy_Counter : Nat := 0;
Choice_Index : Int := 0;
-- Index of current choice in TypeCode, used to identify
@@ -10902,8 +10907,8 @@ package body Exp_Dist is
raise Program_Error;
end if;
- -- TBD: fixed point types???
- -- TBverified numeric types with a biased representation???
+ -- What about fixed point types and numeric types with a biased
+ -- representation???
end Find_Numeric_Representation;
@@ -11344,10 +11349,10 @@ package body Exp_Dist is
begin
if Nkind (Spec) = N_Function_Specification then
- Set_Ekind (Snam, E_Function);
+ Mutate_Ekind (Snam, E_Function);
Set_Etype (Snam, Entity (Result_Definition (Spec)));
else
- Set_Ekind (Snam, E_Procedure);
+ Mutate_Ekind (Snam, E_Procedure);
Set_Etype (Snam, Standard_Void_Type);
end if;
diff --git a/gcc/ada/exp_dist.ads b/gcc/ada/exp_dist.ads
index 8951667..8b0d6e3 100644
--- a/gcc/ada/exp_dist.ads
+++ b/gcc/ada/exp_dist.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute 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 4c658bb..8d7624f 100644
--- a/gcc/ada/exp_fixd.adb
+++ b/gcc/ada/exp_fixd.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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,25 +23,28 @@
-- --
------------------------------------------------------------------------------
-with Atree; use Atree;
-with Checks; use Checks;
-with Einfo; use Einfo;
-with Exp_Util; use Exp_Util;
-with Nlists; use Nlists;
-with Nmake; use Nmake;
-with Restrict; use Restrict;
-with Rident; use Rident;
-with Rtsfind; use Rtsfind;
-with Sem; use Sem;
-with Sem_Eval; use Sem_Eval;
-with Sem_Res; use Sem_Res;
-with Sem_Util; use Sem_Util;
-with Sinfo; use Sinfo;
-with Stand; use Stand;
-with Tbuild; use Tbuild;
-with Ttypes; use Ttypes;
-with Uintp; use Uintp;
-with Urealp; use Urealp;
+with Atree; use Atree;
+with Checks; use Checks;
+with Einfo; use Einfo;
+with Einfo.Entities; use Einfo.Entities;
+with Einfo.Utils; use Einfo.Utils;
+with Exp_Util; use Exp_Util;
+with Nlists; use Nlists;
+with Nmake; use Nmake;
+with Restrict; use Restrict;
+with Rident; use Rident;
+with Rtsfind; use Rtsfind;
+with Sem; use Sem;
+with Sem_Eval; use Sem_Eval;
+with Sem_Res; use Sem_Res;
+with Sem_Util; use Sem_Util;
+with Sinfo; use Sinfo;
+with Sinfo.Nodes; use Sinfo.Nodes;
+with Stand; use Stand;
+with Tbuild; use Tbuild;
+with Ttypes; use Ttypes;
+with Uintp; use Uintp;
+with Urealp; use Urealp;
package body Exp_Fixd is
diff --git a/gcc/ada/exp_fixd.ads b/gcc/ada/exp_fixd.ads
index bebba8e..9a3b205 100644
--- a/gcc/ada/exp_fixd.ads
+++ b/gcc/ada/exp_fixd.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute 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 0cb483b..69b9f2d 100644
--- a/gcc/ada/exp_imgv.adb
+++ b/gcc/ada/exp_imgv.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2001-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2001-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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,29 +23,39 @@
-- --
------------------------------------------------------------------------------
-with Atree; use Atree;
-with Casing; use Casing;
-with Checks; use Checks;
-with Einfo; use Einfo;
+with Atree; use Atree;
+with Casing; use Casing;
+with Checks; use Checks;
+with Einfo; use Einfo;
+with Einfo.Entities; use Einfo.Entities;
+with Einfo.Utils; use Einfo.Utils;
+with Debug; use Debug;
with Exp_Put_Image;
-with Exp_Util; use Exp_Util;
-with Lib; use Lib;
-with Namet; use Namet;
-with Nmake; use Nmake;
-with Nlists; use Nlists;
-with Opt; use Opt;
-with Rtsfind; use Rtsfind;
-with Sem_Aux; use Sem_Aux;
-with Sem_Res; use Sem_Res;
-with Sem_Util; use Sem_Util;
-with Sinfo; use Sinfo;
-with Snames; use Snames;
-with Stand; use Stand;
-with Stringt; use Stringt;
-with Tbuild; use Tbuild;
-with Ttypes; use Ttypes;
-with Uintp; use Uintp;
-with Urealp; use Urealp;
+with Exp_Util; use Exp_Util;
+with Lib; use Lib;
+with Namet; use Namet;
+with Nmake; use Nmake;
+with Nlists; use Nlists;
+with Opt; use Opt;
+with Restrict; use Restrict;
+with Rident; use Rident;
+with Rtsfind; use Rtsfind;
+with Sem_Aux; use Sem_Aux;
+with Sem_Res; use Sem_Res;
+with Sem_Util; use Sem_Util;
+with Sinfo; use Sinfo;
+with Sinfo.Nodes; use Sinfo.Nodes;
+with Sinfo.Utils; use Sinfo.Utils;
+with Snames; use Snames;
+with Stand; use Stand;
+with Stringt; use Stringt;
+with Targparm; use Targparm;
+with Tbuild; use Tbuild;
+with Ttypes; use Ttypes;
+with Uintp; use Uintp;
+with Urealp; use Urealp;
+
+with System.Perfect_Hash_Generators;
package body Exp_Imgv is
@@ -65,21 +75,95 @@ package body Exp_Imgv is
------------------------------------
procedure Build_Enumeration_Image_Tables (E : Entity_Id; N : Node_Id) is
- Loc : constant Source_Ptr := Sloc (E);
+ Loc : constant Source_Ptr := Sloc (E);
+ In_Main_Unit : constant Boolean := In_Extended_Main_Code_Unit (Loc);
+ Act : List_Id;
Eind : Entity_Id;
Estr : Entity_Id;
+ H_Id : Entity_Id;
+ H_OK : Boolean;
+ H_Sp : Node_Id;
Ind : List_Id;
Ityp : Node_Id;
Len : Nat;
Lit : Entity_Id;
Nlit : Nat;
+ S_Id : Entity_Id;
+ S_N : Nat;
Str : String_Id;
+ package SPHG renames System.Perfect_Hash_Generators;
+
Saved_SSO : constant Character := Opt.Default_SSO;
-- Used to save the current scalar storage order during the generation
-- of the literal lookup table.
+ Serial_Number_Budget : constant := 50;
+ -- We may want to compute a perfect hash function for use by the Value
+ -- attribute. However computing this function is costly and, therefore,
+ -- cannot be done when compiling every unit where the enumeration type
+ -- is referenced, so we do it only when compiling the unit where it is
+ -- declared. This means that we may need to control the internal serial
+ -- numbers of this unit, or else we would risk generating public symbols
+ -- with mismatched names later on. The strategy for this is to allocate
+ -- a fixed budget of serial numbers to be spent from a specified point
+ -- until the end of the processing and to make sure that it is always
+ -- exactly spent on all possible paths from this point.
+
+ Threshold : constant Nat :=
+ (if Is_Library_Level_Entity (E)
+ or else not Always_Compatible_Rep_On_Target
+ then 3
+ else Nat'Last);
+ -- Threshold above which we want to generate the hash function in the
+ -- default case. We avoid doing it if this would cause a trampoline to
+ -- be generated because the type is local and descriptors are not used.
+
+ Threshold_For_Size : constant Nat := Nat'Max (Threshold, 9);
+ -- But the function and its tables take a bit of space so the threshold
+ -- is raised when compiling for size.
+
+ procedure Append_Table_To
+ (L : List_Id;
+ E : Entity_Id;
+ UB : Nat;
+ Ctyp : Entity_Id;
+ V : List_Id);
+ -- Append to L the declaration of E as a constant array of range 0 .. UB
+ -- and component type Ctyp with initial value V.
+
+ ---------------------
+ -- Append_Table_To --
+ ---------------------
+
+ procedure Append_Table_To
+ (L : List_Id;
+ E : Entity_Id;
+ UB : Nat;
+ Ctyp : Entity_Id;
+ V : List_Id)
+ is
+ begin
+ Append_To (L,
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => E,
+ Constant_Present => True,
+ Object_Definition =>
+ Make_Constrained_Array_Definition (Loc,
+ Discrete_Subtype_Definitions => New_List (
+ Make_Range (Loc,
+ Low_Bound => Make_Integer_Literal (Loc, 0),
+ High_Bound => Make_Integer_Literal (Loc, UB))),
+ Component_Definition =>
+ Make_Component_Definition (Loc,
+ Aliased_Present => False,
+ Subtype_Indication => New_Occurrence_Of (Ctyp, Loc))),
+ Expression => Make_Aggregate (Loc, Expressions => V)));
+ end Append_Table_To;
+
+ -- Start of Build_Enumeration_Image_Tables
+
begin
-- Nothing to do for types other than a root enumeration type
@@ -99,10 +183,10 @@ package body Exp_Imgv is
Lit := First_Literal (E);
Len := 1;
Nlit := 0;
+ H_OK := False;
loop
- Append_To (Ind,
- Make_Integer_Literal (Loc, UI_From_Int (Len)));
+ Append_To (Ind, Make_Integer_Literal (Loc, UI_From_Int (Len)));
exit when No (Lit);
Nlit := Nlit + 1;
@@ -114,6 +198,9 @@ package body Exp_Imgv is
end if;
Store_String_Chars (Name_Buffer (1 .. Name_Len));
+ if In_Main_Unit then
+ SPHG.Insert (Name_Buffer (1 .. Name_Len));
+ end if;
Len := Len + Int (Name_Len);
Next_Literal (Lit);
end loop;
@@ -148,7 +235,7 @@ package body Exp_Imgv is
-- Generate literal table
- Insert_Actions (N,
+ Act :=
New_List (
Make_Object_Declaration (Loc,
Defining_Identifier => Estr,
@@ -157,27 +244,433 @@ package body Exp_Imgv is
New_Occurrence_Of (Standard_String, Loc),
Expression =>
Make_String_Literal (Loc,
- Strval => Str)),
+ Strval => Str)));
- Make_Object_Declaration (Loc,
- Defining_Identifier => Eind,
- Constant_Present => True,
+ -- Generate index table
- Object_Definition =>
- Make_Constrained_Array_Definition (Loc,
- Discrete_Subtype_Definitions => New_List (
- Make_Range (Loc,
- Low_Bound => Make_Integer_Literal (Loc, 0),
- High_Bound => Make_Integer_Literal (Loc, Nlit))),
- Component_Definition =>
- Make_Component_Definition (Loc,
- Aliased_Present => False,
- Subtype_Indication => New_Occurrence_Of (Ityp, Loc))),
+ Append_Table_To (Act, Eind, Nlit, Ityp, Ind);
- Expression =>
- Make_Aggregate (Loc,
- Expressions => Ind))),
- Suppress => All_Checks);
+ -- If the number of literals is not greater than Threshold, then we are
+ -- done. Otherwise we generate a (perfect) hash function for use by the
+ -- Value attribute.
+
+ if Nlit > Threshold then
+ -- We start to count serial numbers from here
+
+ S_N := Increment_Serial_Number;
+
+ -- Generate specification of hash function
+
+ H_Id :=
+ Make_Defining_Identifier (Loc,
+ Chars => New_External_Name (Chars (E), 'H'));
+ Mutate_Ekind (H_Id, E_Function);
+ Set_Is_Internal (H_Id);
+
+ if not Debug_Generated_Code then
+ Set_Debug_Info_Off (H_Id);
+ end if;
+
+ Set_Lit_Hash (E, H_Id);
+
+ S_Id := Make_Temporary (Loc, 'S');
+
+ H_Sp := Make_Function_Specification (Loc,
+ Defining_Unit_Name => H_Id,
+ Parameter_Specifications => New_List (
+ Make_Parameter_Specification (Loc,
+ Defining_Identifier => S_Id,
+ Parameter_Type =>
+ New_Occurrence_Of (Standard_String, Loc))),
+ Result_Definition =>
+ New_Occurrence_Of (Standard_Natural, Loc));
+
+ -- If the unit where the type is declared is the main unit, and the
+ -- number of literals is greater than Threshold_For_Size when we are
+ -- optimizing for size, and the restriction No_Implicit_Loops is not
+ -- active, and -gnatd_h is not specified, generate the hash function.
+
+ if In_Main_Unit
+ and then (Optimize_Size = 0 or else Nlit > Threshold_For_Size)
+ and then not Restriction_Active (No_Implicit_Loops)
+ and then not Debug_Flag_Underscore_H
+ then
+ declare
+ LB : constant Positive := 2 * Positive (Nlit) + 1;
+ UB : constant Positive := LB + 24;
+
+ begin
+ -- Try at most 25 * 4 times to compute the hash function before
+ -- giving up and using a linear search for the Value attribute.
+
+ for V in LB .. UB loop
+ begin
+ SPHG.Initialize (4321, V, SPHG.Memory_Space, Tries => 4);
+ SPHG.Compute ("");
+ H_OK := True;
+ exit;
+ exception
+ when SPHG.Too_Many_Tries => null;
+ end;
+ end loop;
+ end;
+ end if;
+
+ -- If the hash function has been successfully computed, 4 more tables
+ -- named P, T1, T2 and G are needed. The hash function is of the form
+
+ -- function Hash (S : String) return Natural is
+ -- xxxP : constant array (0 .. X) of Natural = [...];
+ -- xxxT1 : constant array (0 .. Y) of Index_Type = [...];
+ -- xxxT2 : constant array (0 .. Y) of Index_Type = [...];
+ -- xxxG : constant array (0 .. Z) of Index_Type = [...];
+
+ -- F : constant Natural := S'First - 1;
+ -- L : constant Natural := S'Length;
+ -- A, B : Natural := 0;
+ -- J : Natural;
+
+ -- begin
+ -- for K in P'Range loop
+ -- exit when L < P (K);
+ -- J := Character'Pos (S (P (K) + F));
+ -- A := (A + Natural (T1 (K) * J)) mod N;
+ -- B := (B + Natural (T2 (K) * J)) mod N;
+ -- end loop;
+
+ -- return (Natural (G (A)) + Natural (G (B))) mod M;
+ -- end Hash;
+
+ -- where N is the length of G and M the number of literals. Note that
+ -- we declare the tables inside the function for two reasons: first,
+ -- their analysis creates array subtypes and thus their concatenation
+ -- operators which are homonyms of the concatenation operator and may
+ -- change the homonym number of user operators declared in the scope;
+ -- second, the code generator can fold the values in the tables when
+ -- they are small and avoid emitting them in the final object code.
+
+ if H_OK then
+ declare
+ Siz, L1, L2 : Natural;
+ I : Int;
+
+ Pos, T1, T2, G : List_Id;
+ EPos, ET1, ET2, EG : Entity_Id;
+
+ F, L, A, B, J, K : Entity_Id;
+ Body_Decls : List_Id;
+ Body_Stmts : List_Id;
+ Loop_Stmts : List_Id;
+
+ begin
+ Body_Decls := New_List;
+
+ -- Generate position table
+
+ SPHG.Define (SPHG.Character_Position, Siz, L1, L2);
+ Pos := New_List;
+ for J in 0 .. L1 - 1 loop
+ I := Int (SPHG.Value (SPHG.Character_Position, J));
+ Append_To (Pos, Make_Integer_Literal (Loc, UI_From_Int (I)));
+ end loop;
+
+ EPos :=
+ Make_Defining_Identifier (Loc,
+ Chars => New_External_Name (Chars (E), 'P'));
+
+ Append_Table_To
+ (Body_Decls, EPos, Nat (L1 - 1), Standard_Natural, Pos);
+
+ -- Generate function table 1
+
+ SPHG.Define (SPHG.Function_Table_1, Siz, L1, L2);
+ T1 := New_List;
+ for J in 0 .. L1 - 1 loop
+ I := Int (SPHG.Value (SPHG.Function_Table_1, J));
+ Append_To (T1, Make_Integer_Literal (Loc, UI_From_Int (I)));
+ end loop;
+
+ ET1 :=
+ Make_Defining_Identifier (Loc,
+ Chars => New_External_Name (Chars (E), "T1"));
+
+ Ityp :=
+ Small_Integer_Type_For (UI_From_Int (Int (Siz)), Uns => True);
+ Append_Table_To (Body_Decls, ET1, Nat (L1 - 1), Ityp, T1);
+
+ -- Generate function table 2
+
+ SPHG.Define (SPHG.Function_Table_2, Siz, L1, L2);
+ T2 := New_List;
+ for J in 0 .. L1 - 1 loop
+ I := Int (SPHG.Value (SPHG.Function_Table_2, J));
+ Append_To (T2, Make_Integer_Literal (Loc, UI_From_Int (I)));
+ end loop;
+
+ ET2 :=
+ Make_Defining_Identifier (Loc,
+ Chars => New_External_Name (Chars (E), "T2"));
+
+ Ityp :=
+ Small_Integer_Type_For (UI_From_Int (Int (Siz)), Uns => True);
+ Append_Table_To (Body_Decls, ET2, Nat (L1 - 1), Ityp, T2);
+
+ -- Generate graph table
+
+ SPHG.Define (SPHG.Graph_Table, Siz, L1, L2);
+ G := New_List;
+ for J in 0 .. L1 - 1 loop
+ I := Int (SPHG.Value (SPHG.Graph_Table, J));
+ Append_To (G, Make_Integer_Literal (Loc, UI_From_Int (I)));
+ end loop;
+
+ EG :=
+ Make_Defining_Identifier (Loc,
+ Chars => New_External_Name (Chars (E), 'G'));
+
+ Ityp :=
+ Small_Integer_Type_For (UI_From_Int (Int (Siz)), Uns => True);
+ Append_Table_To (Body_Decls, EG, Nat (L1 - 1), Ityp, G);
+
+ F := Make_Temporary (Loc, 'F');
+
+ Append_To (Body_Decls,
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => F,
+ Object_Definition =>
+ New_Occurrence_Of (Standard_Natural, Loc),
+ Expression =>
+ Make_Op_Subtract (Loc,
+ Left_Opnd =>
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Occurrence_Of (S_Id, Loc),
+ Attribute_Name => Name_First),
+ Right_Opnd =>
+ Make_Integer_Literal (Loc, 1))));
+
+ L := Make_Temporary (Loc, 'L');
+
+ Append_To (Body_Decls,
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => L,
+ Object_Definition =>
+ New_Occurrence_Of (Standard_Natural, Loc),
+ Expression =>
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Occurrence_Of (S_Id, Loc),
+ Attribute_Name => Name_Length)));
+
+ A := Make_Temporary (Loc, 'A');
+
+ Append_To (Body_Decls,
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => A,
+ Object_Definition =>
+ New_Occurrence_Of (Standard_Natural, Loc),
+ Expression => Make_Integer_Literal (Loc, 0)));
+
+ B := Make_Temporary (Loc, 'B');
+
+ Append_To (Body_Decls,
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => B,
+ Object_Definition =>
+ New_Occurrence_Of (Standard_Natural, Loc),
+ Expression => Make_Integer_Literal (Loc, 0)));
+
+ J := Make_Temporary (Loc, 'J');
+
+ Append_To (Body_Decls,
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => J,
+ Object_Definition =>
+ New_Occurrence_Of (Standard_Natural, Loc)));
+
+ K := Make_Temporary (Loc, 'K');
+
+ -- Generate exit when L < P (K);
+
+ Loop_Stmts := New_List (
+ Make_Exit_Statement (Loc,
+ Condition =>
+ Make_Op_Lt (Loc,
+ Left_Opnd => New_Occurrence_Of (L, Loc),
+ Right_Opnd =>
+ Make_Indexed_Component (Loc,
+ Prefix => New_Occurrence_Of (EPos, Loc),
+ Expressions => New_List (
+ New_Occurrence_Of (K, Loc))))));
+
+ -- Generate J := Character'Pos (S (P (K) + F));
+
+ Append_To (Loop_Stmts,
+ Make_Assignment_Statement (Loc,
+ Name => New_Occurrence_Of (J, Loc),
+ Expression =>
+ Make_Attribute_Reference (Loc,
+ Prefix =>
+ New_Occurrence_Of (Standard_Character, Loc),
+ Attribute_Name => Name_Pos,
+ Expressions => New_List (
+ Make_Indexed_Component (Loc,
+ Prefix => New_Occurrence_Of (S_Id, Loc),
+ Expressions => New_List (
+ Make_Op_Add (Loc,
+ Left_Opnd =>
+ Make_Indexed_Component (Loc,
+ Prefix =>
+ New_Occurrence_Of (EPos, Loc),
+ Expressions => New_List (
+ New_Occurrence_Of (K, Loc))),
+ Right_Opnd =>
+ New_Occurrence_Of (F, Loc))))))));
+
+ -- Generate A := (A + Natural (T1 (K) * J)) mod N;
+
+ Append_To (Loop_Stmts,
+ Make_Assignment_Statement (Loc,
+ Name => New_Occurrence_Of (A, Loc),
+ Expression =>
+ Make_Op_Mod (Loc,
+ Left_Opnd =>
+ Make_Op_Add (Loc,
+ Left_Opnd => New_Occurrence_Of (A, Loc),
+ Right_Opnd =>
+ Make_Op_Multiply (Loc,
+ Left_Opnd =>
+ Convert_To (Standard_Natural,
+ Make_Indexed_Component (Loc,
+ Prefix =>
+ New_Occurrence_Of (ET1, Loc),
+ Expressions => New_List (
+ New_Occurrence_Of (K, Loc)))),
+ Right_Opnd => New_Occurrence_Of (J, Loc))),
+ Right_Opnd => Make_Integer_Literal (Loc, Int (L1)))));
+
+ -- Generate B := (B + Natural (T2 (K) * J)) mod N;
+
+ Append_To (Loop_Stmts,
+ Make_Assignment_Statement (Loc,
+ Name => New_Occurrence_Of (B, Loc),
+ Expression =>
+ Make_Op_Mod (Loc,
+ Left_Opnd =>
+ Make_Op_Add (Loc,
+ Left_Opnd => New_Occurrence_Of (B, Loc),
+ Right_Opnd =>
+ Make_Op_Multiply (Loc,
+ Left_Opnd =>
+ Convert_To (Standard_Natural,
+ Make_Indexed_Component (Loc,
+ Prefix =>
+ New_Occurrence_Of (ET2, Loc),
+ Expressions => New_List (
+ New_Occurrence_Of (K, Loc)))),
+ Right_Opnd => New_Occurrence_Of (J, Loc))),
+ Right_Opnd => Make_Integer_Literal (Loc, Int (L1)))));
+
+ -- Generate loop
+
+ Body_Stmts := New_List (
+ Make_Implicit_Loop_Statement (N,
+ Iteration_Scheme =>
+ Make_Iteration_Scheme (Loc,
+ Loop_Parameter_Specification =>
+ Make_Loop_Parameter_Specification (Loc,
+ Defining_Identifier => K,
+ Discrete_Subtype_Definition =>
+ Make_Attribute_Reference (Loc,
+ Prefix =>
+ New_Occurrence_Of (EPos, Loc),
+ Attribute_Name => Name_Range))),
+ Statements => Loop_Stmts));
+
+ -- Generate return (Natural (G (A)) + Natural (G (B))) mod M;
+
+ Append_To (Body_Stmts,
+ Make_Simple_Return_Statement (Loc,
+ Expression =>
+ Make_Op_Mod (Loc,
+ Left_Opnd =>
+ Make_Op_Add (Loc,
+ Left_Opnd =>
+ Convert_To (Standard_Natural,
+ Make_Indexed_Component (Loc,
+ Prefix =>
+ New_Occurrence_Of (EG, Loc),
+ Expressions => New_List (
+ New_Occurrence_Of (A, Loc)))),
+ Right_Opnd =>
+ Convert_To (Standard_Natural,
+ Make_Indexed_Component (Loc,
+ Prefix =>
+ New_Occurrence_Of (EG, Loc),
+ Expressions => New_List (
+ New_Occurrence_Of (B, Loc))))),
+ Right_Opnd => Make_Integer_Literal (Loc, Nlit))));
+
+ -- Generate final body
+
+ Append_To (Act,
+ Make_Subprogram_Body (Loc,
+ Specification => H_Sp,
+ Declarations => Body_Decls,
+ Handled_Statement_Sequence =>
+ Make_Handled_Sequence_Of_Statements (Loc, Body_Stmts)));
+ end;
+
+ -- If we chose not to or did not manage to compute the hash function,
+ -- we need to build a dummy function always returning Natural'Last
+ -- because other units reference it if they use the Value attribute.
+
+ elsif In_Main_Unit then
+ declare
+ Body_Stmts : List_Id;
+
+ begin
+ -- Generate return Natural'Last
+
+ Body_Stmts := New_List (
+ Make_Simple_Return_Statement (Loc,
+ Expression =>
+ Make_Attribute_Reference (Loc,
+ Prefix =>
+ New_Occurrence_Of (Standard_Natural, Loc),
+ Attribute_Name => Name_Last)));
+
+ -- Generate body
+
+ Append_To (Act,
+ Make_Subprogram_Body (Loc,
+ Specification => H_Sp,
+ Declarations => Empty_List,
+ Handled_Statement_Sequence =>
+ Make_Handled_Sequence_Of_Statements (Loc, Body_Stmts)));
+ end;
+
+ -- For the other units, just declare the function
+
+ else
+ Append_To (Act,
+ Make_Subprogram_Declaration (Loc, Specification => H_Sp));
+ end if;
+
+ else
+ Set_Lit_Hash (E, Empty);
+ end if;
+
+ if In_Main_Unit then
+ System.Perfect_Hash_Generators.Finalize;
+ end if;
+
+ Insert_Actions (N, Act, Suppress => All_Checks);
+
+ -- This is where we check that our budget of serial numbers has been
+ -- entirely spent, see the declaration of Serial_Number_Budget above.
+
+ if Nlit > Threshold then
+ Synchronize_Serial_Number (S_N + Serial_Number_Budget);
+ end if;
-- Reset the scalar storage order to the saved value
@@ -233,7 +726,7 @@ package body Exp_Imgv is
-- For floating-point types
-- xx = Floating_Point
- -- tv = Long_Long_Float (Expr)
+ -- tv = [Long_[Long_]]Float (Expr)
-- pm = typ'Digits (typ = subtype of expression)
-- For decimal fixed-point types
@@ -250,8 +743,8 @@ package body Exp_Imgv is
-- typ'Aft
-- For other ordinary fixed-point types
- -- xx = Ordinary_Fixed_Point
- -- tv = Long_Long_Float (Expr)
+ -- xx = Fixed
+ -- tv = Long_Float (Expr)
-- pm = typ'Aft (typ = subtype of expression)
-- For enumeration types other than those declared in package Standard
@@ -277,26 +770,124 @@ package body Exp_Imgv is
Expr : constant Node_Id := Relocate_Node (First (Exprs));
Pref : constant Node_Id := Prefix (N);
- procedure Expand_User_Defined_Enumeration_Image;
+ procedure Expand_Standard_Boolean_Image;
+ -- Expand attribute 'Image in Standard.Boolean, avoiding string copy
+
+ procedure Expand_User_Defined_Enumeration_Image (Typ : Entity_Id);
-- Expand attribute 'Image in user-defined enumeration types, avoiding
-- string copy.
- function Is_User_Defined_Enumeration_Type
- (Typ : Entity_Id) return Boolean;
- -- Return True if Typ is a user-defined enumeration type
+ -----------------------------------
+ -- Expand_Standard_Boolean_Image --
+ -----------------------------------
+
+ procedure Expand_Standard_Boolean_Image is
+ Ins_List : constant List_Id := New_List;
+ S1_Id : constant Entity_Id := Make_Temporary (Loc, 'S');
+ T_Id : constant Entity_Id := Make_Temporary (Loc, 'T');
+ F_Id : constant Entity_Id := Make_Temporary (Loc, 'F');
+ V_Id : constant Entity_Id := Make_Temporary (Loc, 'V');
+
+ begin
+ -- We use a single 5-character string subtype throughout so that the
+ -- subtype of the string if-expression is constrained and, therefore,
+ -- does not force the creation of a temporary during analysis.
+
+ -- Generate:
+ -- subtype S1 is String (1 .. 5);
+
+ Append_To (Ins_List,
+ Make_Subtype_Declaration (Loc,
+ Defining_Identifier => S1_Id,
+ Subtype_Indication =>
+ Make_Subtype_Indication (Loc,
+ Subtype_Mark =>
+ New_Occurrence_Of (Standard_String, Loc),
+ Constraint =>
+ Make_Index_Or_Discriminant_Constraint (Loc,
+ Constraints => New_List (
+ Make_Range (Loc,
+ Low_Bound => Make_Integer_Literal (Loc, 1),
+ High_Bound => Make_Integer_Literal (Loc, 5)))))));
+
+ -- Generate:
+ -- T : constant String (1 .. 5) := "TRUE ";
+
+ Start_String;
+ Store_String_Chars ("TRUE ");
+
+ Append_To (Ins_List,
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => T_Id,
+ Object_Definition =>
+ New_Occurrence_Of (S1_Id, Loc),
+ Constant_Present => True,
+ Expression => Make_String_Literal (Loc, End_String)));
+
+ -- Generate:
+ -- F : constant String (1 .. 5) := "FALSE";
+
+ Start_String;
+ Store_String_Chars ("FALSE");
+
+ Append_To (Ins_List,
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => F_Id,
+ Object_Definition =>
+ New_Occurrence_Of (S1_Id, Loc),
+ Constant_Present => True,
+ Expression => Make_String_Literal (Loc, End_String)));
+
+ -- Generate:
+ -- V : String (1 .. 5) renames (if Expr then T else F);
+
+ Append_To (Ins_List,
+ Make_Object_Renaming_Declaration (Loc,
+ Defining_Identifier => V_Id,
+ Subtype_Mark =>
+ New_Occurrence_Of (S1_Id, Loc),
+ Name =>
+ Make_If_Expression (Loc,
+ Expressions => New_List (
+ Duplicate_Subexpr (Expr),
+ New_Occurrence_Of (T_Id, Loc),
+ New_Occurrence_Of (F_Id, Loc)))));
+
+ -- Insert all the above declarations before N. We suppress checks
+ -- because everything is in range at this stage.
+
+ Insert_Actions (N, Ins_List, Suppress => All_Checks);
+
+ -- Final step is to rewrite the expression as a slice:
+ -- V (1 .. (if Expr then 4 else 5)) and analyze, again with no
+ -- checks, since we are sure that everything is OK.
+
+ Rewrite (N,
+ Make_Slice (Loc,
+ Prefix => New_Occurrence_Of (V_Id, Loc),
+ Discrete_Range =>
+ Make_Range (Loc,
+ Low_Bound => Make_Integer_Literal (Loc, 1),
+ High_Bound =>
+ Make_If_Expression (Loc,
+ Expressions => New_List (
+ Duplicate_Subexpr (Expr),
+ Make_Integer_Literal (Loc, 4),
+ Make_Integer_Literal (Loc, 5))))));
+
+ Analyze_And_Resolve (N, Standard_String, Suppress => All_Checks);
+ end Expand_Standard_Boolean_Image;
-------------------------------------------
-- Expand_User_Defined_Enumeration_Image --
-------------------------------------------
- procedure Expand_User_Defined_Enumeration_Image is
+ procedure Expand_User_Defined_Enumeration_Image (Typ : Entity_Id) is
Ins_List : constant List_Id := New_List;
P1_Id : constant Entity_Id := Make_Temporary (Loc, 'P');
P2_Id : constant Entity_Id := Make_Temporary (Loc, 'P');
P3_Id : constant Entity_Id := Make_Temporary (Loc, 'P');
P4_Id : constant Entity_Id := Make_Temporary (Loc, 'P');
- Ptyp : constant Entity_Id := Entity (Pref);
- Rtyp : constant Entity_Id := Root_Type (Ptyp);
S1_Id : constant Entity_Id := Make_Temporary (Loc, 'S');
begin
@@ -308,7 +899,7 @@ package body Exp_Imgv is
end if;
-- Generate:
- -- P1 : constant Natural := Pos;
+ -- P1 : constant Natural := Typ'Pos (Typ?(Expr));
Append_To (Ins_List,
Make_Object_Declaration (Loc,
@@ -320,8 +911,8 @@ package body Exp_Imgv is
Convert_To (Standard_Natural,
Make_Attribute_Reference (Loc,
Attribute_Name => Name_Pos,
- Prefix => New_Occurrence_Of (Ptyp, Loc),
- Expressions => New_List (Expr)))));
+ Prefix => New_Occurrence_Of (Typ, Loc),
+ Expressions => New_List (OK_Convert_To (Typ, Expr))))));
-- Compute the index of the string start, generating:
-- P2 : constant Natural := call_put_enumN (P1);
@@ -336,7 +927,7 @@ package body Exp_Imgv is
Convert_To (Standard_Natural,
Make_Indexed_Component (Loc,
Prefix =>
- New_Occurrence_Of (Lit_Indexes (Rtyp), Loc),
+ New_Occurrence_Of (Lit_Indexes (Typ), Loc),
Expressions =>
New_List (New_Occurrence_Of (P1_Id, Loc))))));
@@ -360,13 +951,13 @@ package body Exp_Imgv is
Convert_To (Standard_Natural,
Make_Indexed_Component (Loc,
Prefix =>
- New_Occurrence_Of (Lit_Indexes (Rtyp), Loc),
+ New_Occurrence_Of (Lit_Indexes (Typ), Loc),
Expressions =>
New_List (Add_Node)))));
end;
-- Generate:
- -- S4 : String renames call_put_enumS (S2 .. S3 - 1);
+ -- P4 : String renames call_put_enumS (P2 .. P3 - 1);
declare
Sub_Node : constant Node_Id := New_Op_Node (N_Op_Subtract, Loc);
@@ -383,7 +974,7 @@ package body Exp_Imgv is
Name =>
Make_Slice (Loc,
Prefix =>
- New_Occurrence_Of (Lit_Strings (Rtyp), Loc),
+ New_Occurrence_Of (Lit_Strings (Typ), Loc),
Discrete_Range =>
Make_Range (Loc,
Low_Bound => New_Occurrence_Of (P2_Id, Loc),
@@ -391,7 +982,7 @@ package body Exp_Imgv is
end;
-- Generate:
- -- subtype S1 is string (1 .. P3 - P2);
+ -- subtype S1 is String (1 .. P3 - P2);
declare
HB : constant Node_Id := New_Op_Node (N_Op_Subtract, Loc);
@@ -426,20 +1017,6 @@ package body Exp_Imgv is
Analyze_And_Resolve (N, Standard_String);
end Expand_User_Defined_Enumeration_Image;
- --------------------------------------
- -- Is_User_Defined_Enumeration_Type --
- --------------------------------------
-
- function Is_User_Defined_Enumeration_Type
- (Typ : Entity_Id) return Boolean is
- begin
- return Ekind (Typ) = E_Enumeration_Type
- and then Typ /= Standard_Boolean
- and then Typ /= Standard_Character
- and then Typ /= Standard_Wide_Character
- and then Typ /= Standard_Wide_Wide_Character;
- end Is_User_Defined_Enumeration_Type;
-
-- Local variables
Enum_Case : Boolean;
@@ -467,76 +1044,46 @@ package body Exp_Imgv is
return;
end if;
- Ptyp := Entity (Pref);
+ -- If 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;
+ end if;
+
+ Ptyp := Underlying_Type (Entity (Pref));
- -- Ada 2020 allows 'Image on private types, so fetch the underlying
+ -- Ada 2022 allows 'Image on private types, so fetch the underlying
-- type to obtain the structure of the type. We use the base type,
- -- not the root type, to handle properly derived types, but we use
- -- the root type for enumeration types, because the literal map is
- -- attached to the root. Should be inherited ???
+ -- not the root type for discrete types, to handle properly derived
+ -- types, but we use the root type for enumeration types, because the
+ -- literal map is attached to the root. Should be inherited ???
- if Is_Enumeration_Type (Ptyp) then
+ if Is_Real_Type (Ptyp) or else Is_Enumeration_Type (Ptyp) then
Rtyp := Underlying_Type (Root_Type (Ptyp));
else
Rtyp := Underlying_Type (Base_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.
-
- if Optimization_Level > 0
- and then not Global_Discard_Names
- and then Is_User_Defined_Enumeration_Type (Rtyp)
- then
- Expand_User_Defined_Enumeration_Image;
- return;
- end if;
-
- -- Build declarations of Snn and Pnn to be inserted
-
- Ins_List := New_List (
-
- -- Snn : String (1 .. typ'Width);
-
- Make_Object_Declaration (Loc,
- Defining_Identifier => Snn,
- Object_Definition =>
- Make_Subtype_Indication (Loc,
- Subtype_Mark => New_Occurrence_Of (Standard_String, Loc),
- Constraint =>
- Make_Index_Or_Discriminant_Constraint (Loc,
- Constraints => New_List (
- Make_Range (Loc,
- Low_Bound => Make_Integer_Literal (Loc, 1),
- High_Bound =>
- Make_Attribute_Reference (Loc,
- Prefix => New_Occurrence_Of (Rtyp, Loc),
- Attribute_Name => Name_Width)))))),
-
- -- Pnn : Natural;
-
- Make_Object_Declaration (Loc,
- Defining_Identifier => Pnn,
- Object_Definition => New_Occurrence_Of (Standard_Natural, Loc)));
-
-- Set Imid (RE_Id of procedure to call), and Tent, target for the
-- type conversion of the first argument for all possibilities.
Enum_Case := False;
- -- If this is a case where Image should be transformed using Put_Image,
- -- then do so. See Exp_Put_Image for details.
+ if Rtyp = Standard_Boolean then
+ -- Use inline expansion if the -gnatd_x switch is not passed to the
+ -- compiler. Otherwise expand into a call to the runtime.
- 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;
+ if not Debug_Flag_Underscore_X then
+ Expand_Standard_Boolean_Image;
+ return;
- elsif Rtyp = Standard_Boolean then
- Imid := RE_Image_Boolean;
- Tent := Rtyp;
+ else
+ Imid := RE_Image_Boolean;
+ Tent := Rtyp;
+ end if;
-- For standard character, we have to select the version which handles
-- soft hyphen correctly, based on the version of Ada in use (this is
@@ -631,14 +1178,26 @@ package body Exp_Imgv is
Imid := RE_Image_Fixed128;
Tent := RTE (RE_Integer_128);
else
- Imid := RE_Image_Ordinary_Fixed_Point;
- Tent := Standard_Long_Long_Float;
+ Imid := RE_Image_Fixed;
+ Tent := Standard_Long_Float;
end if;
end;
elsif Is_Floating_Point_Type (Rtyp) then
- Imid := RE_Image_Floating_Point;
- Tent := Standard_Long_Long_Float;
+ -- Short_Float and Float are the same type for GNAT
+
+ if Rtyp = Standard_Short_Float or else Rtyp = Standard_Float then
+ Imid := RE_Image_Float;
+ Tent := Standard_Float;
+
+ elsif Rtyp = Standard_Long_Float then
+ Imid := RE_Image_Long_Float;
+ Tent := Standard_Long_Float;
+
+ else
+ Imid := RE_Image_Long_Long_Float;
+ Tent := Standard_Long_Long_Float;
+ end if;
-- Only other possibility is user-defined enumeration type
@@ -666,9 +1225,14 @@ package body Exp_Imgv is
Analyze_And_Resolve (N, Standard_String);
return;
- else
- -- Here for enumeration type case
+ -- Use inline expansion if the -gnatd_x switch is not passed to the
+ -- compiler. Otherwise expand into a call to the runtime.
+
+ elsif not Debug_Flag_Underscore_X then
+ Expand_User_Defined_Enumeration_Image (Rtyp);
+ return;
+ else
Ttyp := Component_Type (Etype (Lit_Indexes (Rtyp)));
if Ttyp = Standard_Integer_8 then
@@ -695,27 +1259,13 @@ package body Exp_Imgv is
-- Build first argument for call
if Enum_Case then
- declare
- T : Entity_Id;
- begin
- -- In Ada 2020 we need the underlying type here, because 'Image is
- -- allowed on private types. We have already checked the version
- -- when resolving the attribute.
-
- if Is_Private_Type (Ptyp) 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;
+ Arg_List := New_List (
+ Make_Attribute_Reference (Loc,
+ Attribute_Name => Name_Pos,
+ Prefix => New_Occurrence_Of (Ptyp, Loc),
+ Expressions => New_List (Expr)));
- -- AI12-0020: Ada 2020 allows 'Image for all types, including private
+ -- AI12-0020: Ada 2022 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
@@ -725,6 +1275,7 @@ package body Exp_Imgv is
else
declare
Conv : Node_Id;
+
begin
if Is_Private_Type (Etype (Expr)) then
if Is_Fixed_Point_Type (Rtyp) then
@@ -740,6 +1291,33 @@ package body Exp_Imgv is
end;
end if;
+ -- Build declarations of Snn and Pnn to be inserted
+
+ Ins_List := New_List (
+
+ -- Snn : String (1 .. typ'Width);
+
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Snn,
+ Object_Definition =>
+ Make_Subtype_Indication (Loc,
+ Subtype_Mark => New_Occurrence_Of (Standard_String, Loc),
+ Constraint =>
+ Make_Index_Or_Discriminant_Constraint (Loc,
+ Constraints => New_List (
+ Make_Range (Loc,
+ Low_Bound => Make_Integer_Literal (Loc, 1),
+ High_Bound =>
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Occurrence_Of (Rtyp, Loc),
+ Attribute_Name => Name_Width)))))),
+
+ -- Pnn : Natural;
+
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Pnn,
+ Object_Definition => New_Occurrence_Of (Standard_Natural, Loc)));
+
-- Append Snn, Pnn arguments
Append_To (Arg_List, New_Occurrence_Of (Snn, Loc));
@@ -787,7 +1365,7 @@ package body Exp_Imgv is
-- and also set to do literal conversion.
elsif Is_Ordinary_Fixed_Point_Type (Rtyp) then
- if Imid /= RE_Image_Ordinary_Fixed_Point then
+ if Imid /= RE_Image_Fixed then
Set_Conversion_OK (First (Arg_List));
Append_To (Arg_List,
@@ -850,6 +1428,71 @@ package body Exp_Imgv is
Analyze_And_Resolve (N, Standard_String, Suppress => All_Checks);
end Expand_Image_Attribute;
+ ----------------------------------
+ -- Expand_Valid_Value_Attribute --
+ ----------------------------------
+
+ procedure Expand_Valid_Value_Attribute (N : Node_Id) is
+ Loc : constant Source_Ptr := Sloc (N);
+ Btyp : constant Entity_Id := Base_Type (Entity (Prefix (N)));
+ Rtyp : constant Entity_Id := Root_Type (Btyp);
+ pragma Assert (Is_Enumeration_Type (Rtyp));
+
+ Args : constant List_Id := Expressions (N);
+ Func : RE_Id;
+ Ttyp : Entity_Id;
+
+ begin
+ -- Generate:
+
+ -- Valid_Value_Enumeration_NN
+ -- (typS, typN'Address, typH'Unrestricted_Access, Num, X)
+
+ Ttyp := Component_Type (Etype (Lit_Indexes (Rtyp)));
+
+ if Ttyp = Standard_Integer_8 then
+ Func := RE_Valid_Value_Enumeration_8;
+ elsif Ttyp = Standard_Integer_16 then
+ Func := RE_Valid_Value_Enumeration_16;
+ else
+ Func := RE_Valid_Value_Enumeration_32;
+ end if;
+
+ Prepend_To (Args,
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Occurrence_Of (Rtyp, Loc),
+ Attribute_Name => Name_Pos,
+ Expressions => New_List (
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Occurrence_Of (Rtyp, Loc),
+ Attribute_Name => Name_Last))));
+
+ if Present (Lit_Hash (Rtyp)) then
+ Prepend_To (Args,
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Occurrence_Of (Lit_Hash (Rtyp), Loc),
+ Attribute_Name => Name_Unrestricted_Access));
+ else
+ Prepend_To (Args, Make_Null (Loc));
+ end if;
+
+ Prepend_To (Args,
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Occurrence_Of (Lit_Indexes (Rtyp), Loc),
+ Attribute_Name => Name_Address));
+
+ Prepend_To (Args,
+ New_Occurrence_Of (Lit_Strings (Rtyp), Loc));
+
+ Rewrite (N,
+ Make_Function_Call (Loc,
+ Name =>
+ New_Occurrence_Of (RTE (Func), Loc),
+ Parameter_Associations => Args));
+
+ Analyze_And_Resolve (N, Standard_Boolean);
+ end Expand_Valid_Value_Attribute;
+
----------------------------
-- Expand_Value_Attribute --
----------------------------
@@ -886,12 +1529,16 @@ package body Exp_Imgv is
-- btyp?(Value_Decimal{32,64,128} (X, typ'Scale));
- -- For the most common ordinary fixed-point types
+ -- For the most common ordinary fixed-point types, it expands into
-- btyp?(Value_Fixed{32,64,128} (X, numerator of S, denominator of S));
-- where S = typ'Small
- -- For Wide_[Wide_]Character types, typ'Value (X) expands into:
+ -- For other ordinary fixed-point types, it expands into
+
+ -- btyp (Value_Long_Float (X))
+
+ -- For Wide_[Wide_]Character types, typ'Value (X) expands into
-- btyp (Value_xx (X, EM))
@@ -900,36 +1547,40 @@ package body Exp_Imgv is
-- For enumeration types other than those derived from types Boolean,
-- Character, Wide_[Wide_]Character in Standard, typ'Value (X) expands to:
- -- Enum'Val (Value_Enumeration_NN (typS, typI'Address, Num, X))
+ -- Enum'Val
+ -- (Value_Enumeration_NN
+ -- (typS, typN'Address, typH'Unrestricted_Access, Num, X))
- -- where typS and typI and the Lit_Strings and Lit_Indexes entities
- -- from T's root type entity, and Num is Enum'Pos (Enum'Last). The
- -- Value_Enumeration_NN function will search the tables looking for
+ -- where typS, typN and typH are the Lit_Strings, Lit_Indexes and Lit_Hash
+ -- entities from T's root type entity, and Num is Enum'Pos (Enum'Last).
+ -- The Value_Enumeration_NN function will search the tables looking for
-- X and return the position number in the table if found which is
-- used to provide the result of 'Value (using Enum'Val). If the
-- value is not found Constraint_Error is raised. The suffix _NN
- -- depends on the element type of typI.
+ -- depends on the element type of typN.
procedure Expand_Value_Attribute (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
- Typ : constant Entity_Id := Etype (N);
- Btyp : constant Entity_Id := Base_Type (Typ);
- Rtyp : constant Entity_Id := Root_Type (Typ);
- Exprs : constant List_Id := Expressions (N);
- Vid : RE_Id;
- Args : List_Id;
- Func : RE_Id;
+ Btyp : constant Entity_Id := Etype (N);
+ pragma Assert (Is_Base_Type (Btyp));
+ pragma Assert (Btyp = Base_Type (Entity (Prefix (N))));
+ Rtyp : constant Entity_Id := Root_Type (Btyp);
+
+ Args : constant List_Id := Expressions (N);
Ttyp : Entity_Id;
+ Vid : RE_Id;
begin
- Args := Exprs;
-
- if Rtyp = Standard_Character then
- Vid := RE_Value_Character;
+ -- Fall through for all cases except user-defined enumeration type
+ -- and decimal types, with Vid set to the Id of the entity for the
+ -- Value routine and Args set to the list of parameters for the call.
- elsif Rtyp = Standard_Boolean then
+ if Rtyp = Standard_Boolean then
Vid := RE_Value_Boolean;
+ elsif Rtyp = Standard_Character then
+ Vid := RE_Value_Character;
+
elsif Rtyp = Standard_Wide_Character then
Vid := RE_Value_Wide_Character;
@@ -1036,21 +1687,11 @@ package body Exp_Imgv is
if Rtyp = Standard_Short_Float or else Rtyp = Standard_Float then
Vid := RE_Value_Float;
- -- If Long_Float and Long_Long_Float are the same type, then use the
- -- implementation of the former, which is faster and more accurate.
-
- elsif Rtyp = Standard_Long_Float
- or else (Rtyp = Standard_Long_Long_Float
- and then
- Standard_Long_Long_Float_Size = Standard_Long_Float_Size)
- then
+ elsif Rtyp = Standard_Long_Float then
Vid := RE_Value_Long_Float;
- elsif Rtyp = Standard_Long_Long_Float then
- Vid := RE_Value_Long_Long_Float;
-
else
- raise Program_Error;
+ Vid := RE_Value_Long_Long_Float;
end if;
-- Only other possibility is user-defined enumeration type
@@ -1061,7 +1702,7 @@ package body Exp_Imgv is
-- Case of pragma Discard_Names, transform the Value
-- attribute to Btyp'Val (Long_Long_Integer'Value (Args))
- if Discard_Names (First_Subtype (Typ))
+ if Discard_Names (First_Subtype (Btyp))
or else No (Lit_Strings (Rtyp))
then
Rewrite (N,
@@ -1077,20 +1718,21 @@ package body Exp_Imgv is
Analyze_And_Resolve (N, Btyp);
- -- Here for normal case where we have enumeration tables, this
- -- is where we build
+ -- Normal case where we have enumeration tables, build
- -- T'Val (Value_Enumeration_NN (typS, typI'Address, Num, X))
+ -- T'Val
+ -- (Value_Enumeration_NN
+ -- (typS, typN'Address, typH'Unrestricted_Access, Num, X))
else
Ttyp := Component_Type (Etype (Lit_Indexes (Rtyp)));
if Ttyp = Standard_Integer_8 then
- Func := RE_Value_Enumeration_8;
+ Vid := RE_Value_Enumeration_8;
elsif Ttyp = Standard_Integer_16 then
- Func := RE_Value_Enumeration_16;
+ Vid := RE_Value_Enumeration_16;
else
- Func := RE_Value_Enumeration_32;
+ Vid := RE_Value_Enumeration_32;
end if;
Prepend_To (Args,
@@ -1102,6 +1744,15 @@ package body Exp_Imgv is
Prefix => New_Occurrence_Of (Rtyp, Loc),
Attribute_Name => Name_Last))));
+ if Present (Lit_Hash (Rtyp)) then
+ Prepend_To (Args,
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Occurrence_Of (Lit_Hash (Rtyp), Loc),
+ Attribute_Name => Name_Unrestricted_Access));
+ else
+ Prepend_To (Args, Make_Null (Loc));
+ end if;
+
Prepend_To (Args,
Make_Attribute_Reference (Loc,
Prefix => New_Occurrence_Of (Lit_Indexes (Rtyp), Loc),
@@ -1112,12 +1763,12 @@ package body Exp_Imgv is
Rewrite (N,
Make_Attribute_Reference (Loc,
- Prefix => New_Occurrence_Of (Typ, Loc),
+ Prefix => New_Occurrence_Of (Btyp, Loc),
Attribute_Name => Name_Val,
Expressions => New_List (
Make_Function_Call (Loc,
Name =>
- New_Occurrence_Of (RTE (Func), Loc),
+ New_Occurrence_Of (RTE (Vid), Loc),
Parameter_Associations => Args))));
Analyze_And_Resolve (N, Btyp);
@@ -1126,21 +1777,13 @@ package body Exp_Imgv is
return;
end if;
- -- Fall through for all cases except user-defined enumeration type
- -- and decimal types, with Vid set to the Id of the entity for the
- -- Value routine and Args set to the list of parameters for the call.
-
-- Compiling package Ada.Tags under No_Run_Time_Mode we disable the
-- expansion of the attribute into the function call statement to avoid
-- generating spurious errors caused by the use of Integer_Address'Value
- -- in our implementation of Ada.Tags.Internal_Tag
-
- -- Seems like a bit of a odd approach, there should be a better way ???
-
- -- There is a better way, test RTE_Available ???
+ -- in our implementation of Ada.Tags.Internal_Tag.
if No_Run_Time_Mode
- and then Rtyp = RTE (RE_Integer_Address)
+ and then Is_RTE (Rtyp, RE_Integer_Address)
and then RTU_Loaded (Ada_Tags)
and then Cunit_Entity (Current_Sem_Unit)
= Body_Entity (RTU_Entity (Ada_Tags))
@@ -1148,6 +1791,7 @@ package body Exp_Imgv is
Rewrite (N,
Unchecked_Convert_To (Rtyp,
Make_Integer_Literal (Loc, Uint_0)));
+
else
Rewrite (N,
Convert_To (Btyp,
diff --git a/gcc/ada/exp_imgv.ads b/gcc/ada/exp_imgv.ads
index dea323f..f6ce172 100644
--- a/gcc/ada/exp_imgv.ads
+++ b/gcc/ada/exp_imgv.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2000-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2000-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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,39 +35,43 @@ package Exp_Imgv is
-- base type. The node N is the point in the tree where the resulting
-- declarations are to be inserted.
--
- -- The form of the tables generated is as follows:
+ -- The form of the tables generated is as follows:
--
- -- xxxS : string := "chars";
- -- xxxI : array (0 .. N) of Natural_8/16/32 := (1, n, .., n);
+ -- xxxS : constant string (1 .. M) := "chars";
+ -- xxxN : constant array (0 .. N) of Index_Type := (i1, i2, .., iN, j);
--
- -- Here xxxS is a string obtained by concatenating all the names
- -- of the enumeration literals in sequence, representing any wide
- -- characters according to the current wide character encoding
- -- method, and with all letters forced to upper case.
+ -- Here xxxS is a string obtained by concatenating all the names of the
+ -- enumeration literals in sequence, representing any wide characters
+ -- according to the current wide character encoding method, and with all
+ -- letters forced to upper case.
--
- -- The array xxxI is an array of ones origin indexes to the start
- -- of each name, with one extra entry at the end, which is the index
- -- to the character just past the end of the last literal, i.e. it is
- -- the length of xxxS + 1. The element type is the shortest of the
- -- possible types that will hold all the values.
+ -- The array xxxN is an array of indexes into xxxS pointing to the start
+ -- of each name, with one extra entry at the end, which is the index to
+ -- the character just past the end of the last literal, i.e. it is the
+ -- length of xxxS + 1. The element type is the shortest of the possible
+ -- types that will hold all the values.
--
- -- For example, for the type
+ -- For example, for the type
--
- -- type x is (hello,'!',goodbye);
+ -- type x is (hello,'!',goodbye);
--
- -- the generated tables would consist of
+ -- the generated tables would consist of
--
- -- xxxS : String := "hello'!'goodbye";
- -- xxxI : array (0 .. 3) of Natural_8 := (1, 6, 9, 16);
+ -- xxxS : constant string (1 .. 15) := "hello'!'goodbye";
+ -- xxxN : constant array (0 .. 3) of Integer_8 := (1, 6, 9, 16);
--
- -- Here Natural_8 is used since 16 < 2**(8-1)
+ -- Here Integer_8 is used since 16 < 2**(8-1).
--
- -- If the entity E needs the tables constructing, the necessary
- -- declarations are constructed, and the fields Lit_Strings and
- -- Lit_Indexes of E are set to point to the corresponding entities.
- -- If no tables are needed (E is not a user defined enumeration
- -- root type, or pragma Discard_Names is in effect, then the
- -- declarations are not constructed, and the fields remain Empty.
+ -- If the entity E needs the tables, the necessary declarations are built
+ -- and the fields Lit_Strings and Lit_Indexes of E are set to point to the
+ -- corresponding entities. If no tables are needed (E is not a user defined
+ -- enumeration root type, or pragma Discard_Names is in effect), then the
+ -- declarations are not constructed and the fields remain Empty.
+ --
+ -- If the number of enumeration literals is large enough, a (perfect) hash
+ -- function mapping the literals to their position number is also built and
+ -- requires additional tables. See the System.Perfect_Hash_Generators unit
+ -- for a complete description of this processing.
procedure Expand_Image_Attribute (N : Node_Id);
-- This procedure is called from Exp_Attr to expand an occurrence of the
@@ -81,6 +85,10 @@ package Exp_Imgv is
-- This procedure is called from Exp_Attr to expand an occurrence of the
-- attribute Wide_Wide_Image.
+ procedure Expand_Valid_Value_Attribute (N : Node_Id);
+ -- This procedure is called from Exp_Attr to expand an occurrence of the
+ -- attribute Valid_Value.
+
procedure Expand_Value_Attribute (N : Node_Id);
-- This procedure is called from Exp_Attr to expand an occurrence of the
-- attribute Value.
diff --git a/gcc/ada/exp_intr.adb b/gcc/ada/exp_intr.adb
index 3be039b..45de0fb 100644
--- a/gcc/ada/exp_intr.adb
+++ b/gcc/ada/exp_intr.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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,38 +23,41 @@
-- --
------------------------------------------------------------------------------
-with Atree; use Atree;
-with Checks; use Checks;
-with Einfo; use Einfo;
-with Elists; use Elists;
-with Expander; use Expander;
-with Exp_Atag; use Exp_Atag;
-with Exp_Ch7; use Exp_Ch7;
-with Exp_Ch11; use Exp_Ch11;
-with Exp_Code; use Exp_Code;
-with Exp_Fixd; use Exp_Fixd;
-with Exp_Util; use Exp_Util;
-with Freeze; use Freeze;
-with Inline; use Inline;
-with Nmake; use Nmake;
-with Nlists; use Nlists;
-with Opt; use Opt;
-with Restrict; use Restrict;
-with Rident; use Rident;
-with Rtsfind; use Rtsfind;
-with Sem; use Sem;
-with Sem_Aux; use Sem_Aux;
-with Sem_Eval; use Sem_Eval;
-with Sem_Res; use Sem_Res;
-with Sem_Type; use Sem_Type;
-with Sem_Util; use Sem_Util;
-with Sinfo; use Sinfo;
-with Sinput; use Sinput;
-with Snames; use Snames;
-with Stand; use Stand;
-with Tbuild; use Tbuild;
-with Uintp; use Uintp;
-with Urealp; use Urealp;
+with Atree; use Atree;
+with Checks; use Checks;
+with Einfo; use Einfo;
+with Einfo.Entities; use Einfo.Entities;
+with Einfo.Utils; use Einfo.Utils;
+with Elists; use Elists;
+with Expander; use Expander;
+with Exp_Atag; use Exp_Atag;
+with Exp_Ch7; use Exp_Ch7;
+with Exp_Ch11; use Exp_Ch11;
+with Exp_Code; use Exp_Code;
+with Exp_Fixd; use Exp_Fixd;
+with Exp_Util; use Exp_Util;
+with Freeze; use Freeze;
+with Inline; use Inline;
+with Nmake; use Nmake;
+with Nlists; use Nlists;
+with Opt; use Opt;
+with Restrict; use Restrict;
+with Rident; use Rident;
+with Rtsfind; use Rtsfind;
+with Sem; use Sem;
+with Sem_Aux; use Sem_Aux;
+with Sem_Eval; use Sem_Eval;
+with Sem_Res; use Sem_Res;
+with Sem_Type; use Sem_Type;
+with Sem_Util; use Sem_Util;
+with Sinfo; use Sinfo;
+with Sinfo.Nodes; use Sinfo.Nodes;
+with Sinfo.Utils; use Sinfo.Utils;
+with Sinput; use Sinput;
+with Snames; use Snames;
+with Stand; use Stand;
+with Tbuild; use Tbuild;
+with Uintp; use Uintp;
package body Exp_Intr is
@@ -66,9 +69,6 @@ package body Exp_Intr is
-- Expand a call to an intrinsic arithmetic operator when the operand
-- types or sizes are not identical.
- procedure Expand_Is_Negative (N : Node_Id);
- -- Expand a call to the intrinsic Is_Negative function
-
procedure Expand_Dispatching_Constructor_Call (N : Node_Id);
-- Expand a call to an instantiation of Generic_Dispatching_Constructor
-- into a dispatching call to the actual subprogram associated with the
@@ -521,7 +521,7 @@ package body Exp_Intr is
if No (Choice_Parameter (P)) then
E := Make_Temporary (Loc, 'E');
Set_Choice_Parameter (P, E);
- Set_Ekind (E, E_Variable);
+ Mutate_Ekind (E, E_Variable);
Set_Etype (E, RTE (RE_Exception_Occurrence));
Set_Scope (E, Current_Scope);
end if;
@@ -636,9 +636,6 @@ package body Exp_Intr is
then
Expand_Import_Call (N);
- elsif Nam = Name_Is_Negative then
- Expand_Is_Negative (N);
-
elsif Nam = Name_Rotate_Left then
Expand_Shift (N, E, N_Op_Rotate_Left);
@@ -696,58 +693,6 @@ package body Exp_Intr is
end if;
end Expand_Intrinsic_Call;
- ------------------------
- -- Expand_Is_Negative --
- ------------------------
-
- procedure Expand_Is_Negative (N : Node_Id) is
- Loc : constant Source_Ptr := Sloc (N);
- Opnd : constant Node_Id := Relocate_Node (First_Actual (N));
-
- begin
-
- -- We replace the function call by the following expression
-
- -- if Opnd < 0.0 then
- -- True
- -- else
- -- if Opnd > 0.0 then
- -- False;
- -- else
- -- Float_Unsigned!(Float (Opnd)) /= 0
- -- end if;
- -- end if;
-
- Rewrite (N,
- Make_If_Expression (Loc,
- Expressions => New_List (
- Make_Op_Lt (Loc,
- Left_Opnd => Duplicate_Subexpr (Opnd),
- Right_Opnd => Make_Real_Literal (Loc, Ureal_0)),
-
- New_Occurrence_Of (Standard_True, Loc),
-
- Make_If_Expression (Loc,
- Expressions => New_List (
- Make_Op_Gt (Loc,
- Left_Opnd => Duplicate_Subexpr_No_Checks (Opnd),
- Right_Opnd => Make_Real_Literal (Loc, Ureal_0)),
-
- New_Occurrence_Of (Standard_False, Loc),
-
- Make_Op_Ne (Loc,
- Left_Opnd =>
- Unchecked_Convert_To
- (RTE (RE_Float_Unsigned),
- Convert_To
- (Standard_Float,
- Duplicate_Subexpr_No_Checks (Opnd))),
- Right_Opnd =>
- Make_Integer_Literal (Loc, 0)))))));
-
- Analyze_And_Resolve (N, Standard_Boolean);
- end Expand_Is_Negative;
-
------------------
-- Expand_Shift --
------------------
diff --git a/gcc/ada/exp_intr.ads b/gcc/ada/exp_intr.ads
index 9399ec7..5fae2c7 100644
--- a/gcc/ada/exp_intr.ads
+++ b/gcc/ada/exp_intr.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute 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 c90409b..88f86f4 100644
--- a/gcc/ada/exp_pakd.adb
+++ b/gcc/ada/exp_pakd.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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,33 +23,37 @@
-- --
------------------------------------------------------------------------------
-with Atree; use Atree;
-with Checks; use Checks;
-with Einfo; use Einfo;
-with Errout; use Errout;
-with Exp_Dbug; use Exp_Dbug;
-with Exp_Util; use Exp_Util;
-with Layout; use Layout;
-with Lib.Xref; use Lib.Xref;
-with Namet; use Namet;
-with Nlists; use Nlists;
-with Nmake; use Nmake;
-with Opt; use Opt;
-with Sem; use Sem;
-with Sem_Aux; use Sem_Aux;
-with Sem_Ch3; use Sem_Ch3;
-with Sem_Ch8; use Sem_Ch8;
-with Sem_Ch13; use Sem_Ch13;
-with Sem_Eval; use Sem_Eval;
-with Sem_Res; use Sem_Res;
-with Sem_Util; use Sem_Util;
-with Sinfo; use Sinfo;
-with Snames; use Snames;
-with Stand; use Stand;
-with Targparm; use Targparm;
-with Tbuild; use Tbuild;
-with Ttypes; use Ttypes;
-with Uintp; use Uintp;
+with Atree; use Atree;
+with Checks; use Checks;
+with Einfo; use Einfo;
+with Einfo.Entities; use Einfo.Entities;
+with Einfo.Utils; use Einfo.Utils;
+with Errout; use Errout;
+with Exp_Dbug; use Exp_Dbug;
+with Exp_Util; use Exp_Util;
+with Layout; use Layout;
+with Lib.Xref; use Lib.Xref;
+with Namet; use Namet;
+with Nlists; use Nlists;
+with Nmake; use Nmake;
+with Opt; use Opt;
+with Sem; use Sem;
+with Sem_Aux; use Sem_Aux;
+with Sem_Ch3; use Sem_Ch3;
+with Sem_Ch8; use Sem_Ch8;
+with Sem_Ch13; use Sem_Ch13;
+with Sem_Eval; use Sem_Eval;
+with Sem_Res; use Sem_Res;
+with Sem_Util; use Sem_Util;
+with Sinfo; use Sinfo;
+with Sinfo.Nodes; use Sinfo.Nodes;
+with Sinfo.Utils; use Sinfo.Utils;
+with Snames; use Snames;
+with Stand; use Stand;
+with Targparm; use Targparm;
+with Tbuild; use Tbuild;
+with Ttypes; use Ttypes;
+with Uintp; use Uintp;
package body Exp_Pakd is
@@ -559,11 +563,11 @@ package body Exp_Pakd is
-- Do not reset RM_Size if already set, as happens in the case of
-- a modular type.
- if Unknown_Esize (PAT) then
+ if not Known_Esize (PAT) then
Set_Esize (PAT, PASize);
end if;
- if Unknown_RM_Size (PAT) then
+ if not Known_RM_Size (PAT) then
Set_RM_Size (PAT, PASize);
end if;
@@ -609,7 +613,7 @@ package body Exp_Pakd is
-- type or component, take it into account.
if Csize <= 2 or else Csize = 4 or else Csize mod 2 /= 0
- or else Alignment (Typ) = 1
+ or else (Known_Alignment (Typ) and then Alignment (Typ) = 1)
or else Component_Alignment (Typ) = Calign_Storage_Unit
then
if Reverse_Storage_Order (Typ) then
@@ -619,7 +623,7 @@ package body Exp_Pakd is
end if;
elsif Csize mod 4 /= 0
- or else Alignment (Typ) = 2
+ or else (Known_Alignment (Typ) and then Alignment (Typ) = 2)
then
if Reverse_Storage_Order (Typ) then
PB_Type := RTE (RE_Rev_Packed_Bytes2);
@@ -824,8 +828,8 @@ package body Exp_Pakd is
elsif not Is_Constrained (Typ) then
- -- When generating standard DWARF (i.e when GNAT_Encodings is
- -- DWARF_GNAT_Encodings_Minimal), the ___XP suffix will be stripped
+ -- When generating standard DWARF (i.e when GNAT_Encodings is not
+ -- DWARF_GNAT_Encodings_All), the ___XP suffix will be stripped
-- by the back-end but generate it anyway to ease compiler debugging.
-- This will help to distinguish implementation types from original
-- packed arrays.
@@ -1909,9 +1913,10 @@ package body Exp_Pakd is
-- where PAT is the packed array type. This works fine, since in the
-- modular case we guarantee that the unused bits are always zeroes.
-- We do have to compare the lengths because we could be comparing
- -- two different subtypes of the same base type.
+ -- two different subtypes of the same base type. We can only do this
+ -- if the PATs on both sides are the same.
- if Is_Modular_Integer_Type (PAT) then
+ if Is_Modular_Integer_Type (PAT) and then PAT = Etype (R) then
Rewrite (N,
Make_And_Then (Loc,
Left_Opnd =>
diff --git a/gcc/ada/exp_pakd.ads b/gcc/ada/exp_pakd.ads
index 559f54a..8c34753 100644
--- a/gcc/ada/exp_pakd.ads
+++ b/gcc/ada/exp_pakd.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute 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_prag.adb b/gcc/ada/exp_prag.adb
index d616fb6..43ecdcd 100644
--- a/gcc/ada/exp_prag.adb
+++ b/gcc/ada/exp_prag.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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,38 +23,42 @@
-- --
------------------------------------------------------------------------------
-with Atree; use Atree;
-with Casing; use Casing;
-with Checks; use Checks;
-with Debug; use Debug;
-with Einfo; use Einfo;
-with Elists; use Elists;
-with Errout; use Errout;
-with Exp_Ch11; use Exp_Ch11;
-with Exp_Util; use Exp_Util;
-with Expander; use Expander;
-with Inline; use Inline;
-with Lib; use Lib;
-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 Rtsfind; use Rtsfind;
-with Sem; use Sem;
-with Sem_Aux; use Sem_Aux;
-with Sem_Ch8; use Sem_Ch8;
-with Sem_Prag; use Sem_Prag;
-with Sem_Util; use Sem_Util;
-with Sinfo; use Sinfo;
-with Sinput; use Sinput;
-with Snames; use Snames;
-with Stringt; use Stringt;
-with Stand; use Stand;
-with Tbuild; use Tbuild;
-with Uintp; use Uintp;
-with Validsw; use Validsw;
+with Atree; use Atree;
+with Casing; use Casing;
+with Checks; use Checks;
+with Debug; use Debug;
+with Einfo; use Einfo;
+with Einfo.Entities; use Einfo.Entities;
+with Einfo.Utils; use Einfo.Utils;
+with Elists; use Elists;
+with Errout; use Errout;
+with Exp_Ch11; use Exp_Ch11;
+with Exp_Util; use Exp_Util;
+with Expander; use Expander;
+with Inline; use Inline;
+with Lib; use Lib;
+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 Rtsfind; use Rtsfind;
+with Sem; use Sem;
+with Sem_Aux; use Sem_Aux;
+with Sem_Ch8; use Sem_Ch8;
+with Sem_Prag; use Sem_Prag;
+with Sem_Util; use Sem_Util;
+with Sinfo; use Sinfo;
+with Sinfo.Nodes; use Sinfo.Nodes;
+with Sinfo.Utils; use Sinfo.Utils;
+with Sinput; use Sinput;
+with Snames; use Snames;
+with Stringt; use Stringt;
+with Stand; use Stand;
+with Tbuild; use Tbuild;
+with Uintp; use Uintp;
+with Validsw; use Validsw;
package body Exp_Prag is
@@ -771,7 +775,7 @@ package body Exp_Prag is
function Get_Nth_Arg_Type
(Subprogram : Entity_Id;
N : Positive) return Entity_Id;
- -- Returns the type of the Nth argument of Subprogram.
+ -- Returns the type of the Nth argument of Subprogram
function To_Addresses (Elmts : Elist_Id) return List_Id;
-- Returns a new list containing each element of Elmts wrapped in an
@@ -821,9 +825,9 @@ package body Exp_Prag is
Init_Val : Node_Id) return Node_Id
is
-- Expressions for each component of the returned Dim3
- Dim_X : Node_Id;
- Dim_Y : Node_Id;
- Dim_Z : Node_Id;
+ Dim_X : Node_Id;
+ Dim_Y : Node_Id;
+ Dim_Z : Node_Id;
-- Type of CUDA.Internal.Dim3 - inferred from
-- RE_Push_Call_Configuration to avoid needing changes in GNAT when
@@ -835,12 +839,13 @@ package body Exp_Prag is
First_Component : Entity_Id := First_Entity (RTE (RE_Dim3));
Second_Component : Entity_Id := Next_Entity (First_Component);
Third_Component : Entity_Id := Next_Entity (Second_Component);
+
begin
- -- Sem_prag.adb ensured that Init_Val is either a Dim3, an
- -- aggregate of three Any_Integers or Any_Integer.
+ -- Sem_prag.adb ensured that Init_Val is either a Dim3, an aggregate
+ -- of three Any_Integers or Any_Integer.
- -- If Init_Val is a Dim3, use each of its components.
+ -- If Init_Val is a Dim3, use each of its components
if Etype (Init_Val) = RTE (RE_Dim3) then
Dim_X := Make_Selected_Component (Loc,
@@ -862,7 +867,7 @@ package body Exp_Prag is
Dim_Y := Next (Dim_X);
Dim_Z := Next (Dim_Y);
- -- Otherwise, we know it is an integer and the rest defaults to 1.
+ -- Otherwise, we know it is an integer and the rest defaults to 1
else
Dim_X := Init_Val;
@@ -1011,14 +1016,13 @@ package body Exp_Prag is
Default_Val => Make_Null (Loc));
end Build_Stream_Declaration;
- ------------------------
- -- Etype_Or_Dim3 --
- ------------------------
+ -------------------
+ -- Etype_Or_Dim3 --
+ -------------------
function Etype_Or_Dim3 (N : Node_Id) return Node_Id is
begin
- if Nkind (N) = N_Aggregate and then Is_Composite_Type (Etype (N))
- then
+ if Nkind (N) = N_Aggregate and then Is_Composite_Type (Etype (N)) then
return New_Occurrence_Of (RTE (RE_Dim3), Sloc (N));
end if;
@@ -1036,7 +1040,7 @@ package body Exp_Prag is
Argument : Entity_Id := First_Entity (Subprogram);
begin
for J in 2 .. N loop
- Argument := Next_Entity (Argument);
+ Next_Entity (Argument);
end loop;
return Etype (Argument);
@@ -1098,8 +1102,7 @@ package body Exp_Prag is
Object_Definition => Etype_Or_Dim3 (Block_Dimensions),
Expression => Block_Dimensions);
- -- List holding the entities of the copies of Procedure_Call's
- -- arguments.
+ -- List holding the entities of the copies of Procedure_Call's arguments
Kernel_Arg_Copies : constant Elist_Id := New_Elmt_List;
@@ -1114,7 +1117,7 @@ package body Exp_Prag is
Pop_Call : Node_Id;
Push_Call : Node_Id;
- -- Declaration of all temporaries required for CUDA API Calls.
+ -- Declaration of all temporaries required for CUDA API Calls
Blk_Decls : constant List_Id := New_List;
@@ -1567,7 +1570,7 @@ package body Exp_Prag is
-- effects). Assign prefix value to temp on Eval_Statement
-- list, so assignment will be executed conditionally.
- Set_Ekind (Temp, E_Variable);
+ Mutate_Ekind (Temp, E_Variable);
Set_Suppress_Initialization (Temp);
Analyze (Decl);
@@ -2036,7 +2039,7 @@ package body Exp_Prag is
Expression => Relocate_Node (Rtti_Name))))));
Rewrite (Expression (Foreign_Data),
- Unchecked_Convert_To (Standard_A_Char,
+ OK_Convert_To (Standard_Address,
Make_Attribute_Reference (Loc,
Prefix => Make_Identifier (Loc, Chars (Dum)),
Attribute_Name => Name_Address)));
@@ -2269,7 +2272,7 @@ package body Exp_Prag is
Make_Defining_Identifier (Loc,
Chars => New_External_Name (Chars (Pack_Id), "Initial_Condition"));
- Set_Ekind (Proc_Id, E_Procedure);
+ Mutate_Ekind (Proc_Id, E_Procedure);
Set_Is_Initial_Condition_Procedure (Proc_Id);
-- Generate:
@@ -2358,6 +2361,7 @@ package body Exp_Prag is
S : Entity_Id;
E : Entity_Id;
+ Remove_Inspection_Point : Boolean := False;
begin
if No (Pragma_Argument_Associations (N)) then
A := New_List;
@@ -2369,10 +2373,9 @@ package body Exp_Prag is
if Comes_From_Source (E)
and then Is_Object (E)
and then not Is_Entry_Formal (E)
+ and then not Is_Formal_Object (E)
and then Ekind (E) /= E_Component
and then Ekind (E) /= E_Discriminant
- and then Ekind (E) /= E_Generic_In_Parameter
- and then Ekind (E) /= E_Generic_In_Out_Parameter
then
Append_To (A,
Make_Pragma_Argument_Association (Loc,
@@ -2398,6 +2401,36 @@ package body Exp_Prag is
Expand (Expression (Assoc));
Next (Assoc);
end loop;
+
+ -- If any of the references have a freeze node, it must appear before
+ -- pragma Inspection_Point, otherwise the entity won't be available when
+ -- Gigi processes Inspection_Point.
+ -- When this requirement isn't met, turn the pragma into a no-op.
+
+ Assoc := First (Pragma_Argument_Associations (N));
+ while Present (Assoc) loop
+
+ if Present (Freeze_Node (Entity (Expression (Assoc)))) and then
+ not Is_Frozen (Entity (Expression (Assoc)))
+ then
+ Error_Msg_NE ("??inspection point references unfrozen object &",
+ Assoc,
+ Entity (Expression (Assoc)));
+ Remove_Inspection_Point := True;
+ end if;
+
+ Next (Assoc);
+ end loop;
+
+ if Remove_Inspection_Point then
+ Error_Msg_N ("\pragma will be ignored", N);
+
+ -- We can't just remove the pragma from the tree as it might be
+ -- iterated over by the caller. Turn it into a null statement
+ -- instead.
+
+ Rewrite (N, Make_Null_Statement (Sloc (N)));
+ end if;
end Expand_Pragma_Inspection_Point;
--------------------------------------
@@ -3141,7 +3174,7 @@ package body Exp_Prag is
begin
-- When applied to a variable, the default initialization must not be
-- done. As it is already done when the pragma is found, we just get rid
- -- of the call the initialization procedure which followed the object
+ -- of the call to the initialization procedure which followed the object
-- declaration. The call is inserted after the declaration, but validity
-- checks may also have been inserted and thus the initialization call
-- does not necessarily appear immediately after the object declaration.
diff --git a/gcc/ada/exp_prag.ads b/gcc/ada/exp_prag.ads
index 59f0d6a..a418192 100644
--- a/gcc/ada/exp_prag.ads
+++ b/gcc/ada/exp_prag.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute 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
index 3fae317..90a542d 100644
--- a/gcc/ada/exp_put_image.adb
+++ b/gcc/ada/exp_put_image.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2020-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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,31 +23,34 @@
-- --
------------------------------------------------------------------------------
-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 Aspects; use Aspects;
+with Atree; use Atree;
+with Csets; use Csets;
+with Einfo; use Einfo;
+with Einfo.Entities; use Einfo.Entities;
+with Einfo.Utils; use Einfo.Utils;
+with Exp_Tss; use Exp_Tss;
+with Exp_Util; use Exp_Util;
+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 Sinfo.Nodes; use Sinfo.Nodes;
+with Sinfo.Utils; use Sinfo.Utils;
+with Snames; use Snames;
with Stand;
-with Tbuild; use Tbuild;
-with Ttypes; use Ttypes;
-with Uintp; use Uintp;
+with Stringt; use Stringt;
+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 --
-----------------------
@@ -335,7 +338,7 @@ package body Exp_Put_Image is
-- For other elementary types, generate:
--
- -- Put_Wide_Wide_String (Sink, U_Type'Wide_Wide_Image (Item));
+ -- Wide_Wide_Put (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
@@ -362,7 +365,7 @@ package body Exp_Put_Image is
Put_Call : constant Node_Id :=
Make_Procedure_Call_Statement (Loc,
Name =>
- New_Occurrence_Of (RTE (RE_Put_Wide_Wide_String), Loc),
+ New_Occurrence_Of (RTE (RE_Wide_Wide_Put), Loc),
Parameter_Associations => New_List
(Relocate_Node (Sink), Image));
begin
@@ -525,6 +528,7 @@ package body Exp_Put_Image is
Pnam : out Entity_Id)
is
Btyp : constant Entity_Id := Base_Type (Typ);
+ pragma Assert (not Is_Class_Wide_Type (Btyp));
pragma Assert (not Is_Unchecked_Union (Btyp));
First_Time : Boolean := True;
@@ -645,32 +649,90 @@ package body Exp_Put_Image is
-- 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.
+ -- recursively.
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))));
+ if Chars (Defining_Identifier (Item)) = Name_uParent then
+ declare
+ Parent_Type : constant Entity_Id :=
+ Implementation_Base_Type
+ (Etype (Defining_Identifier (Item)));
+
+ Parent_Aspect_Spec : constant Node_Id :=
+ Find_Aspect (Parent_Type, Aspect_Put_Image);
+
+ Parent_Type_Decl : constant Node_Id :=
+ Declaration_Node (Parent_Type);
+
+ Parent_Rdef : Node_Id :=
+ Type_Definition (Parent_Type_Decl);
+ begin
+ -- If parent type has an noninherited
+ -- explicitly-specified Put_Image aspect spec, then
+ -- display parent part by calling specified procedure,
+ -- and then use extension-aggregate syntax for the
+ -- remaining components as per RM 4.10(15/5);
+ -- otherwise, "look through" the parent component
+ -- to its components - we don't want the image text
+ -- to include mention of an "_parent" component.
+
+ if Present (Parent_Aspect_Spec) and then
+ Entity (Parent_Aspect_Spec) = Parent_Type
+ then
+ Append_Component_Attr
+ (Result, Defining_Identifier (Item));
+
+ -- Omit the " with " if no subsequent components.
+
+ if not Is_Null_Extension_Of
+ (Descendant => Typ,
+ Ancestor => Parent_Type)
+ then
+ Append_To (Result,
+ 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, " with "))));
+ end if;
+ else
+ if Nkind (Parent_Rdef) = N_Derived_Type_Definition
+ then
+ Parent_Rdef :=
+ Record_Extension_Part (Parent_Rdef);
+ end if;
+
+ if Present (Component_List (Parent_Rdef)) then
+ Append_List_To (Result,
+ Make_Component_List_Attributes
+ (Component_List (Parent_Rdef)));
+ end if;
+ end if;
+ end;
+
+ elsif 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;
-
- Append_To (Result, Make_Component_Name (Item));
- Append_Component_Attr (Result, Defining_Identifier (Item));
end if;
Next (Item);
@@ -686,13 +748,35 @@ package body Exp_Put_Image is
function Make_Component_Name (C : Entity_Id) return Node_Id is
Name : constant Name_Id := Chars (Defining_Identifier (C));
+ pragma Assert (Name /= Name_uParent);
+
+ function To_Upper (S : String) return String;
+ -- Same as Ada.Characters.Handling.To_Upper, but withing
+ -- Ada.Characters.Handling seems to cause mailserver problems.
+
+ --------------
+ -- To_Upper --
+ --------------
+
+ function To_Upper (S : String) return String is
+ begin
+ return Result : String := S do
+ for Char of Result loop
+ Char := Fold_Upper (Char);
+ end loop;
+ end return;
+ end To_Upper;
+
+ -- Start of processing for Make_Component_Name
+
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) & " => ")));
+ Make_String_Literal (Loc,
+ To_Upper (Get_Name_String (Name)) & " => ")));
end Make_Component_Name;
Stms : constant List_Id := New_List;
@@ -703,38 +787,71 @@ package body Exp_Put_Image is
-- 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))));
+ if (Ada_Version < Ada_2022)
+ or else not Enable_Put_Image (Btyp)
+ then
+ -- generate a very simple Put_Image implementation
- -- Generate Put_Images for the discriminants of the type
+ if Is_RTE (Typ, RE_Root_Buffer_Type) then
+ -- Avoid introducing a cyclic dependency between
+ -- Ada.Strings.Text_Buffers and System.Put_Images.
- Append_List_To (Stms,
- Make_Component_Attributes (Discriminant_Specifications (Type_Decl)));
+ Append_To (Stms,
+ Make_Raise_Program_Error (Loc,
+ Reason => PE_Explicit_Raise));
+ else
+ Append_To (Stms,
+ Make_Procedure_Call_Statement (Loc,
+ Name => New_Occurrence_Of (RTE (RE_Put_Image_Unknown), Loc),
+ Parameter_Associations => New_List
+ (Make_Identifier (Loc, Name_S),
+ Make_String_Literal (Loc,
+ To_String (Fully_Qualified_Name_String (Btyp))))));
+ end if;
+ elsif Is_Null_Record_Type (Btyp, Ignore_Privacy => True) then
- Rdef := Type_Definition (Type_Decl);
+ -- Interface types take this path.
- -- 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.
+ Append_To (Stms,
+ 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, "(NULL RECORD)"))));
+ else
+ 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))));
- if Nkind (Rdef) = N_Derived_Type_Definition then
- Rdef := Record_Extension_Part (Rdef);
- end if;
+ -- Generate Put_Images for the discriminants of the type
- if Present (Component_List (Rdef)) then
Append_List_To (Stms,
- Make_Component_List_Attributes (Component_List (Rdef)));
- end if;
+ Make_Component_Attributes
+ (Discriminant_Specifications (Type_Decl)));
- 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))));
+ Rdef := Type_Definition (Type_Decl);
+
+ -- In the record extension case, the components we want are to be
+ -- found in the extension (although we have to process the
+ -- _Parent component to find inherited components).
+
+ 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))));
+ end if;
Pnam := Make_Put_Image_Name (Loc, Btyp);
Build_Put_Image_Proc (Loc, Btyp, Decl, Pnam, Stms);
@@ -754,7 +871,8 @@ package body Exp_Put_Image is
In_Present => True,
Out_Present => True,
Parameter_Type =>
- New_Occurrence_Of (Class_Wide_Type (RTE (RE_Sink)), Loc)),
+ New_Occurrence_Of
+ (Class_Wide_Type (RTE (RE_Root_Buffer_Type)), Loc)),
Make_Parameter_Specification (Loc,
Defining_Identifier => Make_Defining_Identifier (Loc, Name_V),
@@ -812,38 +930,29 @@ package body Exp_Put_Image is
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:
+ -- If this function returns False for a non-scalar type Typ, then
+ -- a) calls to Typ'Image will result in calls to
+ -- System.Put_Images.Put_Image_Unknown to generate the image.
+ -- b) If Typ is a tagged type, then similarly the implementation
+ -- of Typ's Put_Image procedure will call Put_Image_Unknown
+ -- and will ignore its formal parameter of type Typ.
+ -- Note that Typ will still have a Put_Image procedure
+ -- in this case, albeit one with a simplified implementation.
--
- -- 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:
+ -- The name "Sink" here is a short nickname for
+ -- "Ada.Strings.Text_Buffers.Root_Buffer_Type".
--
-- 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_Remote_Call_Interface (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.
@@ -854,13 +963,13 @@ package body Exp_Put_Image is
-- 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
+ if No_Run_Time_Mode or else not RTE_Available (RE_Root_Buffer_Type) 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
+ -- ???Disable Put_Image on type Root_Buffer_Type declared in
+ -- Ada.Strings.Text_Buffers. Note that we can't call Is_RTU on
+ -- Ada_Strings_Text_Buffers, because it's not known yet (we might be
-- compiling it). But this is insufficient to allow support for tagged
-- predefined types.
@@ -869,7 +978,7 @@ package body Exp_Put_Image is
begin
if Present (Parent_Scope)
and then Is_RTU (Parent_Scope, Ada_Strings)
- and then Chars (Scope (Typ)) = Name_Find ("text_output")
+ and then Chars (Scope (Typ)) = Name_Find ("text_buffers")
then
return False;
end if;
@@ -896,9 +1005,9 @@ package body Exp_Put_Image is
return True;
end Enable_Put_Image;
- ---------------------------------
+ -------------------------
-- Make_Put_Image_Name --
- ---------------------------------
+ -------------------------
function Make_Put_Image_Name
(Loc : Source_Ptr; Typ : Entity_Id) return Entity_Id
@@ -919,15 +1028,19 @@ package body Exp_Put_Image is
return Make_Defining_Identifier (Loc, Sname);
end Make_Put_Image_Name;
+ ---------------------------------
+ -- Image_Should_Call_Put_Image --
+ ---------------------------------
+
function Image_Should_Call_Put_Image (N : Node_Id) return Boolean is
begin
- if Ada_Version < Ada_2020 then
+ if Ada_Version < Ada_2022 then
return False;
end if;
- -- In Ada 2020, T'Image calls T'Put_Image if there is an explicit
+ -- In Ada 2022, 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.
+ -- in pre-2022 versions of Ada.
declare
U_Type : constant Entity_Id := Underlying_Type (Entity (Prefix (N)));
@@ -940,11 +1053,15 @@ package body Exp_Put_Image is
end;
end Image_Should_Call_Put_Image;
+ ----------------------
+ -- Build_Image_Call --
+ ----------------------
+
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;
+ -- S : Buffer;
-- U_Type'Put_Image (S, X);
-- Result : constant String := Get (S);
-- Destroy (S);
@@ -960,18 +1077,18 @@ package body Exp_Put_Image is
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));
+ New_Occurrence_Of (RTE (RE_Buffer_Type), Loc));
+
+ Image_Prefix : constant Node_Id :=
+ Duplicate_Subexpr (First (Expressions (N)));
+
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)))));
+ Image_Prefix));
Result_Entity : constant Entity_Id :=
Make_Defining_Identifier (Loc, Chars => New_Internal_Name ('R'));
Result_Decl : constant Node_Id :=
@@ -984,23 +1101,98 @@ package body Exp_Put_Image is
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));
+ Actions : List_Id;
+
+ function Put_String_Exp (String_Exp : Node_Id;
+ Wide_Wide : Boolean := False) return Node_Id;
+ -- Generate a call to evaluate a String (or Wide_Wide_String, depending
+ -- on the Wide_Wide Boolean parameter) expression and output it into
+ -- the buffer.
+
+ --------------------
+ -- Put_String_Exp --
+ --------------------
+
+ function Put_String_Exp (String_Exp : Node_Id;
+ Wide_Wide : Boolean := False) return Node_Id is
+ Put_Id : constant RE_Id :=
+ (if Wide_Wide then RE_Wide_Wide_Put else RE_Put_UTF_8);
+
+ -- We could build a nondispatching call here, but to make
+ -- that work we'd have to change Rtsfind spec to make available
+ -- corresponding callees out of Ada.Strings.Text_Buffers.Unbounded
+ -- (as opposed to from Ada.Strings.Text_Buffers). Seems simpler to
+ -- introduce a type conversion and leave it to the optimizer to
+ -- eliminate the dispatching. This does not *introduce* any problems
+ -- if a no-dispatching-allowed restriction is in effect, since we
+ -- are already in the middle of generating a call to T'Class'Image.
+
+ Sink_Exp : constant Node_Id :=
+ Make_Type_Conversion (Loc,
+ Subtype_Mark =>
+ New_Occurrence_Of
+ (Class_Wide_Type (RTE (RE_Root_Buffer_Type)), Loc),
+ Expression => New_Occurrence_Of (Sink_Entity, Loc));
+ begin
+ return
+ Make_Procedure_Call_Statement (Loc,
+ Name => New_Occurrence_Of (RTE (Put_Id), Loc),
+ Parameter_Associations => New_List (Sink_Exp, String_Exp));
+ end Put_String_Exp;
+
+ -- Start of processing for Build_Image_Call
+
begin
- return Image;
+ if Is_Class_Wide_Type (U_Type) then
+ -- Generate qualified-expression syntax; qualification name comes
+ -- from calling Ada.Tags.Wide_Wide_Expanded_Name.
+
+ declare
+ -- The copy of Image_Prefix will be evaluated before the
+ -- original, which is ok if no side effects are involved.
+
+ pragma Assert (Side_Effect_Free (Image_Prefix));
+
+ Specific_Type_Name : constant Node_Id :=
+ Put_String_Exp
+ (Make_Function_Call (Loc,
+ Name => New_Occurrence_Of
+ (RTE (RE_Wide_Wide_Expanded_Name), Loc),
+ Parameter_Associations => New_List (
+ Make_Attribute_Reference (Loc,
+ Prefix => Duplicate_Subexpr (Image_Prefix),
+ Attribute_Name => Name_Tag))),
+ Wide_Wide => True);
+
+ Qualification : constant Node_Id :=
+ Put_String_Exp (Make_String_Literal (Loc, "'"));
+ begin
+ Actions := New_List
+ (Sink_Decl,
+ Specific_Type_Name,
+ Qualification,
+ Put_Im,
+ Result_Decl);
+ end;
+ else
+ Actions := New_List (Sink_Decl, Put_Im, Result_Decl);
+ end if;
+
+ return Make_Expression_With_Actions (Loc,
+ Actions => Actions,
+ Expression => New_Occurrence_Of (Result_Entity, Loc));
end Build_Image_Call;
- ------------------
- -- Preload_Sink --
- ------------------
+ ------------------------------
+ -- Preload_Root_Buffer_Type --
+ ------------------------------
- procedure Preload_Sink (Compilation_Unit : Node_Id) is
+ procedure Preload_Root_Buffer_Type (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.
+ -- We can't call RTE (RE_Root_Buffer_Type) for at least some
+ -- predefined units, because it would introduce cyclic dependences.
+ -- The package where Root_Buffer_Type 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
@@ -1009,25 +1201,25 @@ package body Exp_Put_Image is
-- 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.
+ -- declarations. This mechanism also prevents doing
+ -- RTE (RE_Root_Buffer_Type) when compiling the compiler itself.
+ -- Packages Ada.Strings.Buffer_Types and friends are not included
+ -- in the compiler.
--
- -- Don't do it if type Sink is unavailable in the runtime.
+ -- Don't do it if type Root_Buffer_Type 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)
+ and then RTE_Available (RE_Root_Buffer_Type)
then
declare
- Ignore : constant Entity_Id := RTE (RE_Sink);
+ Ignore : constant Entity_Id := RTE (RE_Root_Buffer_Type);
begin
null;
end;
end if;
- end Preload_Sink;
+ end Preload_Root_Buffer_Type;
-------------------------
-- Put_Image_Base_Type --
diff --git a/gcc/ada/exp_put_image.ads b/gcc/ada/exp_put_image.ads
index 00b3371..4f049f1 100644
--- a/gcc/ada/exp_put_image.ads
+++ b/gcc/ada/exp_put_image.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2020-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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,8 +27,9 @@ 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.
+ -- Routines to build Put_Image calls. See Ada.Strings.Text_Buffers.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
@@ -94,10 +95,10 @@ package Exp_Put_Image is
-- 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
+ procedure Preload_Root_Buffer_Type (Compilation_Unit : Node_Id);
+ -- Call RTE (RE_Root_Buffer_Type) 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 ccf62c6..7140015 100644
--- a/gcc/ada/exp_sel.adb
+++ b/gcc/ada/exp_sel.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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,15 +23,17 @@
-- --
------------------------------------------------------------------------------
-with Einfo; use Einfo;
-with Nlists; use Nlists;
-with Nmake; use Nmake;
-with Opt; use Opt;
-with Rtsfind; use Rtsfind;
-with Sinfo; use Sinfo;
-with Snames; use Snames;
-with Stand; use Stand;
-with Tbuild; use Tbuild;
+with Einfo; use Einfo;
+with Einfo.Entities; use Einfo.Entities;
+with Nlists; use Nlists;
+with Nmake; use Nmake;
+with Opt; use Opt;
+with Rtsfind; use Rtsfind;
+with Sinfo; use Sinfo;
+with Sinfo.Nodes; use Sinfo.Nodes;
+with Snames; use Snames;
+with Stand; use Stand;
+with Tbuild; use Tbuild;
package body Exp_Sel is
diff --git a/gcc/ada/exp_sel.ads b/gcc/ada/exp_sel.ads
index f2f2c56..69c2efa 100644
--- a/gcc/ada/exp_sel.ads
+++ b/gcc/ada/exp_sel.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute 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 fa4aeb6..45db487 100644
--- a/gcc/ada/exp_smem.adb
+++ b/gcc/ada/exp_smem.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1998-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1998-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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,25 +23,29 @@
-- --
------------------------------------------------------------------------------
-with Atree; use Atree;
-with Einfo; use Einfo;
-with Elists; use Elists;
-with Exp_Ch7; use Exp_Ch7;
-with Exp_Ch9; use Exp_Ch9;
-with Exp_Tss; use Exp_Tss;
-with Exp_Util; use Exp_Util;
-with Nmake; use Nmake;
-with Namet; use Namet;
-with Nlists; use Nlists;
-with Rtsfind; use Rtsfind;
-with Sem; use Sem;
-with Sem_Aux; use Sem_Aux;
-with Sem_Util; use Sem_Util;
-with Sinfo; use Sinfo;
-with Snames; use Snames;
-with Stand; use Stand;
-with Stringt; use Stringt;
-with Tbuild; use Tbuild;
+with Atree; use Atree;
+with Einfo; use Einfo;
+with Einfo.Entities; use Einfo.Entities;
+with Einfo.Utils; use Einfo.Utils;
+with Elists; use Elists;
+with Exp_Ch7; use Exp_Ch7;
+with Exp_Ch9; use Exp_Ch9;
+with Exp_Tss; use Exp_Tss;
+with Exp_Util; use Exp_Util;
+with Nmake; use Nmake;
+with Namet; use Namet;
+with Nlists; use Nlists;
+with Rtsfind; use Rtsfind;
+with Sem; use Sem;
+with Sem_Aux; use Sem_Aux;
+with Sem_Util; use Sem_Util;
+with Sinfo; use Sinfo;
+with Sinfo.Nodes; use Sinfo.Nodes;
+with Sinfo.Utils; use Sinfo.Utils;
+with Snames; use Snames;
+with Stand; use Stand;
+with Stringt; use Stringt;
+with Tbuild; use Tbuild;
package body Exp_Smem is
diff --git a/gcc/ada/exp_smem.ads b/gcc/ada/exp_smem.ads
index 26ea6da..68eb58e 100644
--- a/gcc/ada/exp_smem.ads
+++ b/gcc/ada/exp_smem.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1998-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1998-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute 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 d65136b..bbfee62 100644
--- a/gcc/ada/exp_spark.adb
+++ b/gcc/ada/exp_spark.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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,28 +23,32 @@
-- --
------------------------------------------------------------------------------
-with Atree; use Atree;
-with Checks; use Checks;
-with Einfo; use Einfo;
+with Atree; use Atree;
+with Checks; use Checks;
+with Einfo; use Einfo;
+with Einfo.Entities; use Einfo.Entities;
+with Einfo.Utils; use Einfo.Utils;
with Exp_Attr;
with Exp_Ch4;
-with Exp_Ch5; use Exp_Ch5;
-with Exp_Dbug; use Exp_Dbug;
-with Exp_Util; use Exp_Util;
-with Namet; use Namet;
-with Nlists; use Nlists;
-with Nmake; use Nmake;
-with Rtsfind; use Rtsfind;
-with Sem; use Sem;
-with Sem_Ch8; use Sem_Ch8;
-with Sem_Prag; use Sem_Prag;
-with Sem_Res; use Sem_Res;
-with Sem_Util; use Sem_Util;
-with Sinfo; use Sinfo;
-with Snames; use Snames;
-with Stand; use Stand;
-with Tbuild; use Tbuild;
-with Uintp; use Uintp;
+with Exp_Ch5; use Exp_Ch5;
+with Exp_Dbug; use Exp_Dbug;
+with Exp_Util; use Exp_Util;
+with Namet; use Namet;
+with Nlists; use Nlists;
+with Nmake; use Nmake;
+with Rtsfind; use Rtsfind;
+with Sem; use Sem;
+with Sem_Ch8; use Sem_Ch8;
+with Sem_Prag; use Sem_Prag;
+with Sem_Res; use Sem_Res;
+with Sem_Util; use Sem_Util;
+with Sinfo; use Sinfo;
+with Sinfo.Nodes; use Sinfo.Nodes;
+with Sinfo.Utils; use Sinfo.Utils;
+with Snames; use Snames;
+with Stand; use Stand;
+with Tbuild; use Tbuild;
+with Uintp; use Uintp;
package body Exp_SPARK is
diff --git a/gcc/ada/exp_spark.ads b/gcc/ada/exp_spark.ads
index 67fa043..d7d8f77 100644
--- a/gcc/ada/exp_spark.ads
+++ b/gcc/ada/exp_spark.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2011-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2011-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute 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 09bd872..c87b881 100644
--- a/gcc/ada/exp_strm.adb
+++ b/gcc/ada/exp_strm.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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,22 +23,26 @@
-- --
------------------------------------------------------------------------------
-with Atree; use Atree;
-with Einfo; use Einfo;
-with Elists; use Elists;
-with Exp_Util; use Exp_Util;
-with Namet; use Namet;
-with Nlists; use Nlists;
-with Nmake; use Nmake;
-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; use Stand;
-with Tbuild; use Tbuild;
-with Ttypes; use Ttypes;
-with Uintp; use Uintp;
+with Atree; use Atree;
+with Einfo; use Einfo;
+with Einfo.Entities; use Einfo.Entities;
+with Einfo.Utils; use Einfo.Utils;
+with Elists; use Elists;
+with Exp_Util; use Exp_Util;
+with Namet; use Namet;
+with Nlists; use Nlists;
+with Nmake; use Nmake;
+with Rtsfind; use Rtsfind;
+with Sem_Aux; use Sem_Aux;
+with Sem_Util; use Sem_Util;
+with Sinfo; use Sinfo;
+with Sinfo.Nodes; use Sinfo.Nodes;
+with Sinfo.Utils; use Sinfo.Utils;
+with Snames; use Snames;
+with Stand; use Stand;
+with Tbuild; use Tbuild;
+with Ttypes; use Ttypes;
+with Uintp; use Uintp;
package body Exp_Strm is
diff --git a/gcc/ada/exp_strm.ads b/gcc/ada/exp_strm.ads
index d77d756..7243f08 100644
--- a/gcc/ada/exp_strm.ads
+++ b/gcc/ada/exp_strm.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute 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_tss.adb b/gcc/ada/exp_tss.adb
index c5f167a..6bb41de 100644
--- a/gcc/ada/exp_tss.adb
+++ b/gcc/ada/exp_tss.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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,18 +23,21 @@
-- --
------------------------------------------------------------------------------
-with Atree; use Atree;
-with Einfo; use Einfo;
-with Elists; use Elists;
-with Exp_Util; use Exp_Util;
-with Nlists; use Nlists;
-with Lib; use Lib;
-with Restrict; use Restrict;
-with Rident; use Rident;
-with Sem_Aux; use Sem_Aux;
-with Sem_Ch6; use Sem_Ch6;
-with Sem_Util; use Sem_Util;
-with Sinfo; use Sinfo;
+with Atree; use Atree;
+with Einfo; use Einfo;
+with Einfo.Entities; use Einfo.Entities;
+with Einfo.Utils; use Einfo.Utils;
+with Elists; use Elists;
+with Exp_Util; use Exp_Util;
+with Nlists; use Nlists;
+with Lib; use Lib;
+with Restrict; use Restrict;
+with Rident; use Rident;
+with Sem_Aux; use Sem_Aux;
+with Sem_Ch6; use Sem_Ch6;
+with Sem_Util; use Sem_Util;
+with Sinfo; use Sinfo;
+with Sinfo.Nodes; use Sinfo.Nodes;
package body Exp_Tss is
diff --git a/gcc/ada/exp_tss.ads b/gcc/ada/exp_tss.ads
index ca35f5a..060f33e 100644
--- a/gcc/ada/exp_tss.ads
+++ b/gcc/ada/exp_tss.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute 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_unst.adb b/gcc/ada/exp_unst.adb
index ee2cf81..c071a9c 100644
--- a/gcc/ada/exp_unst.adb
+++ b/gcc/ada/exp_unst.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2014-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2014-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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,30 +23,34 @@
-- --
------------------------------------------------------------------------------
-with Atree; use Atree;
-with Debug; use Debug;
-with Einfo; use Einfo;
-with Elists; use Elists;
-with Exp_Util; use Exp_Util;
-with Lib; use Lib;
-with Namet; use Namet;
-with Nlists; use Nlists;
-with Nmake; use Nmake;
+with Atree; use Atree;
+with Debug; use Debug;
+with Einfo; use Einfo;
+with Einfo.Entities; use Einfo.Entities;
+with Einfo.Utils; use Einfo.Utils;
+with Elists; use Elists;
+with Exp_Util; use Exp_Util;
+with Lib; use Lib;
+with Namet; use Namet;
+with Nlists; use Nlists;
+with Nmake; use Nmake;
with Opt;
-with Output; use Output;
-with Rtsfind; use Rtsfind;
-with Sem; use Sem;
-with Sem_Aux; use Sem_Aux;
-with Sem_Ch8; use Sem_Ch8;
-with Sem_Mech; use Sem_Mech;
-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 Tbuild; use Tbuild;
-with Uintp; use Uintp;
+with Output; use Output;
+with Rtsfind; use Rtsfind;
+with Sem; use Sem;
+with Sem_Aux; use Sem_Aux;
+with Sem_Ch8; use Sem_Ch8;
+with Sem_Mech; use Sem_Mech;
+with Sem_Res; use Sem_Res;
+with Sem_Util; use Sem_Util;
+with Sinfo; use Sinfo;
+with Sinfo.Nodes; use Sinfo.Nodes;
+with Sinfo.Utils; use Sinfo.Utils;
+with Sinput; use Sinput;
+with Snames; use Snames;
+with Stand; use Stand;
+with Tbuild; use Tbuild;
+with Uintp; use Uintp;
package body Exp_Unst is
@@ -187,7 +191,7 @@ package body Exp_Unst is
begin
Typ := Make_Temporary (Loc, 'S');
- Set_Ekind (Typ, E_General_Access_Type);
+ Mutate_Ekind (Typ, E_General_Access_Type);
Set_Etype (Typ, Typ);
Set_Scope (Typ, Scop);
Set_Directly_Designated_Type (Typ, Etype (E));
@@ -527,14 +531,17 @@ package body Exp_Unst is
-- Entity name case. Make sure that the entity is declared
-- in a subprogram. This may not be the case for a type in a
-- loop appearing in a precondition.
- -- Exclude explicitly discriminants (that can appear
- -- in bounds of discriminated components).
+ -- Exclude explicitly discriminants (that can appear
+ -- in bounds of discriminated components) and enumeration
+ -- literals.
if Is_Entity_Name (N) then
if Present (Entity (N))
and then not Is_Type (Entity (N))
and then Present (Enclosing_Subprogram (Entity (N)))
- and then Ekind (Entity (N)) /= E_Discriminant
+ and then
+ Ekind (Entity (N))
+ not in E_Discriminant | E_Enumeration_Literal
then
Note_Uplevel_Ref
(E => Entity (N),
@@ -876,9 +883,10 @@ package body Exp_Unst is
-- within Subp. Calls to Subp itself or to subprograms
-- outside the nested structure do not affect us.
- if Scope_Within (Ent, Subp)
- and then Is_Subprogram (Ent)
+ if Is_Subprogram (Ent)
+ and then not Is_Generic_Subprogram (Ent)
and then not Is_Imported (Ent)
+ and then Scope_Within (Ultimate_Alias (Ent), Subp)
then
Append_Unique_Call ((N, Current_Subprogram, Ent));
end if;
@@ -1558,7 +1566,7 @@ package body Exp_Unst is
-- A subprogram instantiation does not have an explicit
-- body. If unused, we could remove the corresponding
- -- wrapper package and its body (TBD).
+ -- wrapper package and its body.
if Present (STJ.Bod) then
Spec := Corresponding_Spec (STJ.Bod);
@@ -1785,7 +1793,7 @@ package body Exp_Unst is
-- Decorate the new formal entity
Set_Scope (Form, STJ.Ent);
- Set_Ekind (Form, E_In_Parameter);
+ Mutate_Ekind (Form, E_In_Parameter);
Set_Etype (Form, STJE.ARECnPT);
Set_Mechanism (Form, By_Copy);
Set_Never_Set_In_Source (Form, True);
diff --git a/gcc/ada/exp_unst.ads b/gcc/ada/exp_unst.ads
index c7cc6cb..9355380 100644
--- a/gcc/ada/exp_unst.ads
+++ b/gcc/ada/exp_unst.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2014-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2014-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute 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 cf4059a..2584041 100644
--- a/gcc/ada/exp_util.adb
+++ b/gcc/ada/exp_util.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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,46 +23,50 @@
-- --
------------------------------------------------------------------------------
-with Aspects; use Aspects;
-with Atree; use Atree;
-with Casing; use Casing;
-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;
-with Exp_Ch11; use Exp_Ch11;
-with Ghost; use Ghost;
-with Inline; use Inline;
-with Itypes; use Itypes;
-with Lib; use Lib;
-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_Ch3; use Sem_Ch3;
-with Sem_Ch6; use Sem_Ch6;
-with Sem_Ch8; use Sem_Ch8;
-with Sem_Ch12; use Sem_Ch12;
-with Sem_Ch13; use Sem_Ch13;
-with Sem_Disp; use Sem_Disp;
-with Sem_Elab; use Sem_Elab;
-with Sem_Eval; use Sem_Eval;
-with Sem_Res; use Sem_Res;
-with Sem_Type; use Sem_Type;
-with Sem_Util; use Sem_Util;
-with Snames; use Snames;
-with Stand; use Stand;
-with Stringt; use Stringt;
-with Tbuild; use Tbuild;
-with Ttypes; use Ttypes;
-with Validsw; use Validsw;
+with Aspects; use Aspects;
+with Atree; use Atree;
+with Casing; use Casing;
+with Checks; use Checks;
+with Debug; use Debug;
+with Einfo; use Einfo;
+with Einfo.Entities; use Einfo.Entities;
+with Einfo.Utils; use Einfo.Utils;
+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;
+with Exp_Ch11; use Exp_Ch11;
+with Freeze; use Freeze;
+with Ghost; use Ghost;
+with Inline; use Inline;
+with Itypes; use Itypes;
+with Lib; use Lib;
+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_Ch3; use Sem_Ch3;
+with Sem_Ch6; use Sem_Ch6;
+with Sem_Ch8; use Sem_Ch8;
+with Sem_Ch12; use Sem_Ch12;
+with Sem_Ch13; use Sem_Ch13;
+with Sem_Disp; use Sem_Disp;
+with Sem_Elab; use Sem_Elab;
+with Sem_Eval; use Sem_Eval;
+with Sem_Res; use Sem_Res;
+with Sem_Type; use Sem_Type;
+with Sem_Util; use Sem_Util;
+with Sinfo.Utils; use Sinfo.Utils;
+with Snames; use Snames;
+with Stand; use Stand;
+with Stringt; use Stringt;
+with Tbuild; use Tbuild;
+with Ttypes; use Ttypes;
+with Validsw; use Validsw;
with GNAT.HTable;
package body Exp_Util is
@@ -834,7 +838,7 @@ package body Exp_Util is
-- Optimize the case where we are using the default Global_Pool_Object,
-- and we don't need the heavy finalization machinery.
- elsif Pool_Id = RTE (RE_Global_Pool_Object)
+ elsif Is_RTE (Pool_Id, RE_Global_Pool_Object)
and then not Needs_Finalization (Desig_Typ)
then
return;
@@ -1327,6 +1331,7 @@ package body Exp_Util is
and then Is_Primitive_Wrapper (New_E)
and then Is_Primitive_Wrapper (Subp)
and then Scope (Subp) = Scope (New_E)
+ and then Chars (Pragma_Identifier (Prag)) = Name_Precondition
then
Error_Msg_Node_2 := Wrapped_Entity (Subp);
Error_Msg_NE
@@ -1462,9 +1467,7 @@ package body Exp_Util is
Make_Procedure_Call_Statement (Loc,
Name => New_Occurrence_Of (Proc_Id, Loc),
Parameter_Associations => New_List (
- Make_Unchecked_Type_Conversion (Loc,
- Subtype_Mark => New_Occurrence_Of (Formal_Typ, Loc),
- Expression => Obj_Name)));
+ Unchecked_Convert_To (Formal_Typ, Obj_Name)));
end Build_DIC_Call;
------------------------------
@@ -1854,12 +1857,18 @@ package body Exp_Util is
end if;
-- Once the DIC assertion expression is fully processed, add a check
- -- to the statements of the DIC procedure.
-
- Add_DIC_Check
- (DIC_Prag => DIC_Prag,
- DIC_Expr => Expr,
- Stmts => Stmts);
+ -- to the statements of the DIC procedure (unless the type is an
+ -- abstract type, in which case we don't want the possibility of
+ -- generating a call to an abstract function of the type; such DIC
+ -- procedures can never be called in any case, so not generating the
+ -- check at all is OK).
+
+ if not Is_Abstract_Type (DIC_Typ) or else GNATprove_Mode then
+ Add_DIC_Check
+ (DIC_Prag => DIC_Prag,
+ DIC_Expr => Expr,
+ Stmts => Stmts);
+ end if;
end Add_Own_DIC;
---------------------
@@ -2180,7 +2189,7 @@ package body Exp_Util is
-- Perform minor decoration in case the body is not analyzed
- Set_Ekind (Proc_Body_Id, E_Subprogram_Body);
+ Mutate_Ekind (Proc_Body_Id, E_Subprogram_Body);
Set_Etype (Proc_Body_Id, Standard_Void_Type);
Set_Scope (Proc_Body_Id, Current_Scope);
Set_SPARK_Pragma (Proc_Body_Id, SPARK_Pragma (Proc_Id));
@@ -2347,7 +2356,7 @@ package body Exp_Util is
-- Perform minor decoration in case the declaration is not analyzed
- Set_Ekind (Proc_Id, E_Procedure);
+ Mutate_Ekind (Proc_Id, E_Procedure);
Set_Etype (Proc_Id, Standard_Void_Type);
Set_Is_DIC_Procedure (Proc_Id);
Set_Scope (Proc_Id, Current_Scope);
@@ -2399,7 +2408,7 @@ package body Exp_Util is
-- Perform minor decoration in case the declaration is not analyzed
- Set_Ekind (Obj_Id, E_In_Parameter);
+ Mutate_Ekind (Obj_Id, E_In_Parameter);
Set_Etype (Obj_Id, Work_Typ);
Set_Scope (Obj_Id, Proc_Id);
@@ -3669,7 +3678,7 @@ package body Exp_Util is
-- Perform minor decoration in case the body is not analyzed
- Set_Ekind (Proc_Body_Id, E_Subprogram_Body);
+ Mutate_Ekind (Proc_Body_Id, E_Subprogram_Body);
Set_Etype (Proc_Body_Id, Standard_Void_Type);
Set_Scope (Proc_Body_Id, Current_Scope);
@@ -3807,7 +3816,7 @@ package body Exp_Util is
-- Perform minor decoration in case the declaration is not analyzed
- Set_Ekind (Proc_Id, E_Procedure);
+ Mutate_Ekind (Proc_Id, E_Procedure);
Set_Etype (Proc_Id, Standard_Void_Type);
Set_Scope (Proc_Id, Current_Scope);
@@ -3893,7 +3902,7 @@ package body Exp_Util is
-- Perform minor decoration in case the declaration is not analyzed
- Set_Ekind (Obj_Id, E_In_Parameter);
+ Mutate_Ekind (Obj_Id, E_In_Parameter);
Set_Etype (Obj_Id, Obj_Typ);
Set_Scope (Obj_Id, Proc_Id);
@@ -4697,7 +4706,7 @@ package body Exp_Util is
-- type Ptr_Typ is access all Desig_Typ;
Ptr_Typ := Make_Temporary (Loc, 'A');
- Set_Ekind (Ptr_Typ, E_General_Access_Type);
+ Mutate_Ekind (Ptr_Typ, E_General_Access_Type);
Set_Directly_Designated_Type (Ptr_Typ, Desig_Typ);
Ptr_Decl :=
@@ -4714,7 +4723,7 @@ package body Exp_Util is
-- Hook : Ptr_Typ := null;
Hook_Id := Make_Temporary (Loc, 'T');
- Set_Ekind (Hook_Id, E_Variable);
+ Mutate_Ekind (Hook_Id, E_Variable);
Set_Etype (Hook_Id, Ptr_Typ);
Hook_Decl :=
@@ -5305,6 +5314,195 @@ package body Exp_Util is
end if;
end Evolve_Or_Else;
+ -------------------------------
+ -- Expand_Sliding_Conversion --
+ -------------------------------
+
+ procedure Expand_Sliding_Conversion (N : Node_Id; Arr_Typ : Entity_Id) is
+
+ pragma Assert (Is_Array_Type (Arr_Typ)
+ and then not Is_Constrained (Arr_Typ)
+ and then Is_Fixed_Lower_Bound_Array_Subtype (Arr_Typ));
+
+ Constraints : List_Id;
+ Index : Node_Id := First_Index (Arr_Typ);
+ Loc : constant Source_Ptr := Sloc (N);
+ Subt_Decl : Node_Id;
+ Subt : Entity_Id;
+ Subt_Low : Node_Id;
+ Subt_High : Node_Id;
+
+ Act_Subt : Entity_Id;
+ Act_Index : Node_Id;
+ Act_Low : Node_Id;
+ Act_High : Node_Id;
+ Adjust_Incr : Node_Id;
+ Dimension : Int := 0;
+ All_FLBs_Match : Boolean := True;
+
+ begin
+ -- This procedure is called during semantic analysis, and we only expand
+ -- a sliding conversion when Expander_Active, to avoid doing it during
+ -- preanalysis (which can lead to problems with the target subtype not
+ -- getting properly expanded during later full analysis). Also, sliding
+ -- should never be needed for string literals, because their bounds are
+ -- determined directly based on the fixed lower bound of Arr_Typ and
+ -- their length.
+
+ if Expander_Active and then Nkind (N) /= N_String_Literal then
+ Constraints := New_List;
+
+ Act_Subt := Get_Actual_Subtype (N);
+ Act_Index := First_Index (Act_Subt);
+
+ -- Loop over the indexes of the fixed-lower-bound array type or
+ -- subtype to build up an index constraint for constructing the
+ -- subtype that will be the target of a conversion of the array
+ -- object that may need a sliding conversion.
+
+ while Present (Index) loop
+ pragma Assert (Present (Act_Index));
+
+ Dimension := Dimension + 1;
+
+ Get_Index_Bounds (Act_Index, Act_Low, Act_High);
+
+ -- If Index defines a normal unconstrained range (range <>),
+ -- then we will simply use the bounds of the actual subtype's
+ -- corresponding index range.
+
+ if not Is_Fixed_Lower_Bound_Index_Subtype (Etype (Index)) then
+ Subt_Low := Act_Low;
+ Subt_High := Act_High;
+
+ -- Otherwise, a range will be created with a low bound given by
+ -- the fixed lower bound of the array subtype's index, and with
+ -- high bound given by (Actual'Length + fixed lower bound - 1).
+
+ else
+ if Nkind (Index) = N_Subtype_Indication then
+ Subt_Low :=
+ New_Copy_Tree
+ (Low_Bound (Range_Expression (Constraint (Index))));
+ else
+ pragma Assert (Nkind (Index) = N_Range);
+
+ Subt_Low := New_Copy_Tree (Low_Bound (Index));
+ end if;
+
+ -- If either we have a nonstatic lower bound, or the target and
+ -- source subtypes are statically known to have unequal lower
+ -- bounds, then we will need to make a subtype conversion to
+ -- slide the bounds. However, if all of the indexes' lower
+ -- bounds are static and known to be equal (the common case),
+ -- then no conversion will be needed, and we'll end up not
+ -- creating the subtype or the conversion (though we still
+ -- build up the index constraint, which will simply be unused).
+
+ if not (Compile_Time_Known_Value (Subt_Low)
+ and then Compile_Time_Known_Value (Act_Low))
+ or else Expr_Value (Subt_Low) /= Expr_Value (Act_Low)
+ then
+ All_FLBs_Match := False;
+ end if;
+
+ -- Apply 'Pos to lower bound, which may be of an enumeration
+ -- type, before subtracting.
+
+ Adjust_Incr :=
+ Make_Op_Subtract (Loc,
+ Make_Attribute_Reference (Loc,
+ Prefix =>
+ New_Occurrence_Of (Etype (Act_Index), Loc),
+ Attribute_Name =>
+ Name_Pos,
+ Expressions =>
+ New_List (New_Copy_Tree (Subt_Low))),
+ Make_Integer_Literal (Loc, 1));
+
+ -- Apply 'Val to the result of adding the increment to the
+ -- length, to handle indexes of enumeration types.
+
+ Subt_High :=
+ Make_Attribute_Reference (Loc,
+ Prefix =>
+ New_Occurrence_Of (Etype (Act_Index), Loc),
+ Attribute_Name =>
+ Name_Val,
+ Expressions =>
+ New_List (Make_Op_Add (Loc,
+ Make_Attribute_Reference (Loc,
+ Prefix =>
+ New_Occurrence_Of (Act_Subt, Loc),
+ Attribute_Name =>
+ Name_Length,
+ Expressions =>
+ New_List
+ (Make_Integer_Literal
+ (Loc, Dimension))),
+ Adjust_Incr)));
+ end if;
+
+ Append (Make_Range (Loc, Subt_Low, Subt_High), Constraints);
+
+ Next (Index);
+ Next (Act_Index);
+ end loop;
+
+ -- If for each index with a fixed lower bound (FLB), the lower bound
+ -- of the corresponding index of the actual subtype is statically
+ -- known be equal to the FLB, then a sliding conversion isn't needed
+ -- at all, so just return without building a subtype or conversion.
+
+ if All_FLBs_Match then
+ return;
+ end if;
+
+ -- A sliding conversion is needed, so create the target subtype using
+ -- the index constraint created above, and rewrite the expression
+ -- as a conversion to that subtype.
+
+ Subt := Make_Temporary (Loc, 'S', Related_Node => N);
+ Set_Is_Internal (Subt);
+
+ Subt_Decl :=
+ Make_Subtype_Declaration (Loc,
+ Defining_Identifier => Subt,
+ Subtype_Indication =>
+ Make_Subtype_Indication (Loc,
+ Subtype_Mark =>
+ New_Occurrence_Of (Arr_Typ, Loc),
+ Constraint =>
+ Make_Index_Or_Discriminant_Constraint (Loc,
+ Constraints => Constraints)));
+
+ Mark_Rewrite_Insertion (Subt_Decl);
+
+ -- The actual subtype is an Itype, so we analyze the declaration,
+ -- but do not attach it to the tree.
+
+ Set_Parent (Subt_Decl, N);
+ Set_Is_Itype (Subt);
+ Analyze (Subt_Decl, Suppress => All_Checks);
+ Set_Associated_Node_For_Itype (Subt, N);
+ Set_Has_Delayed_Freeze (Subt, False);
+
+ -- We need to freeze the actual subtype immediately. This is needed
+ -- because otherwise this Itype will not get frozen at all, and it is
+ -- always safe to freeze on creation because any associated types
+ -- must be frozen at this point.
+
+ Freeze_Itype (Subt, N);
+
+ Rewrite (N,
+ Make_Type_Conversion (Loc,
+ Subtype_Mark =>
+ New_Occurrence_Of (Subt, Loc),
+ Expression => Relocate_Node (N)));
+ Analyze (N);
+ end if;
+ end Expand_Sliding_Conversion;
+
-----------------------------------------
-- Expand_Static_Predicates_In_Choices --
-----------------------------------------
@@ -5312,7 +5510,7 @@ package body Exp_Util is
procedure Expand_Static_Predicates_In_Choices (N : Node_Id) is
pragma Assert (Nkind (N) in N_Case_Statement_Alternative | N_Variant);
- Choices : constant List_Id := Discrete_Choices (N);
+ Choices : List_Id := Discrete_Choices (N);
Choice : Node_Id;
Next_C : Node_Id;
@@ -5320,6 +5518,13 @@ package body Exp_Util is
C : Node_Id;
begin
+ -- If this is an "others" alternative, we need to process any static
+ -- predicates in its Others_Discrete_Choices.
+
+ if Nkind (First (Choices)) = N_Others_Choice then
+ Choices := Others_Discrete_Choices (First (Choices));
+ end if;
+
Choice := First (Choices);
while Present (Choice) loop
Next_C := Next (Choice);
@@ -6203,6 +6408,9 @@ package body Exp_Util is
| N_Discriminant_Association
| N_Parameter_Association
| N_Pragma_Argument_Association
+ | N_Aggregate
+ | N_Delta_Aggregate
+ | N_Extension_Aggregate
and then Nkind (Parent (Par)) not in N_Function_Call
| N_Procedure_Call_Statement
| N_Entry_Call_Statement
@@ -7193,8 +7401,8 @@ package body Exp_Util is
-- Actions belong to the then expression, temporarily place
-- them as Then_Actions of the if expression. They will be
- -- moved to the proper place later when the if expression
- -- is expanded.
+ -- moved to the proper place later when the if expression is
+ -- expanded.
elsif N = ThenX then
if Present (Then_Actions (P)) then
@@ -7207,10 +7415,7 @@ package body Exp_Util is
return;
- -- Actions belong to the else expression, temporarily place
- -- them as Else_Actions of the if expression. They will be
- -- moved to the proper place later when the if expression
- -- is expanded.
+ -- Else_Actions is treated the same as Then_Actions above
elsif N = ElseX then
if Present (Else_Actions (P)) then
@@ -8727,26 +8932,6 @@ package body Exp_Util is
end if;
end if;
- -- The following code is historical, it used to be present but it
- -- is too cautious, because the front-end does not know the proper
- -- default alignments for the target. Also, if the alignment is
- -- not known, the front end can't know in any case. If a copy is
- -- needed, the back-end will take care of it. This whole section
- -- including this comment can be removed later ???
-
- -- If the component reference is for a record that has a specified
- -- alignment, and we either know it is too small, or cannot tell,
- -- then the component may be unaligned.
-
- -- What is the following commented out code ???
-
- -- if Known_Alignment (Etype (P))
- -- and then Alignment (Etype (P)) < Ttypes.Maximum_Alignment
- -- and then M > Alignment (Etype (P))
- -- then
- -- return True;
- -- end if;
-
-- Case of component clause present which may specify an
-- unaligned position.
@@ -8863,7 +9048,7 @@ package body Exp_Util is
if Target_Strict_Alignment
and then Known_Alignment (Ptyp)
- and then (Unknown_Alignment (Styp)
+ and then (not Known_Alignment (Styp)
or else Alignment (Styp) > Alignment (Ptyp))
then
return True;
@@ -8887,7 +9072,7 @@ package body Exp_Util is
begin
if Present (Component_Clause (Field))
and then
- (Unknown_Alignment (Styp)
+ (not Known_Alignment (Styp)
or else
(Component_Bit_Offset (Field) mod
(System_Storage_Unit * Alignment (Styp))) /= 0)
@@ -9075,7 +9260,7 @@ package body Exp_Util is
Is_Class_Wide_Type (Etype (Obj_Id))
and then Present (Expr)
and then Nkind (Expr) = N_Unchecked_Type_Conversion
- and then Etype (Expression (Expr)) = RTE (RE_Tag);
+ and then Is_RTE (Etype (Expression (Expr)), RE_Tag);
end Is_Tag_To_Class_Wide_Conversion;
--------------------------------
@@ -9196,7 +9381,7 @@ package body Exp_Util is
-- True if object reference with volatile type
- elsif Is_Volatile_Object (N) then
+ elsif Is_Volatile_Object_Ref (N) then
return True;
-- True if reference to volatile entity
@@ -9251,28 +9436,33 @@ package body Exp_Util is
if W then
-- We suppress the warning if this code is under control of an
- -- if statement, whose condition is a simple identifier, and
- -- either we are in an instance, or warnings off is set for this
- -- identifier. The reason for killing it in the instance case is
- -- that it is common and reasonable for code to be deleted in
- -- instances for various reasons.
+ -- if/case statement and either
+ -- a) we are in an instance and the condition/selector
+ -- has a statically known value; or
+ -- b) the condition/selector is a simple identifier and
+ -- warnings off is set for this identifier.
+ -- Dead code is common and reasonable in instances, so we don't
+ -- want a warning in that case.
- -- Could we use Is_Statically_Unevaluated here???
+ declare
+ C : Node_Id := Empty;
+ begin
+ if Nkind (Parent (N)) = N_If_Statement then
+ C := Condition (Parent (N));
+ elsif Nkind (Parent (N)) = N_Case_Statement_Alternative then
+ C := Expression (Parent (Parent (N)));
+ end if;
- if Nkind (Parent (N)) = N_If_Statement then
- declare
- C : constant Node_Id := Condition (Parent (N));
- begin
- if Nkind (C) = N_Identifier
- and then
- (In_Instance
- or else (Present (Entity (C))
- and then Has_Warnings_Off (Entity (C))))
+ if Present (C) then
+ if (In_Instance and Compile_Time_Known_Value (C))
+ or else (Nkind (C) = N_Identifier
+ and then Present (Entity (C))
+ and then Has_Warnings_Off (Entity (C)))
then
W := False;
end if;
- end;
- end if;
+ end if;
+ end;
-- Generate warning if not suppressed
@@ -9505,7 +9695,7 @@ package body Exp_Util is
-- end Equiv_T;
Equiv_Type := Make_Temporary (Loc, 'T');
- Set_Ekind (Equiv_Type, E_Record_Type);
+ Mutate_Ekind (Equiv_Type, E_Record_Type);
Set_Parent_Subtype (Equiv_Type, Constr_Root);
-- Set Is_Class_Wide_Equivalent_Type very early to trigger the special
@@ -9997,7 +10187,7 @@ package body Exp_Util is
-- Define the dummy private subtype
- Set_Ekind (Priv_Subtyp, Subtype_Kind (Ekind (Unc_Typ)));
+ Mutate_Ekind (Priv_Subtyp, Subtype_Kind (Ekind (Unc_Typ)));
Set_Etype (Priv_Subtyp, Base_Type (Unc_Typ));
Set_Scope (Priv_Subtyp, Full_Subtyp);
Set_Is_Constrained (Priv_Subtyp);
@@ -10923,7 +11113,7 @@ package body Exp_Util is
Set_Associated_Node_For_Itype (Res, N);
Set_Comes_From_Source (Res, False);
- Set_Ekind (Res, E_Class_Wide_Subtype);
+ Mutate_Ekind (Res, E_Class_Wide_Subtype);
Set_Etype (Res, Base_Type (CW_Typ));
Set_Freeze_Node (Res, Empty);
Set_Is_Frozen (Res, False);
@@ -11343,7 +11533,7 @@ package body Exp_Util is
Init_Call : Node_Id;
- -- Start of processing for Find_Init_Call
+ -- Start of processing for Remove_Init_Call
begin
if Present (Initialization_Statements (Var)) then
@@ -11395,8 +11585,29 @@ package body Exp_Util is
end if;
if Present (Init_Call) then
+ -- If restrictions have forbidden Aborts, the initialization call
+ -- for objects that require deep initialization has not been wrapped
+ -- into the following block (see Exp_Ch3, Default_Initialize_Object)
+ -- so if present remove it as well, and include the IP call in it,
+ -- in the rare case the caller may need to simply displace the
+ -- initialization, as is done for a later address specification.
+
+ if Nkind (Next (Init_Call)) = N_Block_Statement
+ and then Is_Initialization_Block (Next (Init_Call))
+ then
+ declare
+ IP_Call : constant Node_Id := Init_Call;
+ begin
+ Init_Call := Next (IP_Call);
+ Remove (IP_Call);
+ Prepend (IP_Call,
+ Statements (Handled_Statement_Sequence (Init_Call)));
+ end;
+ end if;
+
Remove (Init_Call);
end if;
+
return Init_Call;
end Remove_Init_Call;
@@ -11477,7 +11688,8 @@ package body Exp_Util is
return not Inside_A_Generic
and then Full_Analysis
and then Nkind (Enclosing_Declaration (Exp)) in
- N_Full_Type_Declaration
+ N_Component_Declaration
+ | N_Full_Type_Declaration
| N_Iterator_Specification
| N_Loop_Parameter_Specification
| N_Object_Renaming_Declaration
@@ -12063,7 +12275,9 @@ package body Exp_Util is
-- Local variables
- Context : constant Node_Id := Parent (Ref);
+ Context : constant Node_Id :=
+ (if No (Ref) then Empty else Parent (Ref));
+
Loc : constant Source_Ptr := Sloc (Ref);
Ref_Id : Entity_Id;
Result : Traverse_Result;
@@ -12195,15 +12409,28 @@ package body Exp_Util is
if Nkind (Context) in N_Subprogram_Call
and then No (Type_Map.Get (Entity (Name (Context))))
then
- New_Ref :=
- Convert_To (Type_Of_Formal (Context, Old_Ref), New_Ref);
-
- -- Do not process the generated type conversion because
- -- both the parent type and the derived type are in the
- -- Type_Map table. This will clobber the type conversion
- -- by resetting its subtype mark.
-
- Result := Skip;
+ declare
+ -- We need to use the Original_Node of the callee, in
+ -- case it was already modified. Note that we are using
+ -- Traverse_Proc to walk the tree, and it is defined to
+ -- walk subtrees in an arbitrary order.
+
+ Callee : constant Entity_Id :=
+ Entity (Original_Node (Name (Context)));
+ begin
+ if No (Type_Map.Get (Callee)) then
+ New_Ref :=
+ Convert_To
+ (Type_Of_Formal (Context, Old_Ref), New_Ref);
+
+ -- Do not process the generated type conversion
+ -- because both the parent type and the derived type
+ -- are in the Type_Map table. This will clobber the
+ -- type conversion by resetting its subtype mark.
+
+ Result := Skip;
+ end if;
+ end;
end if;
-- Otherwise there is nothing to replace
@@ -13266,7 +13493,7 @@ package body Exp_Util is
-- modification of that variable within the loop may incorrectly
-- affect the execution of the loop.
- elsif Nkind (Parent (Parent (N))) = N_Loop_Parameter_Specification
+ elsif Parent_Kind (Parent (N)) = N_Loop_Parameter_Specification
and then Within_In_Parameter (Prefix (N))
and then Variable_Ref
then
@@ -13436,16 +13663,26 @@ package body Exp_Util is
-- A binary operator is side effect free if and both operands are
-- side effect free. For this purpose binary operators include
- -- membership tests and short circuit forms.
+ -- short circuit forms.
when N_Binary_Op
- | N_Membership_Test
| N_Short_Circuit
=>
return Side_Effect_Free (Left_Opnd (N), Name_Req, Variable_Ref)
and then
Side_Effect_Free (Right_Opnd (N), Name_Req, Variable_Ref);
+ -- Membership tests may have either Right_Opnd or Alternatives set
+
+ when N_Membership_Test =>
+ return Side_Effect_Free (Left_Opnd (N), Name_Req, Variable_Ref)
+ and then
+ (if Present (Right_Opnd (N))
+ then Side_Effect_Free
+ (Right_Opnd (N), Name_Req, Variable_Ref)
+ else Side_Effect_Free
+ (Alternatives (N), Name_Req, Variable_Ref));
+
-- An explicit dereference is side effect free only if it is
-- a side effect free prefixed reference.
diff --git a/gcc/ada/exp_util.ads b/gcc/ada/exp_util.ads
index 96d3894..5c931c9 100644
--- a/gcc/ada/exp_util.ads
+++ b/gcc/ada/exp_util.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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,12 +25,13 @@
-- Package containing utility procedures used throughout the expander
-with Exp_Tss; use Exp_Tss;
-with Namet; use Namet;
-with Rtsfind; use Rtsfind;
-with Sinfo; use Sinfo;
-with Types; use Types;
-with Uintp; use Uintp;
+with Exp_Tss; use Exp_Tss;
+with Namet; use Namet;
+with Rtsfind; use Rtsfind;
+with Sinfo; use Sinfo;
+with Sinfo.Nodes; use Sinfo.Nodes;
+with Types; use Types;
+with Uintp; use Uintp;
package Exp_Util is
@@ -50,11 +51,11 @@ package Exp_Util is
-- of statements, the actions are simply inserted into the list before
-- the associated statement.
- -- For an expression occurring in a declaration (declarations always
- -- appear in lists), the actions are similarly inserted into the list
- -- just before the associated declaration. ???Declarations do not always
- -- appear in lists; in particular, a library unit declaration does not
- -- appear in a list, and Insert_Action will crash in that case.
+ -- For an expression occurring in a declaration the actions are similarly
+ -- inserted into the list just before the associated declaration. (But
+ -- note that although declarations usually appear in lists, they don't
+ -- always; in particular, a library unit declaration does not appear in
+ -- a list, and Insert_Action will crash in that case.)
-- The following special cases arise:
@@ -161,7 +162,7 @@ package Exp_Util is
--
-- Implementation limitation: Assoc_Node must be a statement. We can
-- generalize to expressions if there is a need but this is tricky to
- -- implement because of short-circuits (among other things).???
+ -- implement because of short-circuits (among other things).
procedure Insert_Declaration (N : Node_Id; Decl : Node_Id);
-- N must be a subexpression (Nkind in N_Subexpr). This is similar to
@@ -477,7 +478,7 @@ package Exp_Util is
--
-- The Name_Req flag is set to ensure that the result is suitable for use
-- in a context requiring a name (for example, the prefix of an attribute
- -- reference) (can't this just be a qualification in Ada 2012???).
+ -- reference).
--
-- The Renaming_Req flag is set to produce an object renaming declaration
-- rather than an object declaration. This is valid only if the expression
@@ -559,6 +560,12 @@ package Exp_Util is
-- indicating that no checks were required). The Sloc field of the
-- constructed N_Or_Else node is copied from Cond1.
+ procedure Expand_Sliding_Conversion (N : Node_Id; Arr_Typ : Entity_Id);
+ -- When sliding is needed for an array object N in the context of an
+ -- unconstrained array type Arr_Typ with fixed lower bound (FLB), create
+ -- a subtype with appropriate index constraint (FLB .. N'Length + FLB - 1)
+ -- and apply a conversion from N to that subtype.
+
procedure Expand_Static_Predicates_In_Choices (N : Node_Id);
-- N is either a case alternative or a variant. The Discrete_Choices field
-- of N points to a list of choices. If any of these choices is the name
@@ -908,7 +915,7 @@ package Exp_Util is
-- Establish the following mapping between the attributes of tagged parent
-- type Parent_Type and tagged derived type Derived_Type.
--
- -- * Map each discriminant of Parent_Type to ether the corresponding
+ -- * Map each discriminant of Parent_Type to either the corresponding
-- discriminant of Derived_Type or come constraint.
-- * Map each primitive operation of Parent_Type to the corresponding
diff --git a/gcc/ada/expander.adb b/gcc/ada/expander.adb
index d6219f4..e0483b7 100644
--- a/gcc/ada/expander.adb
+++ b/gcc/ada/expander.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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,31 +23,32 @@
-- --
------------------------------------------------------------------------------
-with Atree; use Atree;
-with Debug; use Debug;
-with Debug_A; use Debug_A;
-with Exp_Aggr; use Exp_Aggr;
-with Exp_SPARK; use Exp_SPARK;
-with Exp_Attr; use Exp_Attr;
-with Exp_Ch2; use Exp_Ch2;
-with Exp_Ch3; use Exp_Ch3;
-with Exp_Ch4; use Exp_Ch4;
-with Exp_Ch5; use Exp_Ch5;
-with Exp_Ch6; use Exp_Ch6;
-with Exp_Ch7; use Exp_Ch7;
-with Exp_Ch8; use Exp_Ch8;
-with Exp_Ch9; use Exp_Ch9;
-with Exp_Ch11; use Exp_Ch11;
-with Exp_Ch12; use Exp_Ch12;
-with Exp_Ch13; use Exp_Ch13;
-with Exp_Prag; use Exp_Prag;
-with Ghost; use Ghost;
-with Opt; use Opt;
-with Rtsfind; use Rtsfind;
-with Sem; use Sem;
-with Sem_Ch8; use Sem_Ch8;
-with Sem_Util; use Sem_Util;
-with Sinfo; use Sinfo;
+with Atree; use Atree;
+with Debug; use Debug;
+with Debug_A; use Debug_A;
+with Exp_Aggr; use Exp_Aggr;
+with Exp_SPARK; use Exp_SPARK;
+with Exp_Attr; use Exp_Attr;
+with Exp_Ch2; use Exp_Ch2;
+with Exp_Ch3; use Exp_Ch3;
+with Exp_Ch4; use Exp_Ch4;
+with Exp_Ch5; use Exp_Ch5;
+with Exp_Ch6; use Exp_Ch6;
+with Exp_Ch7; use Exp_Ch7;
+with Exp_Ch8; use Exp_Ch8;
+with Exp_Ch9; use Exp_Ch9;
+with Exp_Ch11; use Exp_Ch11;
+with Exp_Ch12; use Exp_Ch12;
+with Exp_Ch13; use Exp_Ch13;
+with Exp_Prag; use Exp_Prag;
+with Ghost; use Ghost;
+with Opt; use Opt;
+with Rtsfind; use Rtsfind;
+with Sem; use Sem;
+with Sem_Ch8; use Sem_Ch8;
+with Sem_Util; use Sem_Util;
+with Sinfo; use Sinfo;
+with Sinfo.Nodes; use Sinfo.Nodes;
with Table;
package body Expander is
@@ -273,6 +274,9 @@ package body Expander is
when N_Generic_Instantiation =>
Expand_N_Generic_Instantiation (N);
+ when N_Goto_When_Statement =>
+ Expand_N_Goto_When_Statement (N);
+
when N_Handled_Sequence_Of_Statements =>
Expand_N_Handled_Sequence_Of_Statements (N);
@@ -420,6 +424,9 @@ package body Expander is
when N_Raise_Statement =>
Expand_N_Raise_Statement (N);
+ when N_Raise_When_Statement =>
+ Expand_N_Raise_When_Statement (N);
+
when N_Raise_Constraint_Error =>
Expand_N_Raise_Constraint_Error (N);
@@ -441,6 +448,9 @@ package body Expander is
when N_Requeue_Statement =>
Expand_N_Requeue_Statement (N);
+ when N_Return_When_Statement =>
+ Expand_N_Return_When_Statement (N);
+
when N_Simple_Return_Statement =>
Expand_N_Simple_Return_Statement (N);
diff --git a/gcc/ada/expander.ads b/gcc/ada/expander.ads
index d7c61ec..12e7398 100644
--- a/gcc/ada/expander.ads
+++ b/gcc/ada/expander.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/expect.c b/gcc/ada/expect.c
index 30c5b8e..a92c465 100644
--- a/gcc/ada/expect.c
+++ b/gcc/ada/expect.c
@@ -6,7 +6,7 @@
* *
* C Implementation File *
* *
- * Copyright (C) 2001-2020, AdaCore *
+ * Copyright (C) 2001-2021, 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/fe.h b/gcc/ada/fe.h
index 858a28a..4517c59 100644
--- a/gcc/ada/fe.h
+++ b/gcc/ada/fe.h
@@ -6,7 +6,7 @@
* *
* C Header File *
* *
- * Copyright (C) 1992-2020, Free Software Foundation, Inc. *
+ * Copyright (C) 1992-2021, Free Software Foundation, Inc. *
* *
* GNAT is 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,7 +55,7 @@ extern Nat Serious_Errors_Detected;
#define Compiler_Abort comperr__compiler_abort
-extern int Compiler_Abort (String_Pointer, String_Pointer, Boolean) ATTRIBUTE_NORETURN;
+extern void Compiler_Abort (String_Pointer, String_Pointer, Boolean) ATTRIBUTE_NORETURN;
/* debug: */
@@ -69,14 +69,14 @@ extern Boolean Debug_Flag_NN;
/* einfo: */
-#define Set_Alignment einfo__set_alignment
-#define Set_Component_Bit_Offset einfo__set_component_bit_offset
-#define Set_Component_Size einfo__set_component_size
-#define Set_Esize einfo__set_esize
-#define Set_Mechanism einfo__set_mechanism
-#define Set_Normalized_First_Bit einfo__set_normalized_first_bit
-#define Set_Normalized_Position einfo__set_normalized_position
-#define Set_RM_Size einfo__set_rm_size
+#define Set_Alignment einfo__entities__set_alignment
+#define Set_Component_Bit_Offset einfo__entities__set_component_bit_offset
+#define Set_Component_Size einfo__entities__set_component_size
+#define Set_Esize einfo__entities__set_esize
+#define Set_Mechanism einfo__entities__set_mechanism
+#define Set_Normalized_First_Bit einfo__entities__set_normalized_first_bit
+#define Set_Normalized_Position einfo__entities__set_normalized_position
+#define Set_RM_Size einfo__entities__set_rm_size
extern void Set_Alignment (Entity_Id, Uint);
extern void Set_Component_Bit_Offset (Entity_Id, Uint);
@@ -87,11 +87,11 @@ extern void Set_Normalized_First_Bit (Entity_Id, Uint);
extern void Set_Normalized_Position (Entity_Id, Uint);
extern void Set_RM_Size (Entity_Id, Uint);
-#define Is_Entity_Name einfo__is_entity_name
+#define Is_Entity_Name einfo__utils__is_entity_name
extern Boolean Is_Entity_Name (Node_Id);
-#define Get_Attribute_Definition_Clause einfo__get_attribute_definition_clause
+#define Get_Attribute_Definition_Clause einfo__utils__get_attribute_definition_clause
extern Node_Id Get_Attribute_Definition_Clause (Entity_Id, unsigned char);
@@ -103,7 +103,7 @@ extern Node_Id Get_Attribute_Definition_Clause (Entity_Id, unsigned char);
extern void Error_Msg_N (String_Pointer, Node_Id);
extern void Error_Msg_NE (String_Pointer, Node_Id, Entity_Id);
-extern void Set_Identifier_Casing (Char *, const Char *);
+extern void Set_Identifier_Casing (void *, const void *);
/* err_vars: */
@@ -122,7 +122,7 @@ extern Uint Error_Msg_Uint_2;
extern Entity_Id Get_Local_Raise_Call_Entity (void);
extern Entity_Id Get_RT_Exception_Entity (int);
-extern void Get_RT_Exception_Name (int);
+extern void Get_RT_Exception_Name (enum RT_Exception_Code);
extern void Warn_If_No_Local_Raise (int);
/* exp_code: */
@@ -145,7 +145,7 @@ extern Node_Id Asm_Input_Value (void);
extern Node_Id Asm_Output_Constraint (void);
extern Node_Id Asm_Output_Variable (void);
extern Node_Id Asm_Template (Node_Id);
-extern char *Clobber_Get_Next (void);
+extern void *Clobber_Get_Next (void);
extern void Clobber_Setup (Node_Id);
extern Boolean Is_Asm_Volatile (Node_Id);
extern void Next_Asm_Input (void);
@@ -190,6 +190,7 @@ extern Boolean In_Extended_Main_Code_Unit (Entity_Id);
/* opt: */
#define Ada_Version opt__ada_version
+#define Assume_No_Invalid_Values opt__assume_no_invalid_values
#define Back_End_Inlining opt__back_end_inlining
#define Debug_Generated_Code opt__debug_generated_code
#define Enable_128bit_Types opt__enable_128bit_types
@@ -203,7 +204,7 @@ extern Boolean In_Extended_Main_Code_Unit (Entity_Id);
#define Suppress_Checks opt__suppress_checks
typedef enum {
- Ada_83, Ada_95, Ada_2005, Ada_2012, Ada_2020
+ Ada_83, Ada_95, Ada_2005, Ada_2012, Ada_2022, Ada_With_Extensions
} Ada_Version_Type;
typedef enum {
@@ -211,6 +212,7 @@ typedef enum {
} Exception_Mechanism_Type;
extern Ada_Version_Type Ada_Version;
+extern Boolean Assume_No_Invalid_Values;
extern Boolean Back_End_Inlining;
extern Boolean Debug_Generated_Code;
extern Boolean Enable_128bit_Types;
@@ -301,9 +303,9 @@ extern Boolean Requires_Transient_Scope (Entity_Id);
/* sinfo: */
-#define End_Location sinfo__end_location
-#define Set_Has_No_Elaboration_Code sinfo__set_has_no_elaboration_code
-#define Set_Present_Expr sinfo__set_present_expr
+#define End_Location sinfo__utils__end_location
+#define Set_Has_No_Elaboration_Code sinfo__nodes__set_has_no_elaboration_code
+#define Set_Present_Expr sinfo__nodes__set_present_expr
extern Source_Ptr End_Location (Node_Id);
extern void Set_Has_No_Elaboration_Code (Node_Id, Boolean);
@@ -343,6 +345,359 @@ extern Boolean Stack_Check_Probes_On_Target;
extern Boolean Warn_On_Questionable_Layout;
+// The following corresponds to Ada code in Einfo.Utils.
+
+typedef Boolean B;
+typedef Component_Alignment_Kind C;
+typedef Entity_Id E;
+typedef Mechanism_Type M;
+typedef Node_Id N;
+typedef Uint U;
+typedef Ureal R;
+typedef Elist_Id L;
+typedef List_Id S;
+
+#define Is_Access_Object_Type einfo__utils__is_access_object_type
+B Is_Access_Object_Type (E Id);
+
+#define Is_Named_Access_Type einfo__utils__is_named_access_type
+B Is_Named_Access_Type (E Id);
+
+#define Address_Clause einfo__utils__address_clause
+N Address_Clause (E Id);
+
+#define Aft_Value einfo__utils__aft_value
+U Aft_Value (E Id);
+
+#define Alignment_Clause einfo__utils__alignment_clause
+N Alignment_Clause (E Id);
+
+#define Base_Type einfo__utils__base_type
+E Base_Type (E Id);
+
+#define Declaration_Node einfo__utils__declaration_node
+N Declaration_Node (E Id);
+
+#define Designated_Type einfo__utils__designated_type
+E Designated_Type (E Id);
+
+#define First_Component einfo__utils__first_component
+E First_Component (E Id);
+
+#define First_Component_Or_Discriminant einfo__utils__first_component_or_discriminant
+E First_Component_Or_Discriminant (E Id);
+
+#define First_Formal einfo__utils__first_formal
+E First_Formal (E Id);
+
+#define First_Formal_With_Extras einfo__utils__first_formal_with_extras
+E First_Formal_With_Extras (E Id);
+
+#define Has_Attach_Handler einfo__utils__has_attach_handler
+B Has_Attach_Handler (E Id);
+
+#define Has_Entries einfo__utils__has_entries
+B Has_Entries (E Id);
+
+#define Has_Foreign_Convention einfo__utils__has_foreign_convention
+B Has_Foreign_Convention (E Id);
+
+#define Has_Interrupt_Handler einfo__utils__has_interrupt_handler
+B Has_Interrupt_Handler (E Id);
+
+#define Has_Non_Limited_View einfo__utils__has_non_limited_view
+B Has_Non_Limited_View (E Id);
+
+#define Has_Non_Null_Abstract_State einfo__utils__has_non_null_abstract_state
+B Has_Non_Null_Abstract_State (E Id);
+
+#define Has_Non_Null_Visible_Refinement einfo__utils__has_non_null_visible_refinement
+B Has_Non_Null_Visible_Refinement (E Id);
+
+#define Has_Null_Abstract_State einfo__utils__has_null_abstract_state
+B Has_Null_Abstract_State (E Id);
+
+#define Has_Null_Visible_Refinement einfo__utils__has_null_visible_refinement
+B Has_Null_Visible_Refinement (E Id);
+
+#define Implementation_Base_Type einfo__utils__implementation_base_type
+E Implementation_Base_Type (E Id);
+
+#define Is_Base_Type einfo__utils__is_base_type
+B Is_Base_Type (E Id);
+
+#define Is_Boolean_Type einfo__utils__is_boolean_type
+B Is_Boolean_Type (E Id);
+
+#define Is_Constant_Object einfo__utils__is_constant_object
+B Is_Constant_Object (E Id);
+
+#define Is_Controlled einfo__utils__is_controlled
+B Is_Controlled (E Id);
+
+#define Is_Discriminal einfo__utils__is_discriminal
+B Is_Discriminal (E Id);
+
+#define Is_Dynamic_Scope einfo__utils__is_dynamic_scope
+B Is_Dynamic_Scope (E Id);
+
+#define Is_Elaboration_Target einfo__utils__is_elaboration_target
+B Is_Elaboration_Target (E Id);
+
+#define Is_External_State einfo__utils__is_external_state
+B Is_External_State (E Id);
+
+#define Is_Finalizer einfo__utils__is_finalizer
+B Is_Finalizer (E Id);
+
+#define Is_Null_State einfo__utils__is_null_state
+B Is_Null_State (E Id);
+
+#define Is_Package_Or_Generic_Package einfo__utils__is_package_or_generic_package
+B Is_Package_Or_Generic_Package (E Id);
+
+#define Is_Packed_Array einfo__utils__is_packed_array
+B Is_Packed_Array (E Id);
+
+#define Is_Prival einfo__utils__is_prival
+B Is_Prival (E Id);
+
+#define Is_Protected_Component einfo__utils__is_protected_component
+B Is_Protected_Component (E Id);
+
+#define Is_Protected_Interface einfo__utils__is_protected_interface
+B Is_Protected_Interface (E Id);
+
+#define Is_Protected_Record_Type einfo__utils__is_protected_record_type
+B Is_Protected_Record_Type (E Id);
+
+#define Is_Relaxed_Initialization_State einfo__utils__is_relaxed_initialization_state
+B Is_Relaxed_Initialization_State (E Id);
+
+#define Is_Standard_Character_Type einfo__utils__is_standard_character_type
+B Is_Standard_Character_Type (E Id);
+
+#define Is_Standard_String_Type einfo__utils__is_standard_string_type
+B Is_Standard_String_Type (E Id);
+
+#define Is_String_Type einfo__utils__is_string_type
+B Is_String_Type (E Id);
+
+#define Is_Synchronized_Interface einfo__utils__is_synchronized_interface
+B Is_Synchronized_Interface (E Id);
+
+#define Is_Synchronized_State einfo__utils__is_synchronized_state
+B Is_Synchronized_State (E Id);
+
+#define Is_Task_Interface einfo__utils__is_task_interface
+B Is_Task_Interface (E Id);
+
+#define Is_Task_Record_Type einfo__utils__is_task_record_type
+B Is_Task_Record_Type (E Id);
+
+#define Is_Wrapper_Package einfo__utils__is_wrapper_package
+B Is_Wrapper_Package (E Id);
+
+#define Last_Formal einfo__utils__last_formal
+E Last_Formal (E Id);
+
+#define Machine_Emax_Value einfo__utils__machine_emax_value
+U Machine_Emax_Value (E Id);
+
+#define Machine_Emin_Value einfo__utils__machine_emin_value
+U Machine_Emin_Value (E Id);
+
+#define Machine_Mantissa_Value einfo__utils__machine_mantissa_value
+U Machine_Mantissa_Value (E Id);
+
+#define Machine_Radix_Value einfo__utils__machine_radix_value
+U Machine_Radix_Value (E Id);
+
+#define Model_Emin_Value einfo__utils__model_emin_value
+U Model_Emin_Value (E Id);
+
+#define Model_Epsilon_Value einfo__utils__model_epsilon_value
+R Model_Epsilon_Value (E Id);
+
+#define Model_Mantissa_Value einfo__utils__model_mantissa_value
+U Model_Mantissa_Value (E Id);
+
+#define Model_Small_Value einfo__utils__model_small_value
+R Model_Small_Value (E Id);
+
+#define Next_Component einfo__utils__next_component
+E Next_Component (E Id);
+
+#define Next_Component_Or_Discriminant einfo__utils__next_component_or_discriminant
+E Next_Component_Or_Discriminant (E Id);
+
+#define Next_Discriminant einfo__utils__next_discriminant
+E Next_Discriminant (E Id);
+
+#define Next_Formal einfo__utils__next_formal
+E Next_Formal (E Id);
+
+#define Next_Formal_With_Extras einfo__utils__next_formal_with_extras
+E Next_Formal_With_Extras (E Id);
+
+#define Number_Dimensions einfo__utils__number_dimensions
+Pos Number_Dimensions (E Id);
+
+#define Number_Entries einfo__utils__number_entries
+Nat Number_Entries (E Id);
+
+#define Number_Formals einfo__utils__number_formals
+Pos Number_Formals (E Id);
+
+#define Object_Size_Clause einfo__utils__object_size_clause
+N Object_Size_Clause (E Id);
+
+#define Partial_Refinement_Constituents einfo__utils__partial_refinement_constituents
+L Partial_Refinement_Constituents (E Id);
+
+#define Primitive_Operations einfo__utils__primitive_operations
+L Primitive_Operations (E Id);
+
+#define Root_Type einfo__utils__root_type
+E Root_Type (E Id);
+
+#define Safe_Emax_Value einfo__utils__safe_emax_value
+U Safe_Emax_Value (E Id);
+
+#define Safe_First_Value einfo__utils__safe_first_value
+R Safe_First_Value (E Id);
+
+#define Safe_Last_Value einfo__utils__safe_last_value
+R Safe_Last_Value (E Id);
+
+#define Scope_Depth einfo__utils__scope_depth
+U Scope_Depth (E Id);
+
+#define Scope_Depth_Set einfo__utils__scope_depth_set
+B Scope_Depth_Set (E Id);
+
+#define Size_Clause einfo__utils__size_clause
+N Size_Clause (E Id);
+
+#define Stream_Size_Clause einfo__utils__stream_size_clause
+N Stream_Size_Clause (E Id);
+
+#define Type_High_Bound einfo__utils__type_high_bound
+N Type_High_Bound (E Id);
+
+#define Type_Low_Bound einfo__utils__type_low_bound
+N Type_Low_Bound (E Id);
+
+#define Underlying_Type einfo__utils__underlying_type
+E Underlying_Type (E Id);
+
+#define Known_Alignment einfo__utils__known_alignment
+B Known_Alignment (Entity_Id E);
+
+#define Known_Component_Bit_Offset einfo__utils__known_component_bit_offset
+B Known_Component_Bit_Offset (Entity_Id E);
+
+#define Known_Component_Size einfo__utils__known_component_size
+B Known_Component_Size (Entity_Id E);
+
+#define Known_Esize einfo__utils__known_esize
+B Known_Esize (Entity_Id E);
+
+#define Known_Normalized_First_Bit einfo__utils__known_normalized_first_bit
+B Known_Normalized_First_Bit (Entity_Id E);
+
+#define Known_Normalized_Position einfo__utils__known_normalized_position
+B Known_Normalized_Position (Entity_Id E);
+
+#define Known_Normalized_Position_Max einfo__utils__known_normalized_position_max
+B Known_Normalized_Position_Max (Entity_Id E);
+
+#define Known_RM_Size einfo__utils__known_rm_size
+B Known_RM_Size (Entity_Id E);
+
+#define Known_Static_Component_Bit_Offset einfo__utils__known_static_component_bit_offset
+B Known_Static_Component_Bit_Offset (Entity_Id E);
+
+#define Known_Static_Component_Size einfo__utils__known_static_component_size
+B Known_Static_Component_Size (Entity_Id E);
+
+#define Known_Static_Esize einfo__utils__known_static_esize
+B Known_Static_Esize (Entity_Id E);
+
+#define Known_Static_Normalized_First_Bit einfo__utils__known_static_normalized_first_bit
+B Known_Static_Normalized_First_Bit (Entity_Id E);
+
+#define Known_Static_Normalized_Position einfo__utils__known_static_normalized_position
+B Known_Static_Normalized_Position (Entity_Id E);
+
+#define Known_Static_Normalized_Position_Max einfo__utils__known_static_normalized_position_max
+B Known_Static_Normalized_Position_Max (Entity_Id E);
+
+#define Known_Static_RM_Size einfo__utils__known_static_rm_size
+B Known_Static_RM_Size (Entity_Id E);
+
+#define Copy_Alignment einfo__utils__copy_alignment
+B Copy_Alignment(Entity_Id To, Entity_Id From);
+
+#define Is_Discrete_Or_Fixed_Point_Type einfo__utils__is_discrete_or_fixed_point_type
+B Is_Discrete_Or_Fixed_Point_Type (E Id);
+
+#define Is_Floating_Point_Type einfo__utils__is_floating_point_type
+B Is_Floating_Point_Type (E Id);
+
+#define Is_Record_Type einfo__utils__is_record_type
+B Is_Record_Type (E Id);
+
+#define Has_DIC einfo__utils__has_dic
+B Has_DIC (E Id);
+
+#define Has_Invariants einfo__utils__has_invariants
+B Has_Invariants (E Id);
+
+#define Is_Full_Access einfo__utils__is_full_access
+B Is_Full_Access (E Id);
+
+#define Next_Index einfo__utils__next_index
+Node_Id Next_Index (Node_Id Id);
+
+#define Next_Literal einfo__utils__next_literal
+E Next_Literal (E Id);
+
+#define Next_Stored_Discriminant einfo__utils__next_stored_discriminant
+E Next_Stored_Discriminant (E Id);
+
+#define Parameter_Mode einfo__utils__parameter_mode
+// Parameter_Mode really returns Formal_Kind, but that is not visible, because
+// fe.h is included before einfo.h.
+Entity_Kind Parameter_Mode (E Id);
+
+#define Is_List_Member einfo__utils__is_list_member
+B Is_List_Member (N Node);
+
+#define List_Containing einfo__utils__list_containing
+S List_Containing (N Node);
+
+// The following is needed because Convention in Sem_Util is a renaming
+// of Basic_Convention.
+
+#define Convention einfo__entities__basic_convention
+Convention_Id Convention (N Node);
+
+// See comments regarding Entity_Or_Associated_Node in Sinfo.Utils.
+
+#define Entity sinfo__nodes__entity_or_associated_node
+Entity_Id Entity (N Node);
+
+// See comments regarding Renamed_Or_Alias in Einfo.Utils
+
+#define Alias einfo__entities__renamed_or_alias
+
+#define Renamed_Entity einfo__entities__renamed_or_alias
+Node_Id Renamed_Entity (N Node);
+
+#define Renamed_Object einfo__entities__renamed_or_alias
+Node_Id Renamed_Object (N Node);
+
#ifdef __cplusplus
}
#endif
diff --git a/gcc/ada/final.c b/gcc/ada/final.c
index 5b3b3b4..58038d5 100644
--- a/gcc/ada/final.c
+++ b/gcc/ada/final.c
@@ -6,7 +6,7 @@
* *
* C Implementation File *
* *
- * Copyright (C) 1992-2020, Free Software Foundation, Inc. *
+ * Copyright (C) 1992-2021, Free Software Foundation, Inc. *
* *
* GNAT is free software; you can redistribute 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 40aeef1..7a8e082 100644
--- a/gcc/ada/fmap.adb
+++ b/gcc/ada/fmap.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2001-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2001-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute 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 862b8ea..b3294dd 100644
--- a/gcc/ada/fmap.ads
+++ b/gcc/ada/fmap.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2001-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2001-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -68,10 +68,7 @@ package Fmap is
-- mapping file whose file name is File_Name.
procedure Reset_Tables;
- -- Initialize all the internal data structures. This procedure is used
- -- when several compilations are performed by the same process (by GNSA
- -- for ASIS, for example) to remove any existing mappings from a previous
- -- compilation.
+ -- Initialize all the internal data structures
procedure Add_Forbidden_File_Name (Name : File_Name_Type);
-- Indicate that a source file name is forbidden. This is used when there
diff --git a/gcc/ada/fname-sf.adb b/gcc/ada/fname-sf.adb
index dc0a3de..8feb150 100644
--- a/gcc/ada/fname-sf.adb
+++ b/gcc/ada/fname-sf.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute 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 c9b5081..dd8e4bf 100644
--- a/gcc/ada/fname-sf.ads
+++ b/gcc/ada/fname-sf.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute 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 48e2bc2..cfaf7c4 100644
--- a/gcc/ada/fname-uf.adb
+++ b/gcc/ada/fname-uf.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute 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 0bbd787..465e8ed 100644
--- a/gcc/ada/fname-uf.ads
+++ b/gcc/ada/fname-uf.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute 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 67d05e2..ae121c6 100644
--- a/gcc/ada/fname.adb
+++ b/gcc/ada/fname.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute 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.ads b/gcc/ada/fname.ads
index 7790fbf..6a908a5 100644
--- a/gcc/ada/fname.ads
+++ b/gcc/ada/fname.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb
index 8dc8a22..84502d8 100644
--- a/gcc/ada/freeze.adb
+++ b/gcc/ada/freeze.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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,52 +23,56 @@
-- --
------------------------------------------------------------------------------
-with Aspects; use Aspects;
-with Atree; use Atree;
-with Checks; use Checks;
-with Contracts; use Contracts;
-with Debug; use Debug;
-with Einfo; use Einfo;
-with Elists; use Elists;
-with Errout; use Errout;
-with Exp_Ch3; use Exp_Ch3;
-with Exp_Ch7; use Exp_Ch7;
-with Exp_Pakd; use Exp_Pakd;
-with Exp_Util; use Exp_Util;
-with Exp_Tss; use Exp_Tss;
-with Ghost; use Ghost;
-with Layout; use Layout;
-with Lib; use Lib;
-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 Rtsfind; use Rtsfind;
-with Sem; use Sem;
-with Sem_Aux; use Sem_Aux;
-with Sem_Cat; use Sem_Cat;
-with Sem_Ch3; use Sem_Ch3;
-with Sem_Ch6; use Sem_Ch6;
-with Sem_Ch7; use Sem_Ch7;
-with Sem_Ch8; use Sem_Ch8;
-with Sem_Ch13; use Sem_Ch13;
-with Sem_Eval; use Sem_Eval;
-with Sem_Mech; use Sem_Mech;
-with Sem_Prag; use Sem_Prag;
-with Sem_Res; use Sem_Res;
-with Sem_Util; use Sem_Util;
-with Sinfo; use Sinfo;
-with Snames; use Snames;
-with Stand; use Stand;
-with Stringt; use Stringt;
-with Targparm; use Targparm;
-with Tbuild; use Tbuild;
-with Ttypes; use Ttypes;
-with Uintp; use Uintp;
-with Urealp; use Urealp;
-with Warnsw; use Warnsw;
+with Aspects; use Aspects;
+with Atree; use Atree;
+with Checks; use Checks;
+with Contracts; use Contracts;
+with Debug; use Debug;
+with Einfo; use Einfo;
+with Einfo.Entities; use Einfo.Entities;
+with Einfo.Utils; use Einfo.Utils;
+with Elists; use Elists;
+with Errout; use Errout;
+with Exp_Ch3; use Exp_Ch3;
+with Exp_Ch7; use Exp_Ch7;
+with Exp_Pakd; use Exp_Pakd;
+with Exp_Util; use Exp_Util;
+with Exp_Tss; use Exp_Tss;
+with Ghost; use Ghost;
+with Layout; use Layout;
+with Lib; use Lib;
+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 Rtsfind; use Rtsfind;
+with Sem; use Sem;
+with Sem_Aux; use Sem_Aux;
+with Sem_Cat; use Sem_Cat;
+with Sem_Ch3; use Sem_Ch3;
+with Sem_Ch6; use Sem_Ch6;
+with Sem_Ch7; use Sem_Ch7;
+with Sem_Ch8; use Sem_Ch8;
+with Sem_Ch13; use Sem_Ch13;
+with Sem_Eval; use Sem_Eval;
+with Sem_Mech; use Sem_Mech;
+with Sem_Prag; use Sem_Prag;
+with Sem_Res; use Sem_Res;
+with Sem_Util; use Sem_Util;
+with Sinfo; use Sinfo;
+with Sinfo.Nodes; use Sinfo.Nodes;
+with Sinfo.Utils; use Sinfo.Utils;
+with Snames; use Snames;
+with Stand; use Stand;
+with Stringt; use Stringt;
+with Targparm; use Targparm;
+with Tbuild; use Tbuild;
+with Ttypes; use Ttypes;
+with Uintp; use Uintp;
+with Urealp; use Urealp;
+with Warnsw; use Warnsw;
package body Freeze is
@@ -182,6 +186,72 @@ package body Freeze is
-- the designated type. Otherwise freezing the access type does not freeze
-- the designated type.
+ function Should_Freeze_Type (Typ : Entity_Id; E : Entity_Id) return Boolean;
+ -- If Typ is in the current scope or in an instantiation, then return True.
+ -- ???Expression functions (represented by E) shouldn't freeze types in
+ -- general, but our current expansion and freezing model requires an early
+ -- freezing when the dispatch table is needed or when building an aggregate
+ -- with a subtype of Typ, so return True also in this case.
+ -- Note that expression function completions do freeze and are
+ -- handled in Sem_Ch6.Analyze_Expression_Function.
+
+ ------------------------
+ -- Should_Freeze_Type --
+ ------------------------
+
+ function Should_Freeze_Type
+ (Typ : Entity_Id; E : Entity_Id) return Boolean
+ is
+ function Is_Dispatching_Call_Or_Aggregate
+ (N : Node_Id) return Traverse_Result;
+ -- Return Abandon if N is a dispatching call to a subprogram
+ -- declared in the same scope as Typ or an aggregate whose type
+ -- is Typ.
+
+ --------------------------------------
+ -- Is_Dispatching_Call_Or_Aggregate --
+ --------------------------------------
+
+ function Is_Dispatching_Call_Or_Aggregate
+ (N : Node_Id) return Traverse_Result is
+ begin
+ if Nkind (N) = N_Function_Call
+ and then Present (Controlling_Argument (N))
+ and then Scope (Entity (Original_Node (Name (N))))
+ = Scope (Typ)
+ then
+ return Abandon;
+ elsif Nkind (N) = N_Aggregate
+ and then Base_Type (Etype (N)) = Base_Type (Typ)
+ then
+ return Abandon;
+ else
+ return OK;
+ end if;
+ end Is_Dispatching_Call_Or_Aggregate;
+
+ -------------------------
+ -- Need_Dispatch_Table --
+ -------------------------
+
+ function Need_Dispatch_Table is new
+ Traverse_Func (Is_Dispatching_Call_Or_Aggregate);
+ -- Return Abandon if the input expression requires access to
+ -- Typ's dispatch table.
+
+ Decl : constant Node_Id :=
+ (if No (E) then E else Original_Node (Unit_Declaration_Node (E)));
+
+ -- Start of processing for Should_Freeze_Type
+
+ begin
+ return Within_Scope (Typ, Current_Scope)
+ or else In_Instance
+ or else (Present (Decl)
+ and then Nkind (Decl) = N_Expression_Function
+ and then Need_Dispatch_Table (Expression (Decl)) = Abandon);
+ end Should_Freeze_Type;
+
procedure Process_Default_Expressions
(E : Entity_Id;
After : in out Node_Id);
@@ -478,12 +548,10 @@ package body Freeze is
Actuals := No_List;
end if;
- if Present (Formal) then
- while Present (Formal) loop
- Append (New_Occurrence_Of (Formal, Loc), Actuals);
- Next_Formal (Formal);
- end loop;
- end if;
+ while Present (Formal) loop
+ Append (New_Occurrence_Of (Formal, Loc), Actuals);
+ Next_Formal (Formal);
+ end loop;
-- If the renamed entity is an entry, inherit its profile. For other
-- renamings as bodies, both profiles must be subtype conformant, so it
@@ -789,7 +857,7 @@ package body Freeze is
-- Set size if not set already
- elsif Unknown_RM_Size (T) then
+ elsif not Known_RM_Size (T) then
Set_RM_Size (T, S);
end if;
end Set_Small_Size;
@@ -799,11 +867,8 @@ package body Freeze is
----------------
function Size_Known (T : Entity_Id) return Boolean is
- Index : Entity_Id;
Comp : Entity_Id;
Ctyp : Entity_Id;
- Low : Node_Id;
- High : Node_Id;
begin
if Size_Known_At_Compile_Time (T) then
@@ -850,8 +915,11 @@ package body Freeze is
-- thus may be packable).
declare
- Size : Uint := Component_Size (T);
- Dim : Uint;
+ Index : Entity_Id;
+ Low : Node_Id;
+ High : Node_Id;
+ Size : Uint := Component_Size (T);
+ Dim : Uint;
begin
Index := First_Index (T);
@@ -975,7 +1043,7 @@ package body Freeze is
if not Is_Constrained (T)
and then
No (Discriminant_Default_Value (First_Discriminant (T)))
- and then Unknown_RM_Size (T)
+ and then not Known_RM_Size (T)
then
return False;
end if;
@@ -1406,7 +1474,7 @@ package body Freeze is
-- pragmas force the creation of a wrapper for the inherited operation.
-- If the ancestor is being overridden, the pragmas are constructed only
-- to verify their legality, in case they contain calls to other
- -- primitives that may haven been overridden.
+ -- primitives that may have been overridden.
---------------------------------------
-- Build_Inherited_Condition_Pragmas --
@@ -1490,6 +1558,15 @@ package body Freeze is
then
Par_Prim := Overridden_Operation (Prim);
+ -- When the primitive is an LSP wrapper we climb to the parent
+ -- primitive that has the inherited contract.
+
+ if Is_Wrapper (Par_Prim)
+ and then Present (LSP_Subprogram (Par_Prim))
+ then
+ Par_Prim := LSP_Subprogram (Par_Prim);
+ end if;
+
-- Analyze the contract items of the overridden operation, before
-- they are rewritten as pragmas.
@@ -1528,6 +1605,15 @@ package body Freeze is
if not Comes_From_Source (Prim) and then Present (Alias (Prim)) then
Par_Prim := Alias (Prim);
+ -- When the primitive is an LSP wrapper we climb to the parent
+ -- primitive that has the inherited contract.
+
+ if Is_Wrapper (Par_Prim)
+ and then Present (LSP_Subprogram (Par_Prim))
+ then
+ Par_Prim := LSP_Subprogram (Par_Prim);
+ end if;
+
-- Analyze the contract items of the parent operation, and
-- determine whether a wrapper is needed. This is determined
-- when the condition is rewritten in sem_prag, using the
@@ -1561,14 +1647,22 @@ package body Freeze is
-- statement with a call.
declare
+ Alias_Id : constant Entity_Id := Ultimate_Alias (Prim);
Loc : constant Source_Ptr := Sloc (R);
Par_R : constant Node_Id := Parent (R);
New_Body : Node_Id;
New_Decl : Node_Id;
+ New_Id : Entity_Id;
New_Spec : Node_Id;
begin
+ -- The wrapper must be analyzed in the scope of its wrapped
+ -- primitive (to ensure its correct decoration).
+
+ Push_Scope (Scope (Prim));
+
New_Spec := Build_Overriding_Spec (Par_Prim, R);
+ New_Id := Defining_Entity (New_Spec);
New_Decl :=
Make_Subprogram_Declaration (Loc,
Specification => New_Spec);
@@ -1577,6 +1671,12 @@ package body Freeze is
-- type declaration that generates inherited operation. For
-- a null procedure, the declaration implies a null body.
+ -- Before insertion, do some minimal decoration of fields
+
+ Mutate_Ekind (New_Id, Ekind (Par_Prim));
+ Set_LSP_Subprogram (New_Id, Par_Prim);
+ Set_Is_Wrapper (New_Id);
+
if Nkind (New_Spec) = N_Procedure_Specification
and then Null_Present (New_Spec)
then
@@ -1592,7 +1692,18 @@ package body Freeze is
Insert_List_After_And_Analyze
(Par_R, New_List (New_Decl, New_Body));
+
+ -- Ensure correct decoration
+
+ pragma Assert (Present (Alias (Prim)));
+ pragma Assert (Present (Overridden_Operation (New_Id)));
+ pragma Assert (Overridden_Operation (New_Id) = Alias_Id);
end if;
+
+ pragma Assert (Is_Dispatching_Operation (Prim));
+ pragma Assert (Is_Dispatching_Operation (New_Id));
+
+ Pop_Scope;
end;
end if;
@@ -1754,8 +1865,7 @@ package body Freeze is
Typ := Etype (Name (Par));
if not Is_Full_Access (Typ)
- and then not (Is_Entity_Name (Name (Par))
- and then Is_Full_Access (Entity (Name (Par))))
+ and then not Is_Full_Access_Object (Name (Par))
then
return False;
end if;
@@ -2069,7 +2179,7 @@ package body Freeze is
elsif Is_Concurrent_Type (E) then
Item := First_Entity (E);
while Present (Item) loop
- if (Is_Entry (Item) or else Is_Subprogram (Item))
+ if Is_Subprogram_Or_Entry (Item)
and then not Default_Expressions_Processed (Item)
then
Process_Default_Expressions (Item, After);
@@ -2195,6 +2305,14 @@ package body Freeze is
-- which is the current instance type can only be applied when the type
-- is limited.
+ procedure Check_No_Parts_Violations
+ (Typ : Entity_Id; Aspect_No_Parts : Aspect_Id) with
+ Pre => Aspect_No_Parts in
+ Aspect_No_Controlled_Parts | Aspect_No_Task_Parts;
+ -- Check that Typ does not violate the semantics of the specified
+ -- Aspect_No_Parts (No_Controlled_Parts or No_Task_Parts) when it is
+ -- specified on Typ or one of its ancestors.
+
procedure Check_Suspicious_Convention (Rec_Type : Entity_Id);
-- Give a warning for pragma Convention with language C or C++ applied
-- to a discriminated record type. This is suppressed for the unchecked
@@ -2415,6 +2533,383 @@ package body Freeze is
end if;
end Check_Current_Instance;
+ -------------------------------
+ -- Check_No_Parts_Violations --
+ -------------------------------
+
+ procedure Check_No_Parts_Violations
+ (Typ : Entity_Id; Aspect_No_Parts : Aspect_Id)
+ is
+
+ function Find_Aspect_No_Parts
+ (Typ : Entity_Id) return Node_Id;
+ -- Search for Aspect_No_Parts on a given type. When
+ -- the aspect is not explicity specified Empty is returned.
+
+ function Get_Aspect_No_Parts_Value
+ (Typ : Entity_Id) return Entity_Id;
+ -- Obtain the value for the Aspect_No_Parts on a given
+ -- type. When the aspect is not explicitly specified Empty is
+ -- returned.
+
+ function Has_Aspect_No_Parts
+ (Typ : Entity_Id) return Boolean;
+ -- Predicate function which identifies whether No_Parts
+ -- is explicitly specified on a given type.
+
+ -------------------------------------
+ -- Find_Aspect_No_Parts --
+ -------------------------------------
+
+ function Find_Aspect_No_Parts
+ (Typ : Entity_Id) return Node_Id
+ is
+ Partial_View : constant Entity_Id :=
+ Incomplete_Or_Partial_View (Typ);
+
+ Aspect_Spec : Entity_Id :=
+ Find_Aspect (Typ, Aspect_No_Parts);
+ Curr_Aspect_Spec : Entity_Id;
+ begin
+
+ -- Examine Typ's associated node, when present, since aspect
+ -- specifications do not get transferred when nodes get rewritten.
+
+ -- For example, this can happen in the expansion of array types
+
+ if No (Aspect_Spec)
+ and then Present (Associated_Node_For_Itype (Typ))
+ and then Nkind (Associated_Node_For_Itype (Typ))
+ = N_Full_Type_Declaration
+ then
+ Aspect_Spec :=
+ Find_Aspect
+ (Id => Defining_Identifier
+ (Associated_Node_For_Itype (Typ)),
+ A => Aspect_No_Parts);
+ end if;
+
+ -- Examine aspects specifications on private type declarations
+
+ -- Should Find_Aspect be improved to handle this case ???
+
+ if No (Aspect_Spec)
+ and then Present (Partial_View)
+ and then Present
+ (Aspect_Specifications
+ (Declaration_Node
+ (Partial_View)))
+ then
+ Curr_Aspect_Spec :=
+ First
+ (Aspect_Specifications
+ (Declaration_Node
+ (Partial_View)));
+
+ -- Search through aspects present on the private type
+
+ while Present (Curr_Aspect_Spec) loop
+ if Get_Aspect_Id (Curr_Aspect_Spec)
+ = Aspect_No_Parts
+ then
+ Aspect_Spec := Curr_Aspect_Spec;
+ exit;
+ end if;
+
+ Next (Curr_Aspect_Spec);
+ end loop;
+
+ end if;
+
+ -- When errors are posted on the aspect return Empty
+
+ if Error_Posted (Aspect_Spec) then
+ return Empty;
+ end if;
+
+ return Aspect_Spec;
+ end Find_Aspect_No_Parts;
+
+ ------------------------------------------
+ -- Get_Aspect_No_Parts_Value --
+ ------------------------------------------
+
+ function Get_Aspect_No_Parts_Value
+ (Typ : Entity_Id) return Entity_Id
+ is
+ Aspect_Spec : constant Entity_Id :=
+ Find_Aspect_No_Parts (Typ);
+ begin
+
+ -- Return the value of the aspect when present
+
+ if Present (Aspect_Spec) then
+
+ -- No expression is the same as True
+
+ if No (Expression (Aspect_Spec)) then
+ return Standard_True;
+ end if;
+
+ -- Assume its expression has already been constant folded into
+ -- a Boolean value and return its value.
+
+ return Entity (Expression (Aspect_Spec));
+ end if;
+
+ -- Otherwise, the aspect is not specified - so return Empty
+
+ return Empty;
+ end Get_Aspect_No_Parts_Value;
+
+ ------------------------------------
+ -- Has_Aspect_No_Parts --
+ ------------------------------------
+
+ function Has_Aspect_No_Parts
+ (Typ : Entity_Id) return Boolean
+ is (Present (Find_Aspect_No_Parts (Typ)));
+
+ -- Generic instances
+
+ -------------------------------------------
+ -- Get_Generic_Formal_Types_In_Hierarchy --
+ -------------------------------------------
+
+ function Get_Generic_Formal_Types_In_Hierarchy
+ is new Collect_Types_In_Hierarchy (Predicate => Is_Generic_Formal);
+ -- Return a list of all types within a given type's hierarchy which
+ -- are generic formals.
+
+ ----------------------------------------
+ -- Get_Types_With_Aspect_In_Hierarchy --
+ ----------------------------------------
+
+ function Get_Types_With_Aspect_In_Hierarchy
+ is new Collect_Types_In_Hierarchy
+ (Predicate => Has_Aspect_No_Parts);
+ -- Returns a list of all types within a given type's hierarchy which
+ -- have the Aspect_No_Parts specified.
+
+ -- Local declarations
+
+ Aspect_Value : Entity_Id;
+ Curr_Value : Entity_Id;
+ Curr_Typ_Elmt : Elmt_Id;
+ Curr_Body_Elmt : Elmt_Id;
+ Curr_Formal_Elmt : Elmt_Id;
+ Gen_Bodies : Elist_Id;
+ Gen_Formals : Elist_Id;
+ Scop : Entity_Id;
+ Types_With_Aspect : Elist_Id;
+
+ -- Start of processing for Check_No_Parts_Violations
+
+ begin
+ -- Nothing to check if the type is elementary or artificial
+
+ if Is_Elementary_Type (Typ) or else not Comes_From_Source (Typ) then
+ return;
+ end if;
+
+ Types_With_Aspect := Get_Types_With_Aspect_In_Hierarchy (Typ);
+
+ -- Nothing to check if there are no types with No_Parts specified
+
+ if Is_Empty_Elmt_List (Types_With_Aspect) then
+ return;
+ end if;
+
+ -- Set name for all errors below
+
+ Error_Msg_Name_1 := Aspect_Names (Aspect_No_Parts);
+
+ -- Obtain the aspect value for No_Parts for comparison
+
+ Aspect_Value :=
+ Get_Aspect_No_Parts_Value
+ (Node (First_Elmt (Types_With_Aspect)));
+
+ -- When the value is True and there are controlled/task parts or the
+ -- type itself is controlled/task, trigger the appropriate error.
+
+ if Aspect_Value = Standard_True then
+ if Aspect_No_Parts = Aspect_No_Controlled_Parts then
+ if Is_Controlled (Typ) or else Has_Controlled_Component (Typ)
+ then
+ Error_Msg_N
+ ("aspect % applied to controlled type &", Typ);
+ end if;
+
+ elsif Aspect_No_Parts = Aspect_No_Task_Parts then
+ if Has_Task (Typ) then
+ Error_Msg_N
+ ("aspect % applied to task type &", Typ);
+ end if;
+
+ else
+ raise Program_Error;
+ end if;
+ end if;
+
+ -- Move through Types_With_Aspect - checking that the value specified
+ -- for their corresponding Aspect_No_Parts do not override each
+ -- other.
+
+ Curr_Typ_Elmt := First_Elmt (Types_With_Aspect);
+ while Present (Curr_Typ_Elmt) loop
+ Curr_Value :=
+ Get_Aspect_No_Parts_Value (Node (Curr_Typ_Elmt));
+
+ -- Compare the aspect value against the current type
+
+ if Curr_Value /= Aspect_Value then
+ Error_Msg_NE
+ ("cannot override aspect % of "
+ & "ancestor type &", Typ, Node (Curr_Typ_Elmt));
+ return;
+ end if;
+
+ Next_Elmt (Curr_Typ_Elmt);
+ end loop;
+
+ -- Issue an error if the aspect applies to a type declared inside a
+ -- generic body and if said type derives from or has a component
+ -- of ageneric formal type - since those are considered to have
+ -- controlled/task parts and have Aspect_No_Parts specified as
+ -- False by default (RM H.4.1(4/5) is about the language-defined
+ -- No_Controlled_Parts aspect, and we are using the same rules for
+ -- No_Task_Parts).
+
+ -- We do not check tagged types since deriving from a formal type
+ -- within an enclosing generic unit is already illegal
+ -- (RM 3.9.1 (4/2)).
+
+ if Aspect_Value = Standard_True
+ and then In_Generic_Body (Typ)
+ and then not Is_Tagged_Type (Typ)
+ then
+ Gen_Bodies := New_Elmt_List;
+ Gen_Formals :=
+ Get_Generic_Formal_Types_In_Hierarchy
+ (Typ => Typ,
+ Examine_Components => True);
+
+ -- Climb scopes collecting generic bodies
+
+ Scop := Scope (Typ);
+ while Present (Scop) and then Scop /= Standard_Standard loop
+
+ -- Generic package body
+
+ if Ekind (Scop) = E_Generic_Package
+ and then In_Package_Body (Scop)
+ then
+ Append_Elmt (Scop, Gen_Bodies);
+
+ -- Generic subprogram body
+
+ elsif Is_Generic_Subprogram (Scop) then
+ Append_Elmt (Scop, Gen_Bodies);
+ end if;
+
+ Scop := Scope (Scop);
+ end loop;
+
+ -- Warn about the improper use of Aspect_No_Parts on a type
+ -- declaration deriving from or that has a component of a generic
+ -- formal type within the formal type's corresponding generic
+ -- body by moving through all formal types in Typ's hierarchy and
+ -- checking if they are formals in any of the enclosing generic
+ -- bodies.
+
+ -- However, a special exception gets made for formal types which
+ -- derive from a type which has Aspect_No_Parts True.
+
+ -- For example:
+
+ -- generic
+ -- type Form is private;
+ -- package G is
+ -- type Type_A is new Form with No_Controlled_Parts; -- OK
+ -- end;
+ --
+ -- package body G is
+ -- type Type_B is new Form with No_Controlled_Parts; -- ERROR
+ -- end;
+
+ -- generic
+ -- type Form is private;
+ -- package G is
+ -- type Type_A is record C : Form; end record
+ -- with No_Controlled_Parts; -- OK
+ -- end;
+ --
+ -- package body G is
+ -- type Type_B is record C : Form; end record
+ -- with No_Controlled_Parts; -- ERROR
+ -- end;
+
+ -- type Root is tagged null record with No_Controlled_Parts;
+ --
+ -- generic
+ -- type Form is new Root with private;
+ -- package G is
+ -- type Type_A is record C : Form; end record
+ -- with No_Controlled_Parts; -- OK
+ -- end;
+ --
+ -- package body G is
+ -- type Type_B is record C : Form; end record
+ -- with No_Controlled_Parts; -- OK
+ -- end;
+
+ Curr_Formal_Elmt := First_Elmt (Gen_Formals);
+ while Present (Curr_Formal_Elmt) loop
+
+ Curr_Body_Elmt := First_Elmt (Gen_Bodies);
+ while Present (Curr_Body_Elmt) loop
+
+ -- Obtain types in the formal type's hierarchy which have
+ -- the aspect specified.
+
+ Types_With_Aspect :=
+ Get_Types_With_Aspect_In_Hierarchy
+ (Node (Curr_Formal_Elmt));
+
+ -- We found a type declaration in a generic body where both
+ -- Aspect_No_Parts is true and one of its ancestors is a
+ -- generic formal type.
+
+ if Scope (Node (Curr_Formal_Elmt)) =
+ Node (Curr_Body_Elmt)
+
+ -- Check that no ancestors of the formal type have
+ -- Aspect_No_Parts True before issuing the error.
+
+ and then (Is_Empty_Elmt_List (Types_With_Aspect)
+ or else
+ Get_Aspect_No_Parts_Value
+ (Node (First_Elmt (Types_With_Aspect)))
+ = Standard_False)
+ then
+ Error_Msg_Node_1 := Typ;
+ Error_Msg_Node_2 := Node (Curr_Formal_Elmt);
+ Error_Msg
+ ("aspect % cannot be applied to "
+ & "type & which has an ancestor or component of "
+ & "formal type & within the formal type's "
+ & "corresponding generic body", Sloc (Typ));
+ end if;
+
+ Next_Elmt (Curr_Body_Elmt);
+ end loop;
+
+ Next_Elmt (Curr_Formal_Elmt);
+ end loop;
+ end if;
+ end Check_No_Parts_Violations;
+
---------------------------------
-- Check_Suspicious_Convention --
---------------------------------
@@ -2812,7 +3307,7 @@ package body Freeze is
-- cases of types whose alignment exceeds their size (the
-- padded type cases).
- if Csiz /= 0 then
+ if Csiz /= 0 and then Known_Alignment (Ctyp) then
declare
A : constant Uint := Alignment_In_Bits (Ctyp);
begin
@@ -2983,9 +3478,12 @@ package body Freeze is
-- Processing that is done only for subtypes
else
- -- Acquire alignment from base type
+ -- Acquire alignment from base type. Known_Alignment of the base
+ -- type is False for Wide_String, for example.
- if Unknown_Alignment (Arr) then
+ if not Known_Alignment (Arr)
+ and then Known_Alignment (Base_Type (Arr))
+ then
Set_Alignment (Arr, Alignment (Base_Type (Arr)));
Adjust_Esize_Alignment (Arr);
end if;
@@ -3147,7 +3645,8 @@ package body Freeze is
end if;
if not Has_Alignment_Clause (Arr) then
- Set_Alignment (Arr, Alignment (Packed_Array_Impl_Type (Arr)));
+ Copy_Alignment
+ (To => Arr, From => Packed_Array_Impl_Type (Arr));
end if;
end if;
@@ -3620,7 +4119,9 @@ package body Freeze is
Set_Etype (Formal, F_Type);
end if;
- if not From_Limited_With (F_Type) then
+ if not From_Limited_With (F_Type)
+ and then Should_Freeze_Type (F_Type, E)
+ then
Freeze_And_Append (F_Type, N, Result);
end if;
@@ -3644,9 +4145,10 @@ package body Freeze is
elsif not After_Last_Declaration
and then not Freezing_Library_Level_Tagged_Type
then
- Error_Msg_Node_1 := F_Type;
- Error_Msg
- ("type & must be fully defined before this point", Loc);
+ Error_Msg_NE
+ ("type & must be fully defined before this point",
+ N,
+ F_Type);
end if;
end if;
@@ -3750,8 +4252,8 @@ package body Freeze is
Error_Msg_NE ("?x?type of argument& is unconstrained array",
Warn_Node, Formal);
- Error_Msg_NE ("?x?foreign caller must pass bounds explicitly",
- Warn_Node, Formal);
+ Error_Msg_N ("\?x?foreign caller must pass bounds explicitly",
+ Warn_Node);
Error_Msg_Qual_Level := 0;
end if;
@@ -3797,7 +4299,9 @@ package body Freeze is
Set_Etype (E, R_Type);
end if;
- Freeze_And_Append (R_Type, N, Result);
+ if Should_Freeze_Type (R_Type, E) then
+ Freeze_And_Append (R_Type, N, Result);
+ end if;
-- Check suspicious return type for C function
@@ -3931,8 +4435,7 @@ package body Freeze is
and then Convention (E) /= Convention_Intrinsic
- -- Assume that ASM interface knows what it is doing. This deals
- -- with e.g. unsigned.ads in the AAMP back end.
+ -- Assume that ASM interface knows what it is doing
and then Convention (E) /= Convention_Assembler
then
@@ -4003,11 +4506,6 @@ package body Freeze is
-- Set True if we find at least one component with no component
-- clause (used to warn about useless Pack pragmas).
- function Check_Allocator (N : Node_Id) return Node_Id;
- -- If N is an allocator, possibly wrapped in one or more level of
- -- qualified expression(s), return the inner allocator node, else
- -- return Empty.
-
procedure Check_Itype (Typ : Entity_Id);
-- If the component subtype is an access to a constrained subtype of
-- an already frozen type, make the subtype frozen as well. It might
@@ -4023,25 +4521,6 @@ package body Freeze is
-- variants referenceed by the Variant_Part VP are frozen. This is
-- a recursive routine to deal with nested variants.
- ---------------------
- -- Check_Allocator --
- ---------------------
-
- function Check_Allocator (N : Node_Id) return Node_Id is
- Inner : Node_Id;
- begin
- Inner := N;
- loop
- if Nkind (Inner) = N_Allocator then
- return Inner;
- elsif Nkind (Inner) = N_Qualified_Expression then
- Inner := Expression (Inner);
- else
- return Empty;
- end if;
- end loop;
- end Check_Allocator;
-
-----------------
-- Check_Itype --
-----------------
@@ -4356,22 +4835,24 @@ package body Freeze is
elsif Is_Access_Type (Etype (Comp))
and then Present (Parent (Comp))
+ and then
+ Nkind (Parent (Comp))
+ in N_Component_Declaration | N_Discriminant_Specification
and then Present (Expression (Parent (Comp)))
then
declare
Alloc : constant Node_Id :=
- Check_Allocator (Expression (Parent (Comp)));
+ Unqualify (Expression (Parent (Comp)));
begin
- if Present (Alloc) then
+ if Nkind (Alloc) = N_Allocator then
-- If component is pointer to a class-wide type, freeze
-- the specific type in the expression being allocated.
-- The expression may be a subtype indication, in which
-- case freeze the subtype mark.
- if Is_Class_Wide_Type
- (Designated_Type (Etype (Comp)))
+ if Is_Class_Wide_Type (Designated_Type (Etype (Comp)))
then
if Is_Entity_Name (Expression (Alloc)) then
Freeze_And_Append
@@ -4383,17 +4864,14 @@ package body Freeze is
(Entity (Subtype_Mark (Expression (Alloc))),
N, Result);
end if;
-
elsif Is_Itype (Designated_Type (Etype (Comp))) then
Check_Itype (Etype (Comp));
-
else
Freeze_And_Append
(Designated_Type (Etype (Comp)), N, Result);
end if;
end if;
end;
-
elsif Is_Access_Type (Etype (Comp))
and then Is_Itype (Designated_Type (Etype (Comp)))
then
@@ -5591,11 +6069,12 @@ package body Freeze is
-- Here for other than a subprogram or type
else
- -- If entity has a type, and it is not a generic unit, then freeze
- -- it first (RM 13.14(10)).
+ -- If entity has a type declared in the current scope, and it is
+ -- not a generic unit, then freeze it first.
if Present (Etype (E))
and then Ekind (E) /= E_Generic_Function
+ and then Within_Scope (Etype (E), Current_Scope)
then
Freeze_And_Append (Etype (E), N, Result);
@@ -6829,6 +7308,18 @@ package body Freeze is
end;
end if;
+ -- Verify at this point that No_Controlled_Parts and No_Task_Parts,
+ -- when specified on the current type or one of its ancestors, has
+ -- not been overridden and that no violation of the aspect has
+ -- occurred.
+
+ -- It is important that we perform the checks here after the type has
+ -- been processed because if said type depended on a private type it
+ -- will not have been marked controlled or having tasks.
+
+ Check_No_Parts_Violations (E, Aspect_No_Controlled_Parts);
+ Check_No_Parts_Violations (E, Aspect_No_Task_Parts);
+
-- End of freeze processing for type entities
end if;
@@ -6875,10 +7366,9 @@ package body Freeze is
begin
Comp := First_Component (E);
while Present (Comp) loop
- Typ := Etype (Comp);
+ Typ := Etype (Comp);
- if Ekind (Comp) = E_Component
- and then Is_Access_Type (Typ)
+ if Is_Access_Type (Typ)
and then Scope (Typ) /= E
and then Base_Type (Designated_Type (Typ)) = E
and then Is_Itype (Designated_Type (Typ))
@@ -7105,6 +7595,7 @@ 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 Is_TSS (Id, TSS_Put_Image)
or else Nkind (Original_Node (P)) =
N_Subprogram_Renaming_Declaration)
then
@@ -7204,7 +7695,7 @@ package body Freeze is
Typ := Empty;
- if Nkind (N) in N_Has_Etype then
+ if Nkind (N) in N_Has_Etype and then Present (Etype (N)) then
if not Is_Frozen (Etype (N)) then
Typ := Etype (N);
@@ -7225,6 +7716,7 @@ package body Freeze is
-- an initialization procedure from freezing the variable.
if Is_Entity_Name (N)
+ and then Present (Entity (N))
and then not Is_Frozen (Entity (N))
and then (Nkind (N) /= N_Identifier
or else Comes_From_Source (N)
@@ -7411,7 +7903,7 @@ package body Freeze is
-- tree. This is an unusual case, but there are some legitimate
-- situations in which this occurs, notably when the expressions
-- in the range of a type declaration are resolved. We simply
- -- ignore the freeze request in this case. Is this right ???
+ -- ignore the freeze request in this case.
if No (Parent_P) then
return;
@@ -7671,7 +8163,7 @@ package body Freeze is
end case;
-- We fall through the case if we did not yet find the proper
- -- place in the free for inserting the freeze node, so climb.
+ -- place in the tree for inserting the freeze node, so climb.
P := Parent_P;
end loop;
@@ -8144,7 +8636,7 @@ package body Freeze is
-- If Esize of a subtype has not previously been set, set it now
- if Unknown_Esize (Typ) then
+ if not Known_Esize (Typ) then
Atype := Ancestor_Subtype (Typ);
if Present (Atype) then
@@ -8639,7 +9131,7 @@ package body Freeze is
-- Set Esize to calculated size if not set already
- if Unknown_Esize (Typ) then
+ if not Known_Esize (Typ) then
Init_Esize (Typ, Actual_Size);
end if;
@@ -9082,15 +9574,18 @@ package body Freeze is
end if;
-- Ensure that all anonymous access-to-subprogram types inherit the
- -- convention of their related subprogram (RM 6.3.1 13.1/3). This is
+ -- convention of their related subprogram (RM 6.3.1(13.1/5)). This is
-- not done for a defaulted convention Ada because those types also
-- default to Ada. Convention Protected must not be propagated when
-- the subprogram is an entry because this would be illegal. The only
-- way to force convention Protected on these kinds of types is to
- -- include keyword "protected" in the access definition.
+ -- include keyword "protected" in the access definition. Conventions
+ -- Entry and Intrinsic are also not propagated (specified by AI12-0207).
if Convention (E) /= Convention_Ada
and then Convention (E) /= Convention_Protected
+ and then Convention (E) /= Convention_Entry
+ and then Convention (E) /= Convention_Intrinsic
then
Set_Profile_Convention (E);
end if;
diff --git a/gcc/ada/freeze.ads b/gcc/ada/freeze.ads
index 448d1ed..6f4feca 100644
--- a/gcc/ada/freeze.ads
+++ b/gcc/ada/freeze.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute 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 b194741..a65b3e1 100644
--- a/gcc/ada/frontend.adb
+++ b/gcc/ada/frontend.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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,47 +25,49 @@
with System.Strings; use System.Strings;
-with Atree; use Atree;
+with Atree; use Atree;
with Checks;
with CStand;
-with Debug; use Debug;
+with Debug; use Debug;
with Elists;
with Exp_Dbug;
with Exp_Unst;
with Fmap;
with Fname.UF;
-with Ghost; use Ghost;
-with Inline; use Inline;
-with Lib; use Lib;
-with Lib.Load; use Lib.Load;
+with Ghost; use Ghost;
+with Inline; use Inline;
+with Lib; use Lib;
+with Lib.Load; use Lib.Load;
with Lib.Xref;
-with Live; use Live;
-with Namet; use Namet;
-with Nlists; use Nlists;
-with Opt; use Opt;
+with Live; use Live;
+with Namet; use Namet;
+with Nlists; use Nlists;
+with Opt; use Opt;
with Osint;
with Par;
with Prep;
with Prepcomp;
-with Restrict; use Restrict;
-with Rident; use Rident;
+with Restrict; use Restrict;
+with Rident; use Rident;
with Rtsfind;
-with Snames; use Snames;
+with Snames; use Snames;
with Sprint;
-with Scn; use Scn;
-with Sem; use Sem;
+with Scn; use Scn;
+with Sem; use Sem;
with Sem_Aux;
with Sem_Ch8;
with Sem_SCIL;
-with Sem_Elab; use Sem_Elab;
-with Sem_Prag; use Sem_Prag;
+with Sem_Elab; use Sem_Elab;
+with Sem_Prag; use Sem_Prag;
with Sem_Warn;
-with Sinfo; use Sinfo;
-with Sinput; use Sinput;
-with Sinput.L; use Sinput.L;
+with Sinfo; use Sinfo;
+with Sinfo.Nodes; use Sinfo.Nodes;
+with Sinfo.Utils; use Sinfo.Utils;
+with Sinput; use Sinput;
+with Sinput.L; use Sinput.L;
with SCIL_LL;
-with Tbuild; use Tbuild;
-with Types; use Types;
+with Tbuild; use Tbuild;
+with Types; use Types;
with VAST;
procedure Frontend is
diff --git a/gcc/ada/frontend.ads b/gcc/ada/frontend.ads
index 6ec3969..9dcd30d 100644
--- a/gcc/ada/frontend.ads
+++ b/gcc/ada/frontend.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute 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 d88c354..765654f 100644
--- a/gcc/ada/gcc-interface/Make-lang.in
+++ b/gcc/ada/gcc-interface/Make-lang.in
@@ -58,17 +58,45 @@ WARN_ADAFLAGS= -W -Wall
# need to be built by a recent/matching native so we might as well leave the
# checks fully active.
+STAGE1=False
+GNATBIND_FLAGS=
+GNATLIB=
+
ifeq ($(CROSS),)
-ADAFLAGS= $(COMMON_ADAFLAGS) -gnatwns
+ ADAFLAGS=$(COMMON_ADAFLAGS) -gnatwns
+
+ ifeq ($(if $(wildcard ../stage_current),$(shell cat ../stage_current),stage1),stage1)
+ STAGE1=True
+ GNATBIND_FLAGS=-t
+ endif
else
-ADAFLAGS= $(COMMON_ADAFLAGS)
+ ADAFLAGS=$(COMMON_ADAFLAGS)
endif
ALL_ADAFLAGS = \
$(CFLAGS) $(ADA_CFLAGS) $(ADAFLAGS) $(CHECKING_ADAFLAGS) $(WARN_ADAFLAGS)
FORCE_DEBUG_ADAFLAGS = -g
ADA_CFLAGS =
-ADA_INCLUDES = -nostdinc -I- -I. -Iada/generated -Iada -Iada/gcc-interface -I$(srcdir)/ada -I$(srcdir)/ada/gcc-interface -Iada/libgnat -I$(srcdir)/ada/libgnat
+COMMON_ADA_INCLUDES = -I- -I. -Iada/generated -Iada -I$(srcdir)/ada
+
+STAGE1_LIBS=
+
+ifeq ($(strip $(filter-out linux%,$(host_os))),)
+ STAGE1_LIBS=-ldl
+endif
+
+ifeq ($(strip $(filter-out hpux%,$(host_os))),)
+ STAGE1_LIBS=/usr/lib/libcl.a
+endif
+
+ifeq ($(STAGE1),True)
+ ADA_INCLUDES=$(COMMON_ADA_INCLUDES)
+ adalib=$(dir $(shell $(CC) -print-libgcc-file-name))adalib
+ GNATLIB=$(adalib)/$(if $(wildcard $(adalib)/libgnat.a),libgnat.a,libgnat.so) $(STAGE1_LIBS)
+else
+ ADA_INCLUDES=-nostdinc $(COMMON_ADA_INCLUDES) -Iada/libgnat -I$(srcdir)/ada/libgnat -Iada/gcc-interface -I$(srcdir)/ada/gcc-interface
+endif
+
GNATLIBFLAGS= -W -Wall -gnatpg -nostdinc
GNATLIBCFLAGS= -g -O2 $(TCFLAGS)
ADA_INCLUDE_DIR = $(libsubdir)/adainclude
@@ -242,22 +270,29 @@ GCC_LLINK=$(LLINKER) $(GCC_LINKERFLAGS) $(LDFLAGS)
# Languages-specific object files for Ada.
-# Object files for gnat1 from C sources.
-GNAT1_C_OBJS = ada/adadecode.o ada/adaint.o ada/argv.o ada/cio.o \
- ada/cstreams.o ada/env.o ada/init.o ada/initialize.o ada/raise.o \
- ada/raise-gcc.o \
- ada/seh_init.o ada/targext.o ada/cuintp.o ada/decl.o ada/rtfinal.o \
- ada/rtinit.o ada/misc.o ada/utils.o ada/utils2.o ada/trans.o ada/targtyps.o
+# Object files from C sources that are used by gnat1
+# Most of the non-gigi files are needed because of s-crtl.o and s-os_lib.o
+# But adadecode.o should not be needed with sufficiently recent compilers
+GNAT1_C_OBJS = \
+ ada/cuintp.o \
+ ada/decl.o \
+ ada/misc.o \
+ ada/utils.o \
+ ada/utils2.o \
+ ada/trans.o \
+ ada/targtyps.o \
+ ada/adadecode.o \
+ ada/adaint.o \
+ ada/argv.o \
+ ada/cio.o \
+ ada/cstreams.o \
+ ada/env.o \
+ ada/errno.o \
+ ada/targext.o \
+ ada/version.o
# Object files from Ada sources that are used by gnat1
GNAT_ADA_OBJS = \
- ada/libgnat/a-charac.o \
- ada/libgnat/a-chlat1.o \
- ada/libgnat/a-elchha.o \
- ada/libgnat/a-except.o \
- ada/libgnat/a-exctra.o \
- ada/libgnat/a-ioexce.o \
- ada/libgnat/ada.o \
ada/spark_xrefs.o \
ada/ali.o \
ada/alloc.o \
@@ -272,6 +307,8 @@ GNAT_ADA_OBJS = \
ada/cstand.o \
ada/debug.o \
ada/debug_a.o \
+ ada/einfo-entities.o \
+ ada/einfo-utils.o \
ada/einfo.o \
ada/elists.o \
ada/err_vars.o \
@@ -316,25 +353,13 @@ GNAT_ADA_OBJS = \
ada/fname.o \
ada/freeze.o \
ada/frontend.o \
- ada/libgnat/g-byorma.o \
- ada/libgnat/g-dynhta.o \
- ada/libgnat/g-graphs.o \
- ada/libgnat/g-hesora.o \
- ada/libgnat/g-htable.o \
- ada/libgnat/g-lists.o \
- ada/libgnat/g-sets.o \
- ada/libgnat/g-spchge.o \
- ada/libgnat/g-speche.o \
- ada/libgnat/g-u3spch.o \
ada/get_targ.o \
ada/ghost.o \
ada/gnat_cuda.o \
- ada/libgnat/gnat.o \
ada/gnatvsn.o \
ada/hostparm.o \
ada/impunit.o \
ada/inline.o \
- ada/libgnat/interfac.o \
ada/itypes.o \
ada/krunch.o \
ada/layout.o \
@@ -362,67 +387,13 @@ GNAT_ADA_OBJS = \
ada/restrict.o \
ada/rident.o \
ada/rtsfind.o \
- ada/libgnat/s-addope.o \
- ada/libgnat/s-addima.o \
- ada/libgnat/s-assert.o \
- ada/libgnat/s-bitops.o \
- ada/libgnat/s-carun8.o \
- ada/libgnat/s-casuti.o \
- ada/libgnat/s-conca2.o \
- ada/libgnat/s-conca3.o \
- ada/libgnat/s-conca4.o \
- ada/libgnat/s-conca5.o \
- ada/libgnat/s-conca6.o \
- ada/libgnat/s-conca7.o \
- ada/libgnat/s-conca8.o \
- ada/libgnat/s-conca9.o \
- ada/libgnat/s-crc32.o \
- ada/libgnat/s-crtl.o \
- ada/libgnat/s-excdeb.o \
- ada/libgnat/s-except.o \
- ada/libgnat/s-exctab.o \
- ada/libgnat/s-excmac.o \
- ada/libgnat/s-htable.o \
- ada/libgnat/s-imenne.o \
- ada/libgnat/s-imgenu.o \
- ada/libgnat/s-imgint.o \
- ada/libgnat/s-mastop.o \
- ada/libgnat/s-memory.o \
- ada/libgnat/s-os_lib.o \
- ada/libgnat/s-parame.o \
- ada/libgnat/s-purexc.o \
- ada/libgnat/s-restri.o \
- ada/libgnat/s-secsta.o \
- ada/libgnat/s-soflin.o \
- ada/libgnat/s-soliin.o \
- ada/libgnat/s-sopco3.o \
- ada/libgnat/s-sopco4.o \
- ada/libgnat/s-sopco5.o \
- ada/libgnat/s-stache.o \
- ada/libgnat/s-stalib.o \
- ada/libgnat/s-stoele.o \
- ada/libgnat/s-strcom.o \
- ada/libgnat/s-strhas.o \
- ada/libgnat/s-string.o \
- ada/libgnat/s-strops.o \
- ada/libgnat/s-traceb.o \
- ada/libgnat/s-traent.o \
- ada/libgnat/s-trasym.o \
- ada/libgnat/s-unstyp.o \
- ada/libgnat/s-utf_32.o \
- ada/libgnat/s-valint.o \
- ada/libgnat/s-valuns.o \
- ada/libgnat/s-valuti.o \
- ada/libgnat/s-wchcnv.o \
- ada/libgnat/s-wchcon.o \
- ada/libgnat/s-wchjis.o \
- ada/libgnat/s-wchstw.o \
ada/scans.o \
ada/scil_ll.o \
ada/scn.o \
ada/scng.o \
ada/scos.o \
ada/sdefault.o \
+ ada/seinfo.o \
ada/sem.o \
ada/sem_aggr.o \
ada/sem_attr.o \
@@ -458,6 +429,8 @@ GNAT_ADA_OBJS = \
ada/sem_warn.o \
ada/set_targ.o \
ada/sinfo-cn.o \
+ ada/sinfo-nodes.o \
+ ada/sinfo-utils.o \
ada/sinfo.o \
ada/sinput-d.o \
ada/sinput-l.o \
@@ -471,12 +444,10 @@ GNAT_ADA_OBJS = \
ada/stylesw.o \
ada/switch-c.o \
ada/switch.o \
- ada/gcc-interface/system.o \
ada/table.o \
ada/targparm.o \
ada/tbuild.o \
ada/treepr.o \
- ada/treeprs.o \
ada/ttypes.o \
ada/types.o \
ada/uintp.o \
@@ -486,7 +457,97 @@ GNAT_ADA_OBJS = \
ada/validsw.o \
ada/vast.o \
ada/warnsw.o \
- ada/widechar.o
+ ada/widechar.o \
+ ada/gnat.o \
+ ada/g-dynhta.o \
+ ada/g-graphs.o \
+ ada/g-lists.o \
+ ada/g-sets.o \
+ ada/s-casuti.o \
+ ada/s-crtl.o \
+ ada/s-os_lib.o \
+ ada/s-pehage.o \
+ ada/s-utf_32.o
+
+ifeq ($(STAGE1),False)
+GNAT1_C_OBJS+= \
+ ada/init.o \
+ ada/initialize.o \
+ ada/raise.o \
+ ada/raise-gcc.o \
+ ada/rtfinal.o \
+ ada/rtinit.o \
+ ada/seh_init.o
+
+GNAT_ADA_OBJS+= \
+ ada/gcc-interface/system.o \
+ ada/libgnat/a-assert.o \
+ ada/libgnat/a-charac.o \
+ ada/libgnat/a-chlat1.o \
+ ada/libgnat/a-elchha.o \
+ ada/libgnat/a-except.o \
+ ada/libgnat/a-exctra.o \
+ ada/libgnat/a-ioexce.o \
+ ada/libgnat/ada.o \
+ ada/libgnat/g-byorma.o \
+ ada/libgnat/g-heasor.o \
+ ada/libgnat/g-htable.o \
+ ada/libgnat/g-spchge.o \
+ ada/libgnat/g-speche.o \
+ ada/libgnat/g-table.o \
+ ada/libgnat/g-u3spch.o \
+ ada/libgnat/interfac.o \
+ ada/libgnat/s-addope.o \
+ ada/libgnat/s-addima.o \
+ ada/libgnat/s-assert.o \
+ ada/libgnat/s-bitops.o \
+ ada/libgnat/s-carun8.o \
+ ada/libgnat/s-conca2.o \
+ ada/libgnat/s-conca3.o \
+ ada/libgnat/s-conca4.o \
+ ada/libgnat/s-conca5.o \
+ ada/libgnat/s-conca6.o \
+ ada/libgnat/s-conca7.o \
+ ada/libgnat/s-conca8.o \
+ ada/libgnat/s-conca9.o \
+ ada/libgnat/s-crc32.o \
+ ada/libgnat/s-excdeb.o \
+ ada/libgnat/s-except.o \
+ ada/libgnat/s-excmac.o \
+ ada/libgnat/s-exctab.o \
+ ada/libgnat/s-htable.o \
+ ada/libgnat/s-imenne.o \
+ ada/libgnat/s-imgint.o \
+ ada/libgnat/s-mastop.o \
+ ada/libgnat/s-memory.o \
+ ada/libgnat/s-parame.o \
+ ada/libgnat/s-purexc.o \
+ ada/libgnat/s-restri.o \
+ ada/libgnat/s-secsta.o \
+ ada/libgnat/s-soflin.o \
+ ada/libgnat/s-soliin.o \
+ ada/libgnat/s-sopco3.o \
+ ada/libgnat/s-sopco4.o \
+ ada/libgnat/s-sopco5.o \
+ ada/libgnat/s-stache.o \
+ ada/libgnat/s-stalib.o \
+ ada/libgnat/s-stoele.o \
+ ada/libgnat/s-strcom.o \
+ ada/libgnat/s-strhas.o \
+ ada/libgnat/s-string.o \
+ ada/libgnat/s-strops.o \
+ ada/libgnat/s-traceb.o \
+ ada/libgnat/s-traent.o \
+ ada/libgnat/s-trasym.o \
+ ada/libgnat/s-unstyp.o \
+ ada/libgnat/s-valint.o \
+ ada/libgnat/s-valuns.o \
+ ada/libgnat/s-valuti.o \
+ ada/libgnat/s-wchcnv.o \
+ ada/libgnat/s-wchcon.o \
+ ada/libgnat/s-wchjis.o \
+ ada/libgnat/s-wchstw.o
+endif
# Object files for gnat executables
GNAT1_ADA_OBJS = $(GNAT_ADA_OBJS) ada/back_end.o ada/gnat1drv.o
@@ -494,14 +555,9 @@ GNAT1_ADA_OBJS = $(GNAT_ADA_OBJS) ada/back_end.o ada/gnat1drv.o
GNAT1_OBJS = $(GNAT1_C_OBJS) $(GNAT1_ADA_OBJS) ada/b_gnat1.o
GNATBIND_OBJS = \
- ada/libgnat/a-elchha.o \
- ada/libgnat/a-except.o \
- ada/libgnat/ada.o \
- ada/adaint.o \
ada/ali-util.o \
ada/ali.o \
ada/alloc.o \
- ada/argv.o \
ada/aspects.o \
ada/atree.o \
ada/bcheck.o \
@@ -520,13 +576,12 @@ GNATBIND_OBJS = \
ada/bindusg.o \
ada/butil.o \
ada/casing.o \
- ada/cio.o \
ada/csets.o \
- ada/cstreams.o \
ada/debug.o \
+ ada/einfo-entities.o \
+ ada/einfo-utils.o \
ada/einfo.o \
ada/elists.o \
- ada/env.o \
ada/err_vars.o \
ada/errout.o \
ada/erroutc.o \
@@ -535,20 +590,9 @@ GNATBIND_OBJS = \
ada/fmap.o \
ada/fname-uf.o \
ada/fname.o \
- ada/libgnat/g-byorma.o \
- ada/libgnat/g-dynhta.o \
- ada/libgnat/g-graphs.o \
- ada/libgnat/g-hesora.o \
- ada/libgnat/g-htable.o \
- ada/libgnat/g-lists.o \
- ada/libgnat/g-sets.o \
- ada/libgnat/gnat.o \
ada/gnatbind.o \
ada/gnatvsn.o \
ada/hostparm.o \
- ada/init.o \
- ada/initialize.o \
- ada/libgnat/interfac.o \
ada/krunch.o \
ada/lib.o \
ada/link.o \
@@ -558,16 +602,73 @@ GNATBIND_OBJS = \
ada/osint-b.o \
ada/osint.o \
ada/output.o \
- ada/raise.o \
- ada/raise-gcc.o \
ada/restrict.o \
ada/rident.o \
+ ada/scans.o \
+ ada/scil_ll.o \
+ ada/scng.o \
+ ada/sdefault.o \
+ ada/seinfo.o \
+ ada/sem_aux.o \
+ ada/sinfo.o \
+ ada/sinfo-nodes.o \
+ ada/sinfo-utils.o \
+ ada/sinput-c.o \
+ ada/sinput.o \
+ ada/snames.o \
+ ada/stand.o \
+ ada/stringt.o \
+ ada/style.o \
+ ada/styleg.o \
+ ada/stylesw.o \
+ ada/switch-b.o \
+ ada/switch.o \
+ ada/table.o \
+ ada/targparm.o \
+ ada/types.o \
+ ada/uintp.o \
+ ada/uname.o \
+ ada/urealp.o \
+ ada/widechar.o \
+ ada/gnat.o \
+ ada/g-dynhta.o \
+ ada/g-lists.o \
+ ada/g-graphs.o \
+ ada/g-sets.o \
+ ada/s-casuti.o \
+ ada/s-os_lib.o \
+ ada/s-resfil.o \
+ ada/s-utf_32.o \
+ ada/adaint.o \
+ ada/argv.o \
+ ada/cio.o \
+ ada/cstreams.o \
+ ada/env.o \
+ ada/errno.o \
+ ada/targext.o \
+ ada/version.o
+
+ifeq ($(STAGE1),False)
+GNATBIND_OBJS += \
+ ada/init.o \
+ ada/initialize.o \
+ ada/raise.o \
+ ada/raise-gcc.o \
ada/rtfinal.o \
ada/rtinit.o \
+ ada/seh_init.o \
+ ada/gcc-interface/system.o \
+ ada/libgnat/a-assert.o \
+ ada/libgnat/a-elchha.o \
+ ada/libgnat/a-except.o \
+ ada/libgnat/ada.o \
+ ada/libgnat/g-byorma.o \
+ ada/libgnat/g-hesora.o \
+ ada/libgnat/g-htable.o \
+ ada/libgnat/interfac.o \
ada/libgnat/s-addope.o \
ada/libgnat/s-assert.o \
ada/libgnat/s-carun8.o \
- ada/libgnat/s-casuti.o \
ada/libgnat/s-conca2.o \
ada/libgnat/s-conca3.o \
ada/libgnat/s-conca4.o \
@@ -577,20 +678,16 @@ GNATBIND_OBJS = \
ada/libgnat/s-conca8.o \
ada/libgnat/s-conca9.o \
ada/libgnat/s-crc32.o \
- ada/libgnat/s-crtl.o \
ada/libgnat/s-excdeb.o \
ada/libgnat/s-except.o \
ada/libgnat/s-excmac.o \
ada/libgnat/s-exctab.o \
ada/libgnat/s-htable.o \
ada/libgnat/s-imenne.o \
- ada/libgnat/s-imgenu.o \
ada/libgnat/s-imgint.o \
ada/libgnat/s-mastop.o \
ada/libgnat/s-memory.o \
- ada/libgnat/s-os_lib.o \
ada/libgnat/s-parame.o \
- ada/libgnat/s-resfil.o \
ada/libgnat/s-restri.o \
ada/libgnat/s-secsta.o \
ada/libgnat/s-soflin.o \
@@ -607,37 +704,11 @@ GNATBIND_OBJS = \
ada/libgnat/s-traent.o \
ada/libgnat/s-traceb.o \
ada/libgnat/s-unstyp.o \
- ada/libgnat/s-utf_32.o \
ada/libgnat/s-wchcnv.o \
ada/libgnat/s-wchcon.o \
ada/libgnat/s-wchjis.o \
- ada/libgnat/s-wchstw.o \
- ada/scans.o \
- ada/scil_ll.o \
- ada/scng.o \
- ada/sdefault.o \
- ada/seh_init.o \
- ada/sem_aux.o \
- ada/sinfo.o \
- ada/sinput-c.o \
- ada/sinput.o \
- ada/snames.o \
- ada/stand.o \
- ada/stringt.o \
- ada/style.o \
- ada/styleg.o \
- ada/stylesw.o \
- ada/switch-b.o \
- ada/switch.o \
- ada/gcc-interface/system.o \
- ada/table.o \
- ada/targext.o \
- ada/targparm.o \
- ada/types.o \
- ada/uintp.o \
- ada/uname.o \
- ada/urealp.o \
- ada/widechar.o
+ ada/libgnat/s-wchstw.o
+endif
# Language-independent object files.
ADA_BACKEND = $(BACKEND) attribs.o
@@ -671,13 +742,13 @@ ada/libgnat/s-excmac.adb: $(srcdir)/ada/libgnat/s-excmac__$(EH_MECHANISM).adb
gnat1$(exeext): $(TARGET_ADA_SRCS) $(GNAT1_OBJS) $(ADA_BACKEND) libcommon-target.a \
$(LIBDEPS) $(ada.prev)
@$(call LINK_PROGRESS,$(INDEX.ada),start)
- +$(GCC_LLINK) -o $@ $(GNAT1_OBJS) $(ADA_BACKEND) \
- libcommon-target.a $(LIBS) $(SYSLIBS) $(BACKENDLIBS) $(CFLAGS)
+ +$(GCC_LLINK) -o $@ $(GNAT1_OBJS) $(ADA_BACKEND) $(CFLAGS) \
+ libcommon-target.a $(LIBS) $(SYSLIBS) $(BACKENDLIBS) $(GNATLIB)
$(RM) stamp-gnatlib2-rts stamp-tools
@$(call LINK_PROGRESS,$(INDEX.ada),end)
gnatbind$(exeext): ada/b_gnatb.o $(CONFIG_H) $(GNATBIND_OBJS) ggc-none.o libcommon-target.a $(LIBDEPS)
- +$(GCC_LINK) -o $@ ada/b_gnatb.o $(GNATBIND_OBJS) ggc-none.o libcommon-target.a $(LIBS) $(SYSLIBS) $(CFLAGS)
+ +$(GCC_LINK) -o $@ $(CFLAGS) ada/b_gnatb.o $(GNATBIND_OBJS) ggc-none.o libcommon-target.a $(LIBS) $(SYSLIBS) $(GNATLIB)
# use target-gcc target-gnatmake target-gnatbind target-gnatlink
gnattools: $(GCC_PARTS) $(CONFIG_H) prefix.o force
@@ -877,7 +948,7 @@ ada.mostlyclean:
-$(RM) ada/*$(objext) ada/*.ali ada/b_gnat*.ads ada/b_gnat*.adb
-$(RM) ada/*$(objext).gnatd.n
-$(RM) ada/*$(coverageexts)
- -$(RM) ada/sdefault.adb ada/stamp-sdefault ada/stamp-snames
+ -$(RM) ada/stamp-sdefault ada/stamp-snames ada/stamp-gen_il
-$(RMDIR) ada/tools
-$(RMDIR) ada/libgnat
-$(RM) gnatbind$(exeext) gnat1$(exeext)
@@ -905,7 +976,6 @@ ada.maintainer-clean:
-$(RM) ada/einfo.h
-$(RM) ada/nmake.adb
-$(RM) ada/nmake.ads
- -$(RM) ada/treeprs.ads
-$(RM) ada/snames.ads ada/snames.adb ada/snames.h
# Stage hooks:
@@ -1011,7 +1081,7 @@ $(check_acats_targets): check-acats%:
ada/b_gnat1.adb : $(GNAT1_ADA_OBJS)
# Old gnatbind do not allow a path for -o.
- $(GNATBIND) $(ADA_INCLUDES) -o b_gnat1.adb -n ada/gnat1drv.ali
+ $(GNATBIND) $(GNATBIND_FLAGS) $(ADA_INCLUDES) -o b_gnat1.adb -n ada/gnat1drv.ali
$(MV) b_gnat1.adb b_gnat1.ads ada/
ada/b_gnat1.o : ada/b_gnat1.adb
@@ -1020,9 +1090,9 @@ ada/b_gnat1.o : ada/b_gnat1.adb
$(CC) -c $(CFLAGS) $(ADA_CFLAGS) -gnatp -gnatws $(ADA_INCLUDES) \
$< $(ADA_OUTPUT_OPTION)
-ada/b_gnatb.adb : $(GNATBIND_OBJS) ada/gnatbind.o ada/libgnat/interfac.o
+ada/b_gnatb.adb : $(GNATBIND_OBJS) ada/gnatbind.o
# Old gnatbind do not allow a path for -o.
- $(GNATBIND) $(ADA_INCLUDES) -o b_gnatb.adb ada/gnatbind.ali
+ $(GNATBIND) $(GNATBIND_FLAGS) $(ADA_INCLUDES) -o b_gnatb.adb ada/gnatbind.ali
$(MV) b_gnatb.adb b_gnatb.ads ada/
ada/b_gnatb.o : ada/b_gnatb.adb
@@ -1031,11 +1101,6 @@ ada/b_gnatb.o : ada/b_gnatb.adb
include $(srcdir)/ada/Make-generated.in
-update-sources : ada/treeprs.ads ada/einfo.h ada/sinfo.h ada/nmake.adb \
- ada/nmake.ads
- $(RM) $(addprefix $(srcdir)/ada/,$(notdir $^))
- $(CP) $^ $(srcdir)/ada
-
ada/sdefault.o : ada/libgnat/ada.ads ada/libgnat/a-except.ads ada/libgnat/a-unccon.ads \
ada/libgnat/a-uncdea.ads ada/alloc.ads ada/debug.ads ada/hostparm.ads ada/namet.ads \
ada/opt.ads ada/osint.ads ada/output.ads ada/sdefault.ads ada/sdefault.adb \
@@ -1083,7 +1148,7 @@ ada/generated/gnatvsn.ads: ada/gnatvsn.ads BASE-VER ada/GNAT_DATE
cat $< | sed -e "/Version/s/(\([0-9][0-9][0-9][0-9][0-9][0-9][0-9][0-9]\).*)/($$d$$s)/g" >$@
ada/gnatvsn.o : ada/gnatvsn.adb ada/generated/gnatvsn.ads
- $(CC) -c $(ALL_ADAFLAGS) -Iada/generated -I../ada/generated $(ADA_INCLUDES) $< $(ADA_OUTPUT_OPTION)
+ $(CC) -c $(ALL_ADAFLAGS) $(ADA_INCLUDES) $< $(ADA_OUTPUT_OPTION)
@$(ADA_DEPS)
# Dependencies for windows specific tool (mdll)
@@ -1097,13 +1162,30 @@ ada/mdll-fil.o : ada/mdll-fil.adb ada/mdll.ads ada/mdll-fil.ads
ada/mdll-utl.o : ada/mdll-utl.adb ada/mdll.ads ada/mdll-utl.ads ada/sdefault.ads ada/types.ads
$(CC) -c $(ALL_ADAFLAGS) $(ADA_INCLUDES) $< $(ADA_OUTPUT_OPTION)
-ada_generated_files = ada/sinfo.h ada/einfo.h ada/nmake.adb ada/nmake.ads \
- ada/treeprs.ads ada/snames.ads ada/snames.adb ada/snames.h \
- ada/generated/gnatvsn.ads
+# All generated files. Perhaps we should build all of these in the same
+# subdirectory, and get rid of ada/bldtools.
+ADA_GENERATED_FILES = \
+ ada/sinfo.h ada/einfo.h ada/nmake.adb ada/nmake.ads \
+ ada/snames.ads ada/snames.adb ada/snames.h \
+ ada/generated/gnatvsn.ads \
+ ada/seinfo.ads ada/seinfo_tables.ads ada/seinfo_tables.adb \
+ ada/sinfo-nodes.ads ada/sinfo-nodes.adb \
+ ada/einfo-entities.ads ada/einfo-entities.adb \
+ ada/gnat.ads ada/g-dynhta.ads ada/g-dynhta.adb \
+ ada/g-dyntab.ads ada/g-dyntab.adb ada/g-graphs.ads ada/g-graphs.adb \
+ ada/g-lists.ads ada/g-lists.adb ada/g-sets.ads ada/g-sets.adb \
+ ada/s-casuti.ads ada/s-casuti.adb \
+ ada/s-crtl.ads ada/s-rident.ads ada/s-pehage.ads ada/s-pehage.adb \
+ ada/s-os_lib.ads ada/s-os_lib.adb ada/s-resfil.ads ada/s-resfil.adb \
+ ada/s-utf_32.ads ada/s-utf_32.adb
+
+# Only used to manually trigger the creation of the generated files.
+.PHONY:
+ada_generated_files: $(ADA_GENERATED_FILES)
# When building from scratch we don't have dependency files, the only thing
# we need to ensure is that the generated files are created first.
-$(GNAT1_OBJS) $(GNATBIND_OBJS): | $(ada_generated_files)
+$(GNAT1_OBJS) $(GNATBIND_OBJS): | $(ADA_GENERATED_FILES)
# Manually include the auto-generated dependencies for the Ada host objects.
ADA_DEPFILES = $(foreach obj,$(GNAT1_ADA_OBJS) $(GNATBIND_OBJS),\
diff --git a/gcc/ada/gcc-interface/Makefile.in b/gcc/ada/gcc-interface/Makefile.in
index 836fcbe..4ab71977 100644
--- a/gcc/ada/gcc-interface/Makefile.in
+++ b/gcc/ada/gcc-interface/Makefile.in
@@ -104,7 +104,7 @@ TEXI2DVI = texi2dvi
TEXI2PDF = texi2pdf
GNATBIND_FLAGS = -static -x
ADA_CFLAGS =
-ADAFLAGS = -W -Wall -gnatpg -gnata
+ADAFLAGS = -W -Wall -gnatpg -gnata -gnatU
FORCE_DEBUG_ADAFLAGS = -g
NO_INLINE_ADAFLAGS = -fno-inline
NO_OMIT_ADAFLAGS = -fno-omit-frame-pointer
@@ -250,9 +250,10 @@ LIBS = $(LIBINTL) $(LIBICONV) $(LIBBACKTRACE) $(LIBIBERTY) $(SYSLIBS)
LIBDEPS = $(LIBINTL_DEP) $(LIBICONV_DEP) $(LIBBACKTRACE) $(LIBIBERTY)
# Default is no TGT_LIB; one might be passed down or something
TGT_LIB =
-TOOLS_LIBS = ../link.o ../targext.o ../../ggc-none.o ../../libcommon-target.a \
- ../../libcommon.a ../../../libcpp/libcpp.a $(LIBGNAT) $(LIBINTL) $(LIBICONV) \
- ../$(LIBBACKTRACE) ../$(LIBIBERTY) $(SYSLIBS) $(TGT_LIB)
+TOOLS_LIBS = ../version.o ../link.o ../targext.o ../../ggc-none.o \
+ ../../libcommon-target.a ../../libcommon.a ../../../libcpp/libcpp.a \
+ $(LIBGNAT) $(LIBINTL) $(LIBICONV) ../$(LIBBACKTRACE) ../$(LIBIBERTY) \
+ $(SYSLIBS) $(TGT_LIB)
# Add -no-pie to TOOLS_LIBS since some of them are compiled with -fno-PIE.
TOOLS_LIBS += @NO_PIE_FLAG@
@@ -302,7 +303,7 @@ ADA_INCLUDES_FOR_SUBDIR = -I. -I$(fsrcdir)/ada
$(CC) -c $(ALL_ADAFLAGS) $(ADA_INCLUDES) $< $(OUTPUT_OPTION)
# how to regenerate this file
-Makefile: ../config.status $(srcdir)/ada/gcc-interface/Makefile.in $(srcdir)/ada/Makefile.in $(srcdir)/version.c
+Makefile: ../config.status $(srcdir)/ada/gcc-interface/Makefile.in $(srcdir)/ada/Makefile.in $(srcdir)/ada/version.c
cd ..; \
LANGUAGES="$(CONFIG_LANGUAGES)" \
CONFIG_HEADERS= \
@@ -332,6 +333,7 @@ GNATMAKE_OBJS = a-except.o ali.o ali-util.o aspects.o s-casuti.o alloc.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 types.o uintp.o \
uname.o urealp.o usage.o widechar.o \
+ seinfo.o einfo-entities.o einfo-utils.o sinfo-nodes.o sinfo-utils.o \
$(EXTRA_GNATMAKE_OBJS)
# Make arch match the current multilib so that the RTS selection code
@@ -383,15 +385,20 @@ TOOLS_FLAGS_TO_PASS= \
GCC_LINK=$(CXX) $(GCC_LINK_FLAGS) $(LDFLAGS)
-# Build directory for the tools. Let's copy the target-dependent
-# sources using the same mechanism as for gnatlib. The other sources are
-# accessed using the vpath directive below
+# Build directory for the tools. We first need to copy the generated files,
+# then the target-dependent sources using the same mechanism as for gnatlib.
+# The other sources are accessed using the vpath directive below
+
+GENERATED_FILES_FOR_TOOLS = \
+ einfo-entities.ads einfo-entities.adb sdefault.adb seinfo.ads \
+ sinfo-nodes.ads sinfo-nodes.adb snames.ads snames.adb
../stamp-tools:
-$(RM) tools/*
-$(RMDIR) tools
-$(MKDIR) tools
- -(cd tools; $(LN_S) ../sdefault.adb ../snames.ads ../snames.adb .)
+ -(cd tools; $(foreach FILE,$(GENERATED_FILES_FOR_TOOLS), \
+ $(LN_S) ../$(FILE) $(FILE);))
-$(foreach PAIR,$(TOOLS_TARGET_PAIRS), \
$(RM) tools/$(word 1,$(subst <, ,$(PAIR)));\
$(LN_S) $(fsrcpfx)ada/$(word 2,$(subst <, ,$(PAIR))) \
diff --git a/gcc/ada/libgnat/a-stobbu.adb b/gcc/ada/gcc-interface/a-assert.adb
index fba591d..429b14b 100644
--- a/gcc/ada/libgnat/a-stobbu.adb
+++ b/gcc/ada/gcc-interface/a-assert.adb
@@ -2,11 +2,11 @@
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
--- ADA.STRINGS.TEXT_OUTPUT.BIT_BUCKETS --
+-- A D A . A S S E R T --
-- --
-- B o d y --
-- --
--- Copyright (C) 2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2007-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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,25 +29,24 @@
-- --
------------------------------------------------------------------------------
-package body Ada.Strings.Text_Output.Bit_Buckets is
+package body Ada.Assertions 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);
+ ------------
+ -- Assert --
+ ------------
- 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;
+ procedure Assert (Check : Boolean) is
+ begin
+ if Check = False then
+ raise Ada.Assertions.Assertion_Error;
+ end if;
+ end Assert;
- overriding procedure Flush_Method (S : in out Bit_Bucket_Type) is
+ procedure Assert (Check : Boolean; Message : String) is
begin
- S.Last := 0;
- end Flush_Method;
+ if Check = False then
+ raise Ada.Assertions.Assertion_Error with Message;
+ end if;
+ end Assert;
-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;
+end Ada.Assertions;
diff --git a/gcc/ada/gcc-interface/a-assert.ads b/gcc/ada/gcc-interface/a-assert.ads
new file mode 100644
index 0000000..55ed806
--- /dev/null
+++ b/gcc/ada/gcc-interface/a-assert.ads
@@ -0,0 +1,50 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- A D A . A S S E R T I O N S --
+-- --
+-- Copyright (C) 2015-2021, Free Software Foundation, Inc. --
+-- --
+-- S p e c --
+-- --
+-- 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 contracts that have been added. --
+-- --
+-- GNAT is 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 version is used to bootstrap the compiler only.
+-- It can be removed when we switch to using a GNAT from 2014 or later.
+
+pragma Compiler_Unit_Warning;
+
+package Ada.Assertions is
+ pragma Pure;
+
+ Assertion_Error : exception;
+
+ procedure Assert (Check : Boolean);
+
+ procedure Assert (Check : Boolean; Message : String);
+
+end Ada.Assertions;
diff --git a/gcc/ada/gcc-interface/ada-tree.h b/gcc/ada/gcc-interface/ada-tree.h
index 461fa2b..9fe52cf 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-2020, Free Software Foundation, Inc. *
+ * Copyright (C) 1992-2021, Free Software Foundation, Inc. *
* *
* GNAT is 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,6 +580,6 @@ do { \
#define EXIT_STMT_LABEL(NODE) TREE_OPERAND_CHECK_CODE (NODE, EXIT_STMT, 1)
/* Small kludge to be able to define Ada built-in functions locally.
- We overload them on top of the HSAIL/BRIG builtin functions. */
-#define BUILT_IN_LIKELY BUILT_IN_HSAIL_WORKITEMABSID
-#define BUILT_IN_UNLIKELY BUILT_IN_HSAIL_GRIDSIZE
+ We overload them on top of the C++ coroutines builtin functions. */
+#define BUILT_IN_LIKELY BUILT_IN_CORO_PROMISE
+#define BUILT_IN_UNLIKELY BUILT_IN_CORO_RESUME
diff --git a/gcc/ada/gcc-interface/ada.h b/gcc/ada/gcc-interface/ada.h
index c5a1916..242a14e 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-2020, Free Software Foundation, Inc. *
+ * Copyright (C) 1992-2021, Free Software Foundation, Inc. *
* *
* GNAT is free software; you can redistribute 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 dada72a..6ac82d7 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-2020, Free Software Foundation, Inc. *
+ * Copyright (C) 1992-2021, Free Software Foundation, Inc. *
* *
* GNAT is 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 @@
For efficiency, this method is used only for integer values larger than the
constant Uint_Bias. If a Uint is less than this constant, then it contains
- the integer value itself. The origin of the Uints_Ptr table is adjusted so
- that a Uint value of Uint_Bias indexes the first element.
+ the integer value itself.
First define a utility function that is build_int_cst for integral types and
does a conversion for floating-point types. */
@@ -85,9 +84,9 @@ UI_To_gnu (Uint Input, tree type)
gnu_ret = build_cst_from_int (comp_type, Input - Uint_Direct_Bias);
else
{
- Int Idx = Uints_Ptr[Input].Loc;
- Pos Length = Uints_Ptr[Input].Length;
- Int First = Udigits_Ptr[Idx];
+ Int Idx = (*Uints_Ptr)[Input - Uint_Table_Start].Loc;
+ Pos Length = (*Uints_Ptr)[Input - Uint_Table_Start].Length;
+ Int First = (*Udigits_Ptr)[Idx];
tree gnu_base;
gcc_assert (Length > 0);
@@ -109,14 +108,14 @@ UI_To_gnu (Uint Input, tree type)
fold_build2 (MULT_EXPR, comp_type,
gnu_ret, gnu_base),
build_cst_from_int (comp_type,
- Udigits_Ptr[Idx]));
+ (*Udigits_Ptr)[Idx]));
else
for (Idx++, Length--; Length; Idx++, Length--)
gnu_ret = fold_build2 (PLUS_EXPR, comp_type,
fold_build2 (MULT_EXPR, comp_type,
gnu_ret, gnu_base),
build_cst_from_int (comp_type,
- Udigits_Ptr[Idx]));
+ (*Udigits_Ptr)[Idx]));
}
gnu_ret = convert (type, gnu_ret);
diff --git a/gcc/ada/gcc-interface/decl.c b/gcc/ada/gcc-interface/decl.c
index 27ef51a..5cedb74 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-2020, Free Software Foundation, Inc. *
+ * Copyright (C) 1992-2021, Free Software Foundation, Inc. *
* *
* GNAT is free software; you can redistribute it and/or modify it under *
* terms of the GNU General Public License as published by the Free Soft- *
@@ -217,7 +217,8 @@ static void set_reverse_storage_order_on_array_type (tree);
static bool same_discriminant_p (Entity_Id, Entity_Id);
static bool array_type_has_nonaliased_component (tree, Entity_Id);
static bool compile_time_known_address_p (Node_Id);
-static bool cannot_be_superflat (Node_Id);
+static bool flb_cannot_be_superflat (Node_Id);
+static bool range_cannot_be_superflat (Node_Id);
static bool constructor_address_p (tree);
static bool allocatable_size_p (tree, bool);
static bool initial_value_needs_conversion (tree, tree);
@@ -434,7 +435,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition)
gcc_assert (!is_type
|| Known_Esize (gnat_entity)
|| Has_Size_Clause (gnat_entity)
- || (!IN (kind, Numeric_Kind)
+ || (!Is_In_Numeric_Kind (kind)
&& !IN (kind, Enumeration_Kind)
&& (!IN (kind, Access_Kind)
|| kind == E_Access_Protected_Subprogram_Type
@@ -443,8 +444,8 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition)
|| type_annotate_only)));
/* The RM size must be specified for all discrete and fixed-point types. */
- gcc_assert (!(IN (kind, Discrete_Or_Fixed_Point_Kind)
- && Unknown_RM_Size (gnat_entity)));
+ gcc_assert (!(Is_In_Discrete_Or_Fixed_Point_Kind (kind)
+ && !Known_RM_Size (gnat_entity)));
/* If we get here, it means we have not yet done anything with this entity.
If we are not defining it, it must be a type or an entity that is defined
@@ -622,7 +623,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition)
= create_var_decl (gnu_entity_name, gnu_ext_name, gnu_type,
gnu_expr, true, Is_Public (gnat_entity),
false, false, false, artificial_p,
- debug_info_p, NULL, gnat_entity, true);
+ debug_info_p, NULL, gnat_entity);
}
break;
@@ -736,16 +737,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition)
if (foreign && Is_Descendant_Of_Address (Underlying_Type (gnat_type)))
gnu_type = ptr_type_node;
else
- {
- gnu_type = gnat_to_gnu_type (gnat_type);
-
- /* If this is a standard exception definition, use the standard
- exception type. This is necessary to make sure that imported
- and exported views of exceptions are merged in LTO mode. */
- if (TREE_CODE (TYPE_NAME (gnu_type)) == TYPE_DECL
- && DECL_NAME (TYPE_NAME (gnu_type)) == exception_data_name_id)
- gnu_type = except_type_node;
- }
+ gnu_type = gnat_to_gnu_type (gnat_type);
/* For a debug renaming declaration, build a debug-only entity. */
if (Present (Debug_Renaming_Link (gnat_entity)))
@@ -1352,7 +1344,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition)
|| (gnu_size
&& !allocatable_size_p (convert (sizetype,
size_binop
- (CEIL_DIV_EXPR, gnu_size,
+ (EXACT_DIV_EXPR, gnu_size,
bitsize_unit_node)),
global_bindings_p ()
|| !definition
@@ -1401,7 +1393,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition)
if (TREE_CODE (TYPE_SIZE_UNIT (gnu_alloc_type)) == INTEGER_CST
&& !valid_constant_size_p (TYPE_SIZE_UNIT (gnu_alloc_type)))
- post_error ("?`Storage_Error` will be raised at run time!",
+ post_error ("??`Storage_Error` will be raised at run time!",
gnat_entity);
gnu_expr
@@ -1536,7 +1528,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, true);
+ gnat_entity);
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);
@@ -2006,7 +1998,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition)
so we use an intermediate step for standard DWARF. */
if (debug_info_p)
{
- if (gnat_encodings == DWARF_GNAT_ENCODINGS_MINIMAL)
+ if (gnat_encodings != DWARF_GNAT_ENCODINGS_ALL)
SET_TYPE_DEBUG_TYPE (gnu_type, gnu_field_type);
else if (DECL_PARALLEL_TYPE (t))
add_parallel_type (gnu_type, DECL_PARALLEL_TYPE (t));
@@ -2109,6 +2101,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition)
case E_Array_Type:
{
+ const Entity_Id PAT = Packed_Array_Impl_Type (gnat_entity);
const bool convention_fortran_p
= (Convention (gnat_entity) == Convention_Fortran);
const int ndim = Number_Dimensions (gnat_entity);
@@ -2212,16 +2205,16 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition)
}
/* 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. */
+ If this is a packed type implemented specially, tell the debugger
+ how to interpret the underlying bits by fetching the name 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)
+ = Present (PAT) && gnat_encodings == DWARF_GNAT_ENCODINGS_ALL
+ ? PAT
: gnat_entity;
tree xup_name
- = (gnat_encodings != DWARF_GNAT_ENCODINGS_MINIMAL)
+ = gnat_encodings == DWARF_GNAT_ENCODINGS_ALL
? create_concat_name (gnat_name, "XUP")
: gnu_entity_name;
create_type_decl (xup_name, gnu_fat_type, true, debug_info_p,
@@ -2246,13 +2239,15 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition)
index += (convention_fortran_p ? - 1 : 1),
gnat_index = Next_Index (gnat_index))
{
- char field_name[16];
+ const bool is_flb
+ = Is_Fixed_Lower_Bound_Index_Subtype (Etype (gnat_index));
tree gnu_index_type = get_unpadded_type (Etype (gnat_index));
tree gnu_orig_min = TYPE_MIN_VALUE (gnu_index_type);
tree gnu_orig_max = TYPE_MAX_VALUE (gnu_index_type);
tree gnu_index_base_type = get_base_type (gnu_index_type);
tree gnu_lb_field, gnu_hb_field;
tree gnu_min, gnu_max, gnu_high;
+ char field_name[16];
/* Update the maximum size of the array in elements. */
if (gnu_max_size)
@@ -2286,25 +2281,38 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition)
/* We can't use build_component_ref here since the template type
isn't complete yet. */
- gnu_orig_min = build3 (COMPONENT_REF, TREE_TYPE (gnu_lb_field),
- gnu_template_reference, gnu_lb_field,
- NULL_TREE);
+ if (!is_flb)
+ {
+ gnu_orig_min = build3 (COMPONENT_REF, TREE_TYPE (gnu_lb_field),
+ gnu_template_reference, gnu_lb_field,
+ NULL_TREE);
+ TREE_READONLY (gnu_orig_min) = 1;
+ }
+
gnu_orig_max = build3 (COMPONENT_REF, TREE_TYPE (gnu_hb_field),
gnu_template_reference, gnu_hb_field,
NULL_TREE);
- TREE_READONLY (gnu_orig_min) = TREE_READONLY (gnu_orig_max) = 1;
+ TREE_READONLY (gnu_orig_max) = 1;
gnu_min = convert (sizetype, gnu_orig_min);
gnu_max = convert (sizetype, gnu_orig_max);
/* Compute the size of this dimension. See the E_Array_Subtype
case below for the rationale. */
- gnu_high
- = build3 (COND_EXPR, sizetype,
- build2 (GE_EXPR, boolean_type_node,
- gnu_orig_max, gnu_orig_min),
- gnu_max,
- size_binop (MINUS_EXPR, gnu_min, size_one_node));
+ if (is_flb
+ && Nkind (gnat_index) == N_Subtype_Indication
+ && flb_cannot_be_superflat (gnat_index))
+ gnu_high = gnu_max;
+
+ else
+ gnu_high
+ = build3 (COND_EXPR, sizetype,
+ build2 (GE_EXPR, boolean_type_node,
+ gnu_orig_max, gnu_orig_min),
+ gnu_max,
+ TREE_CODE (gnu_min) == INTEGER_CST
+ ? int_const_binop (MINUS_EXPR, gnu_min, size_one_node)
+ : size_binop (MINUS_EXPR, gnu_min, size_one_node));
/* Make a range type with the new range in the Ada base type.
Then make an index type with the size range in sizetype. */
@@ -2332,7 +2340,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition)
/* If Component_Size is not already specified, annotate it with the
size of the component. */
- if (Unknown_Component_Size (gnat_entity))
+ if (!Known_Component_Size (gnat_entity))
Set_Component_Size (gnat_entity,
annotate_value (TYPE_SIZE (comp_type)));
@@ -2354,11 +2362,14 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition)
set_nonaliased_component_on_array_type (tem);
}
- /* If an alignment is specified, use it if valid. But ignore it
- for the original type of packed array types. If the alignment
- was requested with an explicit alignment clause, state so. */
- if (No (Packed_Array_Impl_Type (gnat_entity))
- && Known_Alignment (gnat_entity))
+ /* If this is a packed type implemented specially, then process the
+ implementation type so it is elaborated in the proper scope. */
+ if (Present (PAT))
+ gnat_to_gnu_entity (PAT, NULL_TREE, false);
+
+ /* Otherwise, if an alignment is specified, use it if valid and, if
+ the alignment was requested with an explicit clause, state so. */
+ else if (Known_Alignment (gnat_entity))
{
SET_TYPE_ALIGN (tem,
validate_alignment (Alignment (gnat_entity),
@@ -2379,8 +2390,15 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition)
tem = change_qualified_type (tem, TYPE_QUAL_VOLATILE);
/* Adjust the type of the pointer-to-array field of the fat pointer
- and record the aliasing relationships if necessary. */
- TREE_TYPE (TYPE_FIELDS (gnu_fat_type)) = build_pointer_type (tem);
+ and record the aliasing relationships if necessary. If this is
+ a packed type implemented specially, then use a ref-all pointer
+ type since the implementation type may vary between constrained
+ subtypes and unconstrained base type. */
+ if (Present (PAT))
+ TREE_TYPE (TYPE_FIELDS (gnu_fat_type))
+ = build_pointer_type_for_mode (tem, ptr_mode, true);
+ else
+ TREE_TYPE (TYPE_FIELDS (gnu_fat_type)) = build_pointer_type (tem);
if (TYPE_ALIAS_SET_KNOWN_P (gnu_fat_type))
record_component_aliases (gnu_fat_type);
@@ -2402,11 +2420,9 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition)
template at a negative offset, but this was somewhat of a kludge; we
now shift thin pointer values explicitly but only those which have a
TYPE_UNCONSTRAINED_ARRAY attached to the designated RECORD_TYPE.
- Note that GDB can handle standard DWARF information for them, so we
- don't have to name them as a GNAT encoding, except if specifically
- asked to. */
+ If the GNAT encodings are used, give it a name. */
tree xut_name
- = (gnat_encodings != DWARF_GNAT_ENCODINGS_MINIMAL)
+ = (gnat_encodings == DWARF_GNAT_ENCODINGS_ALL)
? create_concat_name (gnat_name, "XUT")
: gnu_entity_name;
obj = build_unc_object_type (gnu_template_type, tem, xut_name,
@@ -2444,6 +2460,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition)
;
else
{
+ const Entity_Id PAT = Packed_Array_Impl_Type (gnat_entity);
Entity_Id gnat_index, gnat_base_index;
const bool convention_fortran_p
= (Convention (gnat_entity) == Convention_Fortran);
@@ -2592,7 +2609,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition)
this. If we can prove that the array can never be superflat,
we can just use the high bound of the index type. */
else if ((Nkind (gnat_index) == N_Range
- && cannot_be_superflat (gnat_index))
+ && range_cannot_be_superflat (gnat_index))
/* Bit-Packed Array Impl. Types are never superflat. */
|| (Is_Packed_Array_Impl_Type (gnat_entity)
&& Is_Bit_Packed_Array
@@ -2654,7 +2671,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition)
&& TREE_CODE (TREE_TYPE (gnu_index_type))
!= INTEGER_TYPE)
|| TYPE_BIASED_REPRESENTATION_P (gnu_index_type))
- && gnat_encodings != DWARF_GNAT_ENCODINGS_MINIMAL)
+ && gnat_encodings == DWARF_GNAT_ENCODINGS_ALL)
need_index_type_struct = true;
}
@@ -2831,7 +2848,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition)
gnu_entity_name = gnu_name;
}
- else if (gnat_encodings != DWARF_GNAT_ENCODINGS_MINIMAL)
+ else if (gnat_encodings == DWARF_GNAT_ENCODINGS_ALL)
{
tree gnu_base_decl
= gnat_to_gnu_entity (Etype (gnat_entity), NULL_TREE,
@@ -2849,7 +2866,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition)
/* If this is a packed type implemented specially, then replace our
type with the implementation type. */
- if (Present (Packed_Array_Impl_Type (gnat_entity)))
+ if (Present (PAT))
{
/* First finish the type we had been making so that we output
debugging information for it. */
@@ -2874,12 +2891,11 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition)
this type again. */
save_gnu_tree (gnat_entity, gnu_tmp_decl, false);
- gnu_type
- = gnat_to_gnu_type (Packed_Array_Impl_Type (gnat_entity));
+ gnu_type = gnat_to_gnu_type (PAT);
save_gnu_tree (gnat_entity, NULL_TREE, false);
/* Set the ___XP suffix for GNAT encodings. */
- if (gnat_encodings != DWARF_GNAT_ENCODINGS_MINIMAL)
+ if (gnat_encodings == DWARF_GNAT_ENCODINGS_ALL)
gnu_entity_name = DECL_NAME (TYPE_NAME (gnu_type));
tree gnu_inner = gnu_type;
@@ -3354,14 +3370,14 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition)
= build_subst_list (gnat_entity, gnat_parent_type, definition);
/* Set the layout of the type to match that of the parent type,
- doing required substitutions. If we are in minimal GNAT
- encodings mode, we don't need debug info for the inner record
+ doing required substitutions. Note that, if we do not use the
+ GNAT encodings, we don't need debug info for the inner record
types, as they will be part of the embedding variant record's
debug info. */
copy_and_substitute_in_layout
(gnat_entity, gnat_parent_type, gnu_type, gnu_parent_type,
gnu_subst_list,
- debug_info_p && gnat_encodings != DWARF_GNAT_ENCODINGS_MINIMAL);
+ debug_info_p && gnat_encodings == DWARF_GNAT_ENCODINGS_ALL);
}
else
{
@@ -3404,21 +3420,6 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition)
/* Fill in locations of fields. */
annotate_rep (gnat_entity, gnu_type);
-
- /* If this is a record type associated with an exception definition,
- equate its fields to those of the standard exception type. This
- will make it possible to convert between them. */
- if (gnu_entity_name == exception_data_name_id)
- {
- tree gnu_std_field;
- for (gnu_field = TYPE_FIELDS (gnu_type),
- gnu_std_field = TYPE_FIELDS (except_type_node);
- gnu_field;
- gnu_field = DECL_CHAIN (gnu_field),
- gnu_std_field = DECL_CHAIN (gnu_std_field))
- SET_DECL_ORIGINAL_FIELD_TO_FIELD (gnu_field, gnu_std_field);
- gcc_assert (!gnu_std_field);
- }
}
break;
@@ -3515,11 +3516,11 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition)
annotate_rep (gnat_entity, gnu_type);
/* If debugging information is being written for the type and if
- we are asked to output such encodings, write a record that
+ we are asked to output GNAT 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 (debug_info_p
- && gnat_encodings != DWARF_GNAT_ENCODINGS_MINIMAL)
+ && gnat_encodings == DWARF_GNAT_ENCODINGS_ALL)
{
tree gnu_subtype_marker = make_node (RECORD_TYPE);
tree gnu_unpad_base_name
@@ -3546,16 +3547,15 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition)
= create_var_decl (create_concat_name (gnat_entity,
"XVZ"),
NULL_TREE, sizetype, gnu_size_unit,
- false, false, false, false, false,
- true, debug_info_p,
- NULL, gnat_entity);
+ true, false, false, false, false,
+ true, true, NULL, gnat_entity, false);
}
- /* Or else, if the subtype is artificial and encodings are not
- used, use the base record type as the debug type. */
+ /* Or else, if the subtype is artificial and GNAT 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)
+ && gnat_encodings != DWARF_GNAT_ENCODINGS_ALL)
SET_TYPE_DEBUG_TYPE (gnu_type, gnu_unpad_base_type);
}
@@ -4348,7 +4348,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition)
ratio is greater or equal to the byte/bit ratio. */
if (tree_fits_uhwi_p (size)
&& align >= tree_to_uhwi (size) * BITS_PER_UNIT)
- post_error_ne ("?suspiciously large alignment specified for&",
+ post_error_ne ("??suspiciously large alignment specified for&",
Expression (Alignment_Clause (gnat_entity)),
gnat_entity);
}
@@ -4383,7 +4383,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition)
set_rm_size (RM_Size (gnat_entity), gnu_type, gnat_entity);
/* Back-annotate the alignment of the type if not already set. */
- if (Unknown_Alignment (gnat_entity))
+ if (!Known_Alignment (gnat_entity))
{
unsigned int double_align, align;
bool is_capped_double, align_clause;
@@ -4409,7 +4409,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition)
}
/* Likewise for the size, if any. */
- if (Unknown_Esize (gnat_entity) && TYPE_SIZE (gnu_type))
+ if (!Known_Esize (gnat_entity) && TYPE_SIZE (gnu_type))
{
tree gnu_size = TYPE_SIZE (gnu_type);
@@ -4431,9 +4431,13 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition)
const bool derived_p = Is_Derived_Type (gnat_entity);
const Entity_Id gnat_parent
= derived_p ? Etype (Base_Type (gnat_entity)) : Empty;
+ /* The following test for Known_Alignment preserves the old behavior,
+ but is probably wrong. */
const unsigned int inherited_align
= derived_p
- ? UI_To_Int (Alignment (gnat_parent)) * BITS_PER_UNIT
+ ? (Known_Alignment (gnat_parent)
+ ? UI_To_Int (Alignment (gnat_parent)) * BITS_PER_UNIT
+ : 0)
: POINTER_SIZE;
const unsigned int align
= MAX (TYPE_ALIGN (gnu_type), inherited_align);
@@ -4442,7 +4446,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition)
/* If there is neither size clause nor representation clause, the
sizes need to be adjusted. */
- if (Unknown_RM_Size (gnat_entity)
+ if (!Known_RM_Size (gnat_entity)
&& !VOID_TYPE_P (gnu_type)
&& (!TYPE_FIELDS (gnu_type)
|| integer_zerop (bit_position (TYPE_FIELDS (gnu_type)))))
@@ -4462,7 +4466,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition)
Set_Esize (gnat_entity, annotate_value (gnu_size));
/* Tagged types are Strict_Alignment so RM_Size = Esize. */
- if (Unknown_RM_Size (gnat_entity))
+ if (!Known_RM_Size (gnat_entity))
Set_RM_Size (gnat_entity, Esize (gnat_entity));
}
@@ -4472,24 +4476,23 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition)
}
/* Likewise for the RM size, if any. */
- if (Unknown_RM_Size (gnat_entity) && TYPE_SIZE (gnu_type))
+ if (!Known_RM_Size (gnat_entity) && TYPE_SIZE (gnu_type))
Set_RM_Size (gnat_entity, annotate_value (rm_size (gnu_type)));
- /* If we are at global level, GCC will have applied variable_size to
- the type, but that won't have done anything. So, if it's not
- a constant or self-referential, call elaborate_expression_1 to
- make a variable for the size rather than calculating it each time.
- Handle both the RM size and the actual size. */
+ /* If we are at global level, GCC applied variable_size to the size but
+ this has done nothing. So, if it's not constant or self-referential,
+ call elaborate_expression_1 to make a variable for it rather than
+ calculating it each time. */
if (TYPE_SIZE (gnu_type)
&& !TREE_CONSTANT (TYPE_SIZE (gnu_type))
&& !CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type))
&& global_bindings_p ())
{
- tree size = TYPE_SIZE (gnu_type);
+ tree orig_size = TYPE_SIZE (gnu_type);
TYPE_SIZE (gnu_type)
- = elaborate_expression_1 (size, gnat_entity, "SIZE", definition,
- false);
+ = elaborate_expression_1 (TYPE_SIZE (gnu_type), gnat_entity,
+ "SIZE", definition, false);
/* ??? For now, store the size as a multiple of the alignment in
bytes so that we can see the alignment from the tree. */
@@ -4502,7 +4505,9 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition)
may not be marked by the call to create_type_decl below. */
MARK_VISITED (TYPE_SIZE_UNIT (gnu_type));
- if (TREE_CODE (gnu_type) == RECORD_TYPE)
+ /* For a record type, deal with the variant part, if any, and handle
+ the Ada size as well. */
+ if (RECORD_OR_UNION_TYPE_P (gnu_type))
{
tree variant_part = get_variant_part (gnu_type);
tree ada_size = TYPE_ADA_SIZE (gnu_type);
@@ -4555,7 +4560,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition)
DECL_SIZE_UNIT (variant_part) = TYPE_SIZE_UNIT (union_type);
}
- if (operand_equal_p (ada_size, size, 0))
+ if (operand_equal_p (ada_size, orig_size, 0))
ada_size = TYPE_SIZE (gnu_type);
else
ada_size
@@ -4568,7 +4573,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition)
/* Similarly, if this is a record type or subtype at global level, call
elaborate_expression_2 on any field position. Skip any fields that
we haven't made trees for to avoid problems with class-wide types. */
- if (IN (kind, Record_Kind) && global_bindings_p ())
+ if (Is_In_Record_Kind (kind) && global_bindings_p ())
for (gnat_temp = First_Entity (gnat_entity); Present (gnat_temp);
gnat_temp = Next_Entity (gnat_temp))
if (Ekind (gnat_temp) == E_Component && present_gnu_tree (gnat_temp))
@@ -4736,11 +4741,11 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition)
&& !TYPE_IS_DUMMY_P (TREE_TYPE (gnu_decl))
&& Present (gnat_annotate_type))
{
- if (Unknown_Alignment (gnat_entity))
- Set_Alignment (gnat_entity, Alignment (gnat_annotate_type));
- if (Unknown_Esize (gnat_entity))
+ if (!Known_Alignment (gnat_entity))
+ Copy_Alignment (gnat_entity, gnat_annotate_type);
+ if (!Known_Esize (gnat_entity))
Set_Esize (gnat_entity, Esize (gnat_annotate_type));
- if (Unknown_RM_Size (gnat_entity))
+ if (!Known_RM_Size (gnat_entity))
Set_RM_Size (gnat_entity, RM_Size (gnat_annotate_type));
}
@@ -5463,7 +5468,7 @@ gnat_to_gnu_param (Entity_Id gnat_param, tree gnu_param_type, bool first,
input_location = saved_location;
if (mech == By_Copy && (by_ref || by_component_ptr))
- post_error ("?cannot pass & by copy", gnat_param);
+ post_error ("??cannot pass & by copy", gnat_param);
/* If this is an Out parameter that isn't passed by reference and whose
type doesn't require the initialization of formals, we don't make a
@@ -5761,16 +5766,16 @@ gnat_to_gnu_subprog_type (Entity_Id gnat_subprog, bool definition,
tree gnu_cico_return_type = NULL_TREE;
tree gnu_cico_field_list = NULL_TREE;
bool gnu_cico_only_integral_type = true;
- /* The semantics of "pure" in Ada essentially matches that of "const"
- or "pure" in GCC. In particular, both properties are orthogonal
- to the "nothrow" property if the EH circuitry is explicit in the
- internal representation of the middle-end. If we are to completely
- hide the EH circuitry from it, we need to declare that calls to pure
- Ada subprograms that can throw have side effects since they can
- trigger an "abnormal" transfer of control flow; therefore, they can
- be neither "const" nor "pure" in the GCC sense. */
- bool const_flag = (Back_End_Exceptions () && Is_Pure (gnat_subprog));
- bool pure_flag = false;
+ /* Although the semantics of "pure" units in Ada essentially match those of
+ "const" in GNU C, the semantics of the Is_Pure flag in GNAT do not say
+ anything about access to global memory, that's why it needs to be mapped
+ to "pure" instead of "const" in GNU C. The property is orthogonal to the
+ "nothrow" property only if the EH circuitry is explicit in the internal
+ representation of the middle-end: if we are to completely hide the EH
+ circuitry from it, we need to declare that calls to pure Ada subprograms
+ that can throw have side effects, since they can trigger an "abnormal"
+ transfer of control; therefore they cannot be "pure" in the GCC sense. */
+ bool pure_flag = Is_Pure (gnat_subprog) && Back_End_Exceptions ();
bool return_by_direct_ref_p = false;
bool return_by_invisi_ref_p = false;
bool return_unconstrained_p = false;
@@ -5923,14 +5928,14 @@ gnat_to_gnu_subprog_type (Entity_Id gnat_subprog, bool definition,
}
/* A procedure (something that doesn't return anything) shouldn't be
- considered const since there would be no reason for calling such a
+ considered pure since there would be no reason for calling such a
subprogram. Note that procedures with Out (or In Out) parameters
have already been converted into a function with a return type.
Similarly, if the function returns an unconstrained type, then the
function will allocate the return value on the secondary stack and
thus calls to it cannot be CSE'ed, lest the stack be reclaimed. */
if (VOID_TYPE_P (gnu_return_type) || return_unconstrained_p)
- const_flag = false;
+ pure_flag = false;
/* Loop over the parameters and get their associated GCC tree. While doing
this, build a copy-in copy-out structure if we need one. */
@@ -6058,18 +6063,16 @@ gnat_to_gnu_subprog_type (Entity_Id gnat_subprog, bool definition,
save_gnu_tree (gnat_param, gnu_param, false);
/* A pure function in the Ada sense which takes an access parameter
- may modify memory through it and thus need be considered neither
- const nor pure in the GCC sense. Likewise it if takes a by-ref
- In Out or Out parameter. But if it takes a by-ref In parameter,
- then it may only read memory through it and can be considered
- pure in the GCC sense. */
- if ((const_flag || pure_flag)
- && (POINTER_TYPE_P (gnu_param_type)
+ may modify memory through it and thus cannot be considered pure
+ in the GCC sense, unless it's access-to-function. Likewise it if
+ takes a by-ref In Out or Out parameter. But if it takes a by-ref
+ In parameter, then it may only read memory through it and can be
+ considered pure in the GCC sense. */
+ if (pure_flag
+ && ((POINTER_TYPE_P (gnu_param_type)
+ && TREE_CODE (TREE_TYPE (gnu_param_type)) != FUNCTION_TYPE)
|| TYPE_IS_FAT_POINTER_P (gnu_param_type)))
- {
- const_flag = false;
- pure_flag = DECL_POINTS_TO_READONLY_P (gnu_param);
- }
+ pure_flag = DECL_POINTS_TO_READONLY_P (gnu_param);
}
/* If the parameter uses the copy-in copy-out mechanism, allocate a field
@@ -6269,9 +6272,6 @@ gnat_to_gnu_subprog_type (Entity_Id gnat_subprog, bool definition,
}
}
- if (const_flag)
- gnu_type = change_qualified_type (gnu_type, TYPE_QUAL_CONST);
-
if (pure_flag)
gnu_type = change_qualified_type (gnu_type, TYPE_QUAL_RESTRICT);
@@ -6296,7 +6296,7 @@ gnat_to_gnu_subprog_type (Entity_Id gnat_subprog, bool definition,
if (!intrin_profiles_compatible_p (&inb))
post_error
- ("?profile of& doesn''t match the builtin it binds!",
+ ("??profile of& doesn''t match the builtin it binds!",
gnat_subprog);
return gnu_builtin_decl;
@@ -6309,7 +6309,7 @@ gnat_to_gnu_subprog_type (Entity_Id gnat_subprog, bool definition,
on demand without risking false positives with common default sets
of options. */
if (warn_shadow)
- post_error ("?gcc intrinsic not found for&!", gnat_subprog);
+ post_error ("??gcc intrinsic not found for&!", gnat_subprog);
}
}
@@ -6428,33 +6428,81 @@ compile_time_known_address_p (Node_Id gnat_address)
return Compile_Time_Known_Value (gnat_address);
}
+/* Return true if GNAT_INDIC, a N_Subtype_Indication node for the index of a
+ FLB, cannot yield superflat objects, i.e. if the inequality HB >= LB - 1
+ is true for these objects. LB and HB are the low and high bounds. */
+
+static bool
+flb_cannot_be_superflat (Node_Id gnat_indic)
+{
+ const Entity_Id gnat_type = Entity (Subtype_Mark (gnat_indic));
+ const Entity_Id gnat_subtype = Etype (gnat_indic);
+ Node_Id gnat_scalar_range, gnat_lb, gnat_hb;
+ tree gnu_lb, gnu_hb, gnu_lb_minus_one;
+
+ /* This is a FLB so LB is fixed. */
+ if ((Ekind (gnat_subtype) == E_Signed_Integer_Subtype
+ || Ekind (gnat_subtype) == E_Modular_Integer_Subtype)
+ && (gnat_scalar_range = Scalar_Range (gnat_subtype)))
+ {
+ gnat_lb = Low_Bound (gnat_scalar_range);
+ gcc_assert (Nkind (gnat_lb) == N_Integer_Literal);
+ }
+ else
+ return false;
+
+ /* The low bound of the type is a lower bound for HB. */
+ if ((Ekind (gnat_type) == E_Signed_Integer_Subtype
+ || Ekind (gnat_type) == E_Modular_Integer_Subtype)
+ && (gnat_scalar_range = Scalar_Range (gnat_type)))
+ {
+ gnat_hb = Low_Bound (gnat_scalar_range);
+ gcc_assert (Nkind (gnat_hb) == N_Integer_Literal);
+ }
+ else
+ return false;
+
+ /* We need at least a signed 64-bit type to catch most cases. */
+ gnu_lb = UI_To_gnu (Intval (gnat_lb), sbitsizetype);
+ gnu_hb = UI_To_gnu (Intval (gnat_hb), sbitsizetype);
+ if (TREE_OVERFLOW (gnu_lb) || TREE_OVERFLOW (gnu_hb))
+ return false;
+
+ /* If the low bound is the smallest integer, nothing can be smaller. */
+ gnu_lb_minus_one = size_binop (MINUS_EXPR, gnu_lb, sbitsize_one_node);
+ if (TREE_OVERFLOW (gnu_lb_minus_one))
+ return true;
+
+ return !tree_int_cst_lt (gnu_hb, gnu_lb_minus_one);
+}
+
/* Return true if GNAT_RANGE, a N_Range node, cannot be superflat, i.e. if the
- inequality HB >= LB-1 is true. LB and HB are the low and high bounds. */
+ inequality HB >= LB - 1 is true. LB and HB are the low and high bounds. */
static bool
-cannot_be_superflat (Node_Id gnat_range)
+range_cannot_be_superflat (Node_Id gnat_range)
{
Node_Id gnat_lb = Low_Bound (gnat_range), gnat_hb = High_Bound (gnat_range);
- Node_Id scalar_range;
+ Node_Id gnat_scalar_range;
tree gnu_lb, gnu_hb, gnu_lb_minus_one;
/* If the low bound is not constant, try to find an upper bound. */
while (Nkind (gnat_lb) != N_Integer_Literal
&& (Ekind (Etype (gnat_lb)) == E_Signed_Integer_Subtype
|| Ekind (Etype (gnat_lb)) == E_Modular_Integer_Subtype)
- && (scalar_range = Scalar_Range (Etype (gnat_lb)))
- && (Nkind (scalar_range) == N_Signed_Integer_Type_Definition
- || Nkind (scalar_range) == N_Range))
- gnat_lb = High_Bound (scalar_range);
+ && (gnat_scalar_range = Scalar_Range (Etype (gnat_lb)))
+ && (Nkind (gnat_scalar_range) == N_Signed_Integer_Type_Definition
+ || Nkind (gnat_scalar_range) == N_Range))
+ gnat_lb = High_Bound (gnat_scalar_range);
/* If the high bound is not constant, try to find a lower bound. */
while (Nkind (gnat_hb) != N_Integer_Literal
&& (Ekind (Etype (gnat_hb)) == E_Signed_Integer_Subtype
|| Ekind (Etype (gnat_hb)) == E_Modular_Integer_Subtype)
- && (scalar_range = Scalar_Range (Etype (gnat_hb)))
- && (Nkind (scalar_range) == N_Signed_Integer_Type_Definition
- || Nkind (scalar_range) == N_Range))
- gnat_hb = Low_Bound (scalar_range);
+ && (gnat_scalar_range = Scalar_Range (Etype (gnat_hb)))
+ && (Nkind (gnat_scalar_range) == N_Signed_Integer_Type_Definition
+ || Nkind (gnat_scalar_range) == N_Range))
+ gnat_hb = Low_Bound (gnat_scalar_range);
/* If we have failed to find constant bounds, punt. */
if (Nkind (gnat_lb) != N_Integer_Literal
@@ -6749,12 +6797,12 @@ prepend_attributes (struct attrib **attr_list, Entity_Id gnat_entity)
if a variable needs to be created and DEFINITION is true if this is done
for a definition of GNAT_ENTITY. If NEED_VALUE is true, we need a result;
otherwise, we are just elaborating the expression for side-effects. If
- NEED_DEBUG is true, we need a variable for debugging purposes even if it
- isn't needed for code generation. */
+ NEED_FOR_DEBUG is true, we need a variable for debugging purposes even
+ if it isn't needed for code generation. */
static tree
elaborate_expression (Node_Id gnat_expr, Entity_Id gnat_entity, const char *s,
- bool definition, bool need_value, bool need_debug)
+ bool definition, bool need_value, bool need_for_debug)
{
tree gnu_expr;
@@ -6772,12 +6820,12 @@ elaborate_expression (Node_Id gnat_expr, Entity_Id gnat_entity, const char *s,
return NULL_TREE;
/* If it's a static expression, we don't need a variable for debugging. */
- if (need_debug && Compile_Time_Known_Value (gnat_expr))
- need_debug = false;
+ if (need_for_debug && Compile_Time_Known_Value (gnat_expr))
+ need_for_debug = false;
/* Otherwise, convert this tree to its GCC equivalent and elaborate it. */
gnu_expr = elaborate_expression_1 (gnat_to_gnu (gnat_expr), gnat_entity, s,
- definition, need_debug);
+ definition, need_for_debug);
/* Save the expression in case we try to elaborate this entity again. Since
it's not a DECL, don't check it. Don't save if it's a discriminant. */
@@ -6791,7 +6839,7 @@ elaborate_expression (Node_Id gnat_expr, Entity_Id gnat_entity, const char *s,
static tree
elaborate_expression_1 (tree gnu_expr, Entity_Id gnat_entity, const char *s,
- bool definition, bool need_debug)
+ bool definition, bool need_for_debug)
{
const bool expr_public_p = Is_Public (gnat_entity);
const bool expr_global_p = expr_public_p || global_bindings_p ();
@@ -6839,38 +6887,42 @@ elaborate_expression_1 (tree gnu_expr, Entity_Id gnat_entity, const char *s,
/* 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
+ we must 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
+ if (need_for_debug
+ && gnat_encodings != DWARF_GNAT_ENCODINGS_ALL
&& (TREE_CONSTANT (gnu_expr)
|| (!expr_public_p
&& DECL_P (gnu_expr)
&& !DECL_IGNORED_P (gnu_expr))))
- need_debug = false;
+ need_for_debug = false;
/* Now create it, possibly only for debugging purposes. */
- if (use_variable || need_debug)
+ if (use_variable || need_for_debug)
{
/* The following variable creation can happen when processing the body
- of subprograms that are defined out of the extended main unit and
+ of subprograms that are defined outside of the extended main unit and
inlined. In this case, we are not at the global scope, and thus the
new variable must not be tagged "external", as we used to do here as
- soon as DEFINITION was false. */
+ soon as DEFINITION was false. And note that we test Needs_Debug_Info
+ here instead of NEED_FOR_DEBUG because, once the variable is created,
+ whether or not debug information is generated for it is orthogonal to
+ the reason why it was created in the first place. */
tree gnu_decl
= create_var_decl (create_concat_name (gnat_entity, s), NULL_TREE,
TREE_TYPE (gnu_expr), gnu_expr, true,
expr_public_p, !definition && expr_global_p,
- expr_global_p, false, true, need_debug,
- NULL, gnat_entity);
+ expr_global_p, false, true,
+ Needs_Debug_Info (gnat_entity),
+ NULL, gnat_entity, false);
- /* Using this variable at debug time (if need_debug is true) requires a
- proper location. The back-end will compute a location for this
+ /* Using this variable for debug (if need_for_debug is true) requires
+ a proper location. The back-end will compute a location for this
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. */
- if (use_variable || (need_debug && !TREE_CONSTANT (gnu_expr)))
+ if (use_variable || (need_for_debug && !TREE_CONSTANT (gnu_expr)))
return gnu_decl;
}
@@ -6881,7 +6933,7 @@ elaborate_expression_1 (tree gnu_expr, Entity_Id gnat_entity, const char *s,
static tree
elaborate_expression_2 (tree gnu_expr, Entity_Id gnat_entity, const char *s,
- bool definition, bool need_debug, unsigned int align)
+ bool definition, bool need_for_debug, unsigned int align)
{
tree unit_align = size_int (align / BITS_PER_UNIT);
return
@@ -6890,7 +6942,7 @@ elaborate_expression_2 (tree gnu_expr, Entity_Id gnat_entity, const char *s,
gnu_expr,
unit_align),
gnat_entity, s, definition,
- need_debug),
+ need_for_debug),
unit_align);
}
@@ -7125,6 +7177,14 @@ gnat_to_gnu_field (Entity_Id gnat_field, tree gnu_record_type, int packed,
tree gnu_field, gnu_size, gnu_pos;
bool is_bitfield;
+ /* Force the type of the Not_Handled_By_Others field to be that of the
+ field in struct Exception_Data declared in raise.h instead of using
+ the declared boolean type. We need to do that because there is no
+ easy way to make use of a C compatible boolean type for the latter. */
+ if (gnu_field_id == not_handled_by_others_name_id
+ && gnu_field_type == boolean_type_node)
+ gnu_field_type = char_type_node;
+
/* The qualifier to be used in messages. */
if (is_aliased)
field_s = "aliased&";
@@ -7614,20 +7674,20 @@ warn_on_field_placement (tree gnu_field, Node_Id gnat_component_list,
const char *msg1
= in_variant
- ? "?variant layout may cause performance issues"
- : "?record layout may cause performance issues";
+ ? "??variant layout may cause performance issues"
+ : "??record layout may cause performance issues";
const char *msg2
= Ekind (gnat_field) == E_Discriminant
- ? "?discriminant & whose length is not multiple of a byte"
+ ? "??discriminant & whose length is not multiple of a byte"
: field_has_self_size (gnu_field)
- ? "?component & whose length depends on a discriminant"
+ ? "??component & whose length depends on a discriminant"
: field_has_variable_size (gnu_field)
- ? "?component & whose length is not fixed"
- : "?component & whose length is not multiple of a byte";
+ ? "??component & whose length is not fixed"
+ : "??component & whose length is not multiple of a byte";
const char *msg3
= do_reorder
- ? "?comes too early and was moved down"
- : "?comes too early and ought to be moved down";
+ ? "??comes too early and was moved down"
+ : "??comes too early and ought to be moved down";
post_error (msg1, gnat_field);
post_error_ne (msg2, gnat_field, gnat_field);
@@ -7674,7 +7734,7 @@ typedef struct vinfo
will be the single field of GNU_RECORD_TYPE and the GCC nodes for the
discriminants will be on GNU_FIELD_LIST. The other call to this function
is a recursive call for the component list of a variant and, in this case,
- GNU_FIELD_LIST is empty.
+ GNU_FIELD_LIST is empty. Note that GNAT_COMPONENT_LIST may be Empty.
PACKED is 1 if this is for a packed record or -1 if this is for a record
with Component_Alignment of Storage_Unit.
@@ -7715,7 +7775,7 @@ components_to_record (Node_Id gnat_component_list, Entity_Id gnat_record_type,
tree *p_gnu_rep_list)
{
const bool needs_xv_encodings
- = debug_info && gnat_encodings != DWARF_GNAT_ENCODINGS_MINIMAL;
+ = debug_info && gnat_encodings == DWARF_GNAT_ENCODINGS_ALL;
bool all_rep_and_size = all_rep && TYPE_SIZE (gnu_record_type);
bool variants_have_rep = all_rep;
bool layout_with_rep = false;
@@ -7730,7 +7790,8 @@ components_to_record (Node_Id gnat_component_list, Entity_Id gnat_record_type,
/* For each component referenced in a component declaration create a GCC
field and add it to the list, skipping pragmas in the GNAT list. */
gnu_last = tree_last (gnu_field_list);
- if (Present (Component_Items (gnat_component_list)))
+ if (Present (gnat_component_list)
+ && (Present (Component_Items (gnat_component_list))))
for (gnat_component_decl
= First_Non_Pragma (Component_Items (gnat_component_list));
Present (gnat_component_decl);
@@ -7787,7 +7848,10 @@ components_to_record (Node_Id gnat_component_list, Entity_Id gnat_record_type,
}
/* At the end of the component list there may be a variant part. */
- gnat_variant_part = Variant_Part (gnat_component_list);
+ if (Present (gnat_component_list))
+ gnat_variant_part = Variant_Part (gnat_component_list);
+ else
+ gnat_variant_part = Empty;
/* We create a QUAL_UNION_TYPE for the variant part since the variants are
mutually exclusive and should go in the same memory. To do this we need
@@ -8688,7 +8752,7 @@ annotate_object (Entity_Id gnat_entity, tree gnu_type, tree size, bool by_ref)
gnu_type = TREE_TYPE (gnu_type);
}
- if (Unknown_Esize (gnat_entity))
+ if (!Known_Esize (gnat_entity))
{
if (TREE_CODE (gnu_type) == RECORD_TYPE
&& TYPE_CONTAINS_TEMPLATE_P (gnu_type))
@@ -8700,7 +8764,7 @@ annotate_object (Entity_Id gnat_entity, tree gnu_type, tree size, bool by_ref)
Set_Esize (gnat_entity, annotate_value (size));
}
- if (Unknown_Alignment (gnat_entity))
+ if (!Known_Alignment (gnat_entity))
Set_Alignment (gnat_entity,
UI_From_Int (TYPE_ALIGN (gnu_type) / BITS_PER_UNIT));
}
@@ -9494,14 +9558,14 @@ intrin_arglists_compatible_p (intrin_binding_t * inb)
if (ada_type == void_type_node
&& btin_type != void_type_node)
{
- post_error ("?Ada arguments list too short!", inb->gnat_entity);
+ post_error ("??Ada arguments list too short!", inb->gnat_entity);
return false;
}
if (btin_type == void_type_node
&& ada_type != void_type_node)
{
- post_error_ne_num ("?Ada arguments list too long ('> ^)!",
+ post_error_ne_num ("??Ada arguments list too long ('> ^)!",
inb->gnat_entity, inb->gnat_entity, argpos);
return false;
}
@@ -9510,7 +9574,7 @@ intrin_arglists_compatible_p (intrin_binding_t * inb)
argpos ++;
if (intrin_types_incompatible_p (ada_type, btin_type))
{
- post_error_ne_num ("?intrinsic binding type mismatch on argument ^!",
+ post_error_ne_num ("??intrinsic binding type mismatch on argument ^!",
inb->gnat_entity, inb->gnat_entity, argpos);
return false;
}
@@ -9541,7 +9605,7 @@ intrin_return_compatible_p (intrin_binding_t * inb)
handles void/void as well. */
if (intrin_types_incompatible_p (btin_return_type, ada_return_type))
{
- post_error ("?intrinsic binding type mismatch on return value!",
+ post_error ("??intrinsic binding type mismatch on return value!",
inb->gnat_entity);
return false;
}
@@ -10175,7 +10239,12 @@ associate_original_type_to_packed_array (tree gnu_type, Entity_Id gnat_entity)
gcc_assert (TYPE_IMPL_PACKED_ARRAY_P (gnu_type));
- if (gnat_encodings == DWARF_GNAT_ENCODINGS_MINIMAL)
+ if (gnat_encodings == DWARF_GNAT_ENCODINGS_ALL)
+ {
+ add_parallel_type (gnu_type, gnu_original_array_type);
+ return NULL_TREE;
+ }
+ else
{
SET_TYPE_ORIGINAL_PACKED_ARRAY (gnu_type, gnu_original_array_type);
@@ -10184,11 +10253,6 @@ associate_original_type_to_packed_array (tree gnu_type, Entity_Id gnat_entity)
original_name = DECL_NAME (original_name);
return original_name;
}
- else
- {
- 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 bf49794..89b9a11 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-2020, Free Software Foundation, Inc. *
+ * Copyright (C) 2010-2021, Free Software Foundation, Inc. *
* *
* GNAT is free software; you can redistribute 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 328e5f3..49b85a4 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-2020, Free Software Foundation, Inc. *
+ * Copyright (C) 1992-2021, Free Software Foundation, Inc. *
* *
* GNAT is free software; you can redistribute it and/or modify it under *
* terms of the GNU General Public License as published by the Free Soft- *
@@ -233,24 +233,24 @@ extern "C" {
structures and then generates code. */
extern void gigi (Node_Id gnat_root,
int max_gnat_node,
- int number_name,
- struct Node *nodes_ptr,
- struct Flags *Flags_Ptr,
+ int number_name,
+ Field_Offset *node_offsets_ptr,
+ any_slot *slots_ptr,
Node_Id *next_node_ptr,
Node_Id *prev_node_ptr,
struct Elist_Header *elists_ptr,
- struct Elmt_Item *elmts_ptr,
- struct String_Entry *strings_ptr,
- Char_Code *strings_chars_ptr,
- struct List_Header *list_headers_ptr,
- Nat number_file,
- struct File_Info_Type *file_info_ptr,
- Entity_Id standard_boolean,
- Entity_Id standard_integer,
- Entity_Id standard_character,
- Entity_Id standard_long_long_float,
- Entity_Id standard_exception_type,
- Int gigi_operating_mode);
+ struct Elmt_Item *elmts_ptr,
+ struct String_Entry *strings_ptr,
+ Char_Code *strings_chars_ptr,
+ struct List_Header *list_headers_ptr,
+ Nat number_file,
+ struct File_Info_Type *file_info_ptr,
+ Entity_Id standard_boolean,
+ Entity_Id standard_integer,
+ Entity_Id standard_character,
+ Entity_Id standard_long_long_float,
+ Entity_Id standard_exception_type,
+ Int gigi_operating_mode);
#ifdef __cplusplus
}
@@ -396,8 +396,8 @@ enum standard_datatypes
/* Identifier for the name of the _Parent field in tagged record types. */
ADT_parent_name_id,
- /* Identifier for the name of the Exception_Data type. */
- ADT_exception_data_name_id,
+ /* Identifier for the name of the Not_Handled_By_Others field. */
+ ADT_not_handled_by_others_name_id,
/* Types and decls used by the SJLJ exception mechanism. */
ADT_jmpbuf_type,
@@ -467,7 +467,8 @@ extern GTY(()) tree gnat_raise_decls_ext[(int) LAST_REASON_CODE + 1];
#define mulv64_decl gnat_std_decls[(int) ADT_mulv64_decl]
#define mulv128_decl gnat_std_decls[(int) ADT_mulv128_decl]
#define parent_name_id gnat_std_decls[(int) ADT_parent_name_id]
-#define exception_data_name_id gnat_std_decls[(int) ADT_exception_data_name_id]
+#define not_handled_by_others_name_id \
+ gnat_std_decls[(int) ADT_not_handled_by_others_name_id]
#define jmpbuf_type gnat_std_decls[(int) ADT_jmpbuf_type]
#define jmpbuf_ptr_type gnat_std_decls[(int) ADT_jmpbuf_ptr_type]
#define get_jmpbuf_decl gnat_std_decls[(int) ADT_get_jmpbuf_decl]
diff --git a/gcc/ada/gcc-interface/lang-specs.h b/gcc/ada/gcc-interface/lang-specs.h
index f0ef3b92..f5a7496 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-2020, Free Software Foundation, Inc. *
+ * Copyright (C) 1992-2021, Free Software Foundation, Inc. *
* *
* GNAT is free software; you can redistribute 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/misc.c b/gcc/ada/gcc-interface/misc.c
index d0867e0..96199bd 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-2020, Free Software Foundation, Inc. *
+ * Copyright (C) 1992-2021, Free Software Foundation, Inc. *
* *
* GNAT is 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,7 +63,7 @@ const char **save_argv;
/* GNAT argc and argv generated by the binder for all Ada programs. */
extern int gnat_argc;
-extern const char **gnat_argv;
+extern char **gnat_argv;
/* Ada code requires variables for these settings rather than elements
of the global_options structure because they are imported. */
@@ -241,7 +241,7 @@ gnat_init_options (unsigned int decoded_options_count,
save_argv[save_argc] = NULL;
/* Pass just the name of the command through the regular channel. */
- gnat_argv = (const char **) xmalloc (sizeof (char *));
+ gnat_argv = (char **) xmalloc (sizeof (char *));
gnat_argv[0] = xstrdup (save_argv[0]);
gnat_argc = 1;
}
@@ -256,6 +256,9 @@ gnat_post_options (const char **pfilename ATTRIBUTE_UNUSED)
/* Excess precision other than "fast" requires front-end support. */
if (flag_excess_precision == EXCESS_PRECISION_STANDARD)
sorry ("%<-fexcess-precision=standard%> for Ada");
+ else if (flag_excess_precision == EXCESS_PRECISION_FLOAT16)
+ sorry ("%<-fexcess-precision=16%> for Ada");
+
flag_excess_precision = EXCESS_PRECISION_FAST;
/* No psABI change warnings for Ada. */
@@ -370,6 +373,9 @@ gnat_init (void)
sbitsize_one_node = sbitsize_int (1);
sbitsize_unit_node = sbitsize_int (BITS_PER_UNIT);
+ /* In Ada, we do not use location ranges. */
+ line_table->default_range_bits = 0;
+
/* Register our internal error function. */
global_dc->internal_error = &internal_error_function;
@@ -749,7 +755,7 @@ gnat_type_max_size (const_tree gnu_type)
type's alignment and return the result in units. */
if (tree_fits_uhwi_p (max_ada_size))
max_size_unit
- = size_binop (CEIL_DIV_EXPR,
+ = size_binop (EXACT_DIV_EXPR,
round_up (max_ada_size, TYPE_ALIGN (gnu_type)),
bitsize_unit_node);
}
@@ -803,7 +809,7 @@ gnat_get_array_descr_info (const_tree const_type,
/* 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)
+ && gnat_encodings != DWARF_GNAT_ENCODINGS_ALL)
{
/* This will be our base object address. Note that we assume that
pointers to this will actually point to the array field (thin
@@ -898,7 +904,7 @@ gnat_get_array_descr_info (const_tree const_type,
if (TYPE_CONTEXT (first_dimen)
&& TREE_CODE (TYPE_CONTEXT (first_dimen)) != RECORD_TYPE
&& CONTAINS_PLACEHOLDER_P (TYPE_MIN_VALUE (index_type))
- && gnat_encodings != DWARF_GNAT_ENCODINGS_MINIMAL)
+ && gnat_encodings == DWARF_GNAT_ENCODINGS_ALL)
{
info->dimen[i].lower_bound = NULL_TREE;
info->dimen[i].upper_bound = NULL_TREE;
@@ -940,7 +946,7 @@ gnat_get_array_descr_info (const_tree const_type,
info->associated = NULL_TREE;
info->data_location = NULL_TREE;
- if (gnat_encodings == DWARF_GNAT_ENCODINGS_MINIMAL)
+ if (gnat_encodings != DWARF_GNAT_ENCODINGS_ALL)
{
/* When arrays contain dynamically-sized elements, we usually wrap them
in padding types, or we create constrained types for them. Then, if
diff --git a/gcc/ada/gcc-interface/system.ads b/gcc/ada/gcc-interface/system.ads
index f54c43f..cfd9bb9 100644
--- a/gcc/ada/gcc-interface/system.ads
+++ b/gcc/ada/gcc-interface/system.ads
@@ -7,7 +7,7 @@
-- S p e c --
-- (Compiler Version) --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, 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 --
@@ -50,6 +50,10 @@ pragma Restrictions (No_Finalization);
-- access type on incomplete type Perm_Tree_Wrapper (which is required for
-- defining a recursive type).
+pragma Restrictions (No_Tasking);
+-- Make it explicit that tasking is not used in the compiler, which also
+-- allows generating simpler and more efficient code.
+
package System is
pragma Pure;
-- Note that we take advantage of the implementation permission to make
@@ -145,7 +149,6 @@ private
-- parameters is not too critical for the compiler version (e.g. we
-- do not use floating-point anyway in the compiler).
- AAMP : constant Boolean := False;
Backend_Divide_Checks : constant Boolean := False;
Backend_Overflow_Checks : constant Boolean := False;
Command_Line_Args : constant Boolean := True;
@@ -153,8 +156,6 @@ private
Denorm : constant Boolean := True;
Duration_32_Bits : constant Boolean := False;
Exit_Status_Supported : constant Boolean := True;
- Fractional_Fixed_Ops : constant Boolean := False;
- Frontend_Layout : constant Boolean := False;
Machine_Overflows : constant Boolean := False;
Machine_Rounds : constant Boolean := True;
Preallocated_Stacks : constant Boolean := False;
@@ -172,13 +173,4 @@ private
Frontend_Exceptions : constant Boolean := False;
ZCX_By_Default : constant Boolean := True;
- -- Obsolete entries, to be removed eventually (bootstrap issues)
-
- Front_End_ZCX_Support : constant Boolean := False;
- High_Integrity_Mode : constant Boolean := False;
- Long_Shifts_Inlined : constant Boolean := True;
- Functions_Return_By_DSP : constant Boolean := False;
- Support_64_Bit_Divides : constant Boolean := True;
- GCC_ZCX_Support : constant Boolean := True;
-
end System;
diff --git a/gcc/ada/gcc-interface/targtyps.c b/gcc/ada/gcc-interface/targtyps.c
index 60a37e1..704172d 100644
--- a/gcc/ada/gcc-interface/targtyps.c
+++ b/gcc/ada/gcc-interface/targtyps.c
@@ -6,7 +6,7 @@
* *
* Body *
* *
- * Copyright (C) 1992-2020, Free Software Foundation, Inc. *
+ * Copyright (C) 1992-2021, Free Software Foundation, Inc. *
* *
* GNAT is free software; you can redistribute 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 ae7a52f..3df56aa 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-2020, Free Software Foundation, Inc. *
+ * Copyright (C) 1992-2021, Free Software Foundation, Inc. *
* *
* GNAT is 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 @@
#define ALLOCA_THRESHOLD 1000
/* Pointers to front-end tables accessed through macros. */
-struct Node *Nodes_Ptr;
-struct Flags *Flags_Ptr;
+Field_Offset *Node_Offsets_Ptr;
+any_slot *Slots_Ptr;
Node_Id *Next_Node_Ptr;
Node_Id *Prev_Node_Ptr;
struct Elist_Header *Elists_Ptr;
@@ -112,7 +112,7 @@ struct GTY (()) parm_attr_d {
typedef struct parm_attr_d *parm_attr;
-
+/* Structure used to record information for a function. */
struct GTY(()) language_function {
vec<parm_attr, va_gc> *parm_attr_cache;
bitmap named_ret_val;
@@ -194,9 +194,9 @@ struct GTY(()) range_check_info_d {
typedef struct range_check_info_d *range_check_info;
-
/* Structure used to record information for a loop. */
struct GTY(()) loop_info_d {
+ tree fndecl;
tree stmt;
tree loop_var;
tree low_bound;
@@ -205,11 +205,11 @@ struct GTY(()) loop_info_d {
tree omp_construct_clauses;
enum tree_code omp_code;
vec<range_check_info, va_gc> *checks;
+ vec<tree, va_gc> *invariants;
};
typedef struct loop_info_d *loop_info;
-
/* Stack of loop_info structures associated with LOOP_STMT nodes. */
static GTY(()) vec<loop_info, va_gc> *gnu_loop_stack;
@@ -251,17 +251,27 @@ static tree build_raise_check (int, enum exception_info_kind);
static tree create_init_temporary (const char *, tree, tree *, Node_Id);
static bool maybe_make_gnu_thunk (Entity_Id gnat_thunk, tree gnu_thunk);
-/* Hooks for debug info back-ends, only supported and used in a restricted set
- of configurations. */
-static const char *extract_encoding (const char *) ATTRIBUTE_UNUSED;
-static const char *decode_name (const char *) ATTRIBUTE_UNUSED;
-
/* This makes gigi's file_info_ptr visible in this translation unit,
so that Sloc_to_locus can look it up when deciding whether to map
decls to instances. */
static struct File_Info_Type *file_map;
+/* Return the string of the identifier allocated for the file name Id. */
+
+static const char*
+File_Name_to_gnu (Name_Id Id)
+{
+ /* __gnat_to_canonical_file_spec translates file names from pragmas
+ Source_Reference that contain host style syntax not understood by GDB. */
+ const char *name = __gnat_to_canonical_file_spec (Get_Name_String (Id));
+
+ /* Use the identifier table to make a permanent copy of the file name as
+ the name table gets reallocated after Gigi returns but before all the
+ debugging information is output. */
+ return IDENTIFIER_POINTER (get_identifier (name));
+}
+
/* This is the main program of the back-end. It sets up all the table
structures and then generates code. */
@@ -269,8 +279,8 @@ void
gigi (Node_Id gnat_root,
int max_gnat_node,
int number_name ATTRIBUTE_UNUSED,
- struct Node *nodes_ptr,
- struct Flags *flags_ptr,
+ Field_Offset *node_offsets_ptr,
+ any_slot *slots_ptr,
Node_Id *next_node_ptr,
Node_Id *prev_node_ptr,
struct Elist_Header *elists_ptr,
@@ -295,8 +305,8 @@ gigi (Node_Id gnat_root,
max_gnat_nodes = max_gnat_node;
- Nodes_Ptr = nodes_ptr;
- Flags_Ptr = flags_ptr;
+ Node_Offsets_Ptr = node_offsets_ptr;
+ Slots_Ptr = slots_ptr;
Next_Node_Ptr = next_node_ptr;
Prev_Node_Ptr = prev_node_ptr;
Elists_Ptr = elists_ptr;
@@ -315,23 +325,18 @@ gigi (Node_Id gnat_root,
for (i = 0; i < number_file; i++)
{
- /* Use the identifier table to make a permanent copy of the filename as
- the name table gets reallocated after Gigi returns but before all the
- debugging information is output. The __gnat_to_canonical_file_spec
- call translates filenames from pragmas Source_Reference that contain
- host style syntax not understood by gdb. */
- const char *filename
- = IDENTIFIER_POINTER
- (get_identifier
- (__gnat_to_canonical_file_spec
- (Get_Name_String (file_info_ptr[i].File_Name))));
-
/* We rely on the order isomorphism between files and line maps. */
- gcc_assert ((int) LINEMAPS_ORDINARY_USED (line_table) == i);
+ if ((int) LINEMAPS_ORDINARY_USED (line_table) != i)
+ {
+ gcc_assert (i > 0);
+ error ("%s contains too many lines",
+ File_Name_to_gnu (file_info_ptr[i - 1].File_Name));
+ }
/* We create the line map for a source file at once, with a fixed number
of columns chosen to avoid jumping over the next power of 2. */
- linemap_add (line_table, LC_ENTER, 0, filename, 1);
+ linemap_add (line_table, LC_ENTER, 0,
+ File_Name_to_gnu (file_info_ptr[i].File_Name), 1);
linemap_line_start (line_table, file_info_ptr[i].Num_Source_Lines, 252);
linemap_position_for_column (line_table, 252 - 1);
linemap_add (line_table, LC_LEAVE, 0, NULL, 0);
@@ -456,13 +461,20 @@ gigi (Node_Id gnat_root,
/* Name of the _Parent field in tagged record types. */
parent_name_id = get_identifier (Get_Name_String (Name_uParent));
- /* Name of the Exception_Data type defined in System.Standard_Library. */
- exception_data_name_id
- = get_identifier ("system__standard_library__exception_data");
+ /* Name of the Not_Handled_By_Others field in exception record types. */
+ not_handled_by_others_name_id = get_identifier ("not_handled_by_others");
/* Make the types and functions used for exception processing. */
except_type_node = gnat_to_gnu_type (Base_Type (standard_exception_type));
+ for (t = TYPE_FIELDS (except_type_node); t; t = DECL_CHAIN (t))
+ if (DECL_NAME (t) == not_handled_by_others_name_id)
+ {
+ not_handled_by_others_decl = t;
+ break;
+ }
+ gcc_assert (DECL_P (not_handled_by_others_decl));
+
jmpbuf_type
= build_array_type (gnat_type_for_mode (Pmode, 0),
build_index_type (size_int (5)));
@@ -490,15 +502,6 @@ gigi (Node_Id gnat_root,
NULL_TREE),
NULL_TREE, is_default, true, true, true, false, false, NULL, Empty);
- not_handled_by_others_decl = get_identifier ("not_handled_by_others");
- for (t = TYPE_FIELDS (except_type_node); t; t = DECL_CHAIN (t))
- if (DECL_NAME (t) == not_handled_by_others_decl)
- {
- not_handled_by_others_decl = t;
- break;
- }
- gcc_assert (DECL_P (not_handled_by_others_decl));
-
/* setjmp returns an integer and has one operand, which is a pointer to
a jmpbuf. */
setjmp_decl
@@ -747,7 +750,7 @@ build_raise_check (int check, enum exception_info_kind kind)
strcpy (Name_Buffer, pfx);
Name_Len = sizeof (pfx) - 1;
- Get_RT_Exception_Name (check);
+ Get_RT_Exception_Name ((enum RT_Exception_Code) check);
if (kind == exception_simple)
{
@@ -1450,17 +1453,17 @@ Pragma_to_gnu (Node_Id gnat_node)
{
case Name_Off:
if (optimize)
- post_error ("must specify -O0?", gnat_node);
+ post_error ("must specify -O0??", gnat_node);
break;
case Name_Space:
if (!optimize_size)
- post_error ("must specify -Os?", gnat_node);
+ post_error ("must specify -Os??", gnat_node);
break;
case Name_Time:
if (!optimize)
- post_error ("insufficient -O value?", gnat_node);
+ post_error ("insufficient -O value??", gnat_node);
break;
default:
@@ -1470,7 +1473,7 @@ Pragma_to_gnu (Node_Id gnat_node)
case Pragma_Reviewable:
if (write_symbols == NO_DEBUG)
- post_error ("must specify -g?", gnat_node);
+ post_error ("must specify -g??", gnat_node);
break;
case Pragma_Warning_As_Error:
@@ -1571,17 +1574,17 @@ Pragma_to_gnu (Node_Id gnat_node)
option_index = find_opt (option_string + 1, lang_mask);
if (option_index == OPT_SPECIAL_unknown)
{
- post_error ("?unknown -W switch", gnat_node);
+ post_error ("unknown -W switch??", gnat_node);
break;
}
else if (!(cl_options[option_index].flags & CL_WARNING))
{
- post_error ("?-W switch does not control warning", gnat_node);
+ post_error ("-W switch does not control warning??", gnat_node);
break;
}
else if (!(cl_options[option_index].flags & lang_mask))
{
- post_error ("?-W switch not valid for Ada", gnat_node);
+ post_error ("-W switch not valid for Ada??", gnat_node);
break;
}
if (cl_options[option_index].flags & CL_JOINED)
@@ -2763,13 +2766,27 @@ find_loop_for (tree expr, tree *disp, bool *neg_p)
if (TREE_CODE (var) != VAR_DECL)
return NULL;
- if (decl_function_context (var) != current_function_decl)
- return NULL;
+ gcc_checking_assert (vec_safe_length (gnu_loop_stack) > 0);
+
+ FOR_EACH_VEC_ELT_REVERSE (*gnu_loop_stack, i, iter)
+ if (iter->loop_var == var && iter->fndecl == current_function_decl)
+ break;
+
+ return iter;
+}
+
+/* Return the innermost enclosing loop in the current function. */
+
+static struct loop_info_d *
+find_loop (void)
+{
+ struct loop_info_d *iter = NULL;
+ unsigned int i;
- gcc_assert (vec_safe_length (gnu_loop_stack) > 0);
+ gcc_checking_assert (vec_safe_length (gnu_loop_stack) > 0);
FOR_EACH_VEC_ELT_REVERSE (*gnu_loop_stack, i, iter)
- if (var == iter->loop_var)
+ if (iter->fndecl == current_function_decl)
break;
return iter;
@@ -2919,26 +2936,30 @@ independent_iterations_p (tree stmt_list)
return true;
}
-/* 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.
-
- We expect the top of gnu_loop_stack to hold a pointer to the loop info
- setup for the translation, which holds a pointer to the initial gnu loop
- stmt node. We return the new gnu loop statement to use.
-
- We might also set *GNU_COND_EXPR_P to request a variant of the translation
- scheme in Loop_Statement_to_gnu. */
+/* Subroutine of gnat_to_gnu to translate gnat_node, an N_Loop_Statement,
+ to a GCC tree, which is returned. */
static tree
-Regular_Loop_to_gnu (Node_Id gnat_node, tree *gnu_cond_expr_p)
+Loop_Statement_to_gnu (Node_Id gnat_node)
{
const Node_Id gnat_iter_scheme = Iteration_Scheme (gnat_node);
- struct loop_info_d *const gnu_loop_info = gnu_loop_stack->last ();
- tree gnu_loop_stmt = gnu_loop_info->stmt;
- tree gnu_loop_label = LOOP_STMT_LABEL (gnu_loop_stmt);
- tree gnu_cond_expr = *gnu_cond_expr_p;
- tree gnu_low = NULL_TREE, gnu_high = NULL_TREE;
+ struct loop_info_d *gnu_loop_info = ggc_cleared_alloc<loop_info_d> ();
+ tree gnu_loop_stmt = build4 (LOOP_STMT, void_type_node, NULL_TREE,
+ NULL_TREE, NULL_TREE, NULL_TREE);
+ tree gnu_loop_label = create_artificial_label (input_location);
+ tree gnu_cond_expr = NULL_TREE, gnu_low = NULL_TREE, gnu_high = NULL_TREE;
+ tree gnu_result;
+
+ /* Push the loop_info structure associated with the LOOP_STMT. */
+ gnu_loop_info->fndecl = current_function_decl;
+ gnu_loop_info->stmt = gnu_loop_stmt;
+ vec_safe_push (gnu_loop_stack, gnu_loop_info);
+
+ /* Set location information for statement and end label. */
+ set_expr_location_from_node (gnu_loop_stmt, gnat_node);
+ Sloc_to_locus (Sloc (End_Label (gnat_node)),
+ &DECL_SOURCE_LOCATION (gnu_loop_label));
+ LOOP_STMT_LABEL (gnu_loop_stmt) = gnu_loop_label;
/* Set the condition under which the loop must keep going. If we have an
explicit condition, use it to set the location information throughout
@@ -3272,7 +3293,16 @@ Regular_Loop_to_gnu (Node_Id gnat_node, tree *gnu_cond_expr_p)
}
}
- /* Second, if loop vectorization is enabled and the iterations of the
+ /* Second, if we have recorded invariants to be hoisted, emit them. */
+ if (vec_safe_length (gnu_loop_info->invariants) > 0)
+ {
+ tree *iter;
+ unsigned int i;
+ FOR_EACH_VEC_ELT (*gnu_loop_info->invariants, i, iter)
+ add_stmt_with_node_force (*iter, gnat_node);
+ }
+
+ /* Third, if loop vectorization is enabled and the iterations of the
loop can easily be proved as independent, mark the loop. */
if (optimize >= 3
&& independent_iterations_p (LOOP_STMT_BODY (gnu_loop_stmt)))
@@ -3283,40 +3313,6 @@ Regular_Loop_to_gnu (Node_Id gnat_node, tree *gnu_cond_expr_p)
gnu_loop_stmt = end_stmt_group ();
}
- *gnu_cond_expr_p = gnu_cond_expr;
-
- return gnu_loop_stmt;
-}
-
-/* Subroutine of gnat_to_gnu to translate gnat_node, an N_Loop_Statement,
- to a GCC tree, which is returned. */
-
-static tree
-Loop_Statement_to_gnu (Node_Id gnat_node)
-{
- struct loop_info_d *gnu_loop_info = ggc_cleared_alloc<loop_info_d> ();
-
- tree gnu_loop_stmt = build4 (LOOP_STMT, void_type_node, NULL_TREE,
- NULL_TREE, NULL_TREE, NULL_TREE);
- tree gnu_cond_expr = NULL_TREE;
- tree gnu_loop_label = create_artificial_label (input_location);
- tree gnu_result;
-
- /* Push the loop_info structure associated with the LOOP_STMT. */
- vec_safe_push (gnu_loop_stack, gnu_loop_info);
-
- /* Set location information for statement and end label. */
- set_expr_location_from_node (gnu_loop_stmt, gnat_node);
- Sloc_to_locus (Sloc (End_Label (gnat_node)),
- &DECL_SOURCE_LOCATION (gnu_loop_label));
- LOOP_STMT_LABEL (gnu_loop_stmt) = gnu_loop_label;
-
- /* Save the statement for later reuse. */
- gnu_loop_info->stmt = gnu_loop_stmt;
-
- /* Perform the core loop body translation. */
- 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. */
if (gnu_cond_expr)
@@ -3889,7 +3885,9 @@ Subprogram_Body_to_gnu (Node_Id gnat_node)
}
/* Set the line number in the decl to correspond to that of the body. */
- if (!Sloc_to_locus (Sloc (gnat_node), &locus, false, gnu_subprog_decl))
+ if (DECL_IGNORED_P (gnu_subprog_decl))
+ locus = UNKNOWN_LOCATION;
+ else if (!Sloc_to_locus (Sloc (gnat_node), &locus, false, gnu_subprog_decl))
locus = input_location;
DECL_SOURCE_LOCATION (gnu_subprog_decl) = locus;
@@ -4241,7 +4239,7 @@ node_is_component (Node_Id gnat_node)
We implement 3 different semantics of atomicity in this function:
1. the Ada 95/2005/2012 semantics of the Atomic aspect/pragma,
- 2. the Ada 2020 semantics of the Atomic aspect/pragma,
+ 2. the Ada 2022 semantics of the Atomic aspect/pragma,
3. the semantics of the Volatile_Full_Access GNAT aspect/pragma.
They are mutually exclusive and the FE should have rejected conflicts. */
@@ -4288,7 +4286,7 @@ get_atomic_access (Node_Id gnat_node, atomic_acces_t *type, bool *sync)
gnat_node = Expression (gnat_node);
/* Up to Ada 2012, for Atomic itself, only reads and updates of the object as
- a whole require atomic access (RM C.6(15)). But, starting with Ada 2020,
+ a whole require atomic access (RM C.6(15)). But, starting with Ada 2022,
reads of or writes to a nonatomic subcomponent of the object also require
atomic access (RM C.6(19)). */
if (node_is_atomic (gnat_node))
@@ -4299,7 +4297,7 @@ get_atomic_access (Node_Id gnat_node, atomic_acces_t *type, bool *sync)
for (gnat_temp = gnat_node, gnat_parent = Parent (gnat_temp);
node_is_component (gnat_parent) && Prefix (gnat_parent) == gnat_temp;
gnat_temp = gnat_parent, gnat_parent = Parent (gnat_temp))
- if (Ada_Version < Ada_2020 || node_is_atomic (gnat_parent))
+ if (Ada_Version < Ada_2022 || node_is_atomic (gnat_parent))
goto not_atomic;
else
as_a_whole = false;
@@ -4318,7 +4316,7 @@ get_atomic_access (Node_Id gnat_node, atomic_acces_t *type, bool *sync)
for (gnat_temp = gnat_node;
node_is_component (gnat_temp);
gnat_temp = Prefix (gnat_temp))
- if ((Ada_Version >= Ada_2020 && node_is_atomic (Prefix (gnat_temp)))
+ if ((Ada_Version >= Ada_2022 && node_is_atomic (Prefix (gnat_temp)))
|| node_is_volatile_full_access (Prefix (gnat_temp)))
{
*type = OUTER_ATOMIC;
@@ -4379,6 +4377,69 @@ create_init_temporary (const char *prefix, tree gnu_init, tree *gnu_init_stmt,
return gnu_temp;
}
+/* Return true if TYPE is an array of scalar type. */
+
+static bool
+is_array_of_scalar_type (tree type)
+{
+ if (TREE_CODE (type) != ARRAY_TYPE)
+ return false;
+
+ type = TREE_TYPE (type);
+
+ return !AGGREGATE_TYPE_P (type) && !POINTER_TYPE_P (type);
+}
+
+/* Helper function for walk_tree, used by return_slot_opt_for_pure_call_p. */
+
+static tree
+find_decls_r (tree *tp, int *walk_subtrees, void *data)
+{
+ bitmap decls = (bitmap) data;
+
+ if (TYPE_P (*tp))
+ *walk_subtrees = 0;
+
+ else if (DECL_P (*tp))
+ bitmap_set_bit (decls, DECL_UID (*tp));
+
+ return NULL_TREE;
+}
+
+/* Return whether the assignment TARGET = CALL can be subject to the return
+ slot optimization, under the assumption that the called function be pure
+ in the Ada sense and return an array of scalar type. */
+
+static bool
+return_slot_opt_for_pure_call_p (tree target, tree call)
+{
+ /* Check that the target is a DECL. */
+ if (!DECL_P (target))
+ return false;
+
+ const bitmap decls = BITMAP_GGC_ALLOC ();
+ call_expr_arg_iterator iter;
+ tree arg;
+
+ /* Check that all the arguments have either a scalar type (we assume that
+ this means by-copy passing mechanism) or array of scalar type. */
+ FOR_EACH_CALL_EXPR_ARG (arg, iter, call)
+ {
+ tree arg_type = TREE_TYPE (arg);
+ if (TREE_CODE (arg_type) == REFERENCE_TYPE)
+ arg_type = TREE_TYPE (arg_type);
+
+ if (is_array_of_scalar_type (arg_type))
+ walk_tree_without_duplicates (&arg, find_decls_r, decls);
+
+ else if (AGGREGATE_TYPE_P (arg_type) || POINTER_TYPE_P (arg_type))
+ return false;
+ }
+
+ /* Check that the target is not referenced by the non-scalar arguments. */
+ return !bitmap_bit_p (decls, DECL_UID (target));
+}
+
/* Subroutine of gnat_to_gnu to translate gnat_node, either an N_Function_Call
or an N_Procedure_Call_Statement, to a GCC tree, which is returned.
GNU_RESULT_TYPE_P is a pointer to where we should place the result type.
@@ -4412,8 +4473,8 @@ 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 went_into_elab_proc = false;
- bool pushed_binding_level = false;
+ bool went_into_elab_proc;
+ bool pushed_binding_level;
bool variadic;
bool by_descriptor;
Entity_Id gnat_formal;
@@ -4496,6 +4557,8 @@ Call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target,
current_function_decl = get_elaboration_procedure ();
went_into_elab_proc = true;
}
+ else
+ went_into_elab_proc = false;
/* First, create the temporary for the return value when:
@@ -4503,15 +4566,16 @@ Call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target,
because we need to preserve the return value before copying back the
parameters.
- 2. There is no target and the call is made for neither an object, nor a
- renaming declaration, nor a return statement, nor an allocator, and
- the return type has variable size because in this case the gimplifier
- cannot create the temporary, or more generally is an aggregate type,
- because the gimplifier would create the temporary in the outermost
- scope instead of locally. But there is an exception for an allocator
- of an unconstrained record type with default discriminant because we
- allocate the actual size in this case, unlike the other 3 cases, so
- we need a temporary to fetch the discriminant and we create it here.
+ 2. There is no target and the call is made for neither the declaration
+ of an object (regular or renaming), nor a return statement, nor an
+ allocator, nor an aggregate, and the return type has variable size
+ because in this case the gimplifier cannot create the temporary, or
+ more generally is an aggregate type, because the gimplifier would
+ create the temporary in the outermost scope instead of locally here.
+ But there is an exception for an allocator of unconstrained record
+ type with default discriminant because we allocate the actual size
+ in this case, unlike in the other cases, so we need a temporary to
+ fetch the discriminant and we create it here.
3. There is a target and it is a slice or an array with fixed size,
and the return type has variable size, because the gimplifier
@@ -4537,6 +4601,7 @@ Call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target,
&& (!(Nkind (Parent (gnat_node)) == N_Qualified_Expression
&& Nkind (Parent (Parent (gnat_node))) == N_Allocator)
|| type_is_padding_self_referential (gnu_result_type))
+ && Nkind (Parent (gnat_node)) != N_Aggregate
&& AGGREGATE_TYPE_P (gnu_result_type)
&& !TYPE_IS_FAT_POINTER_P (gnu_result_type))
|| (gnu_target
@@ -4548,6 +4613,8 @@ Call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target,
|| (gnu_target
&& TREE_CODE (gnu_target) == COMPONENT_REF
&& DECL_BIT_FIELD (TREE_OPERAND (gnu_target, 1))
+ && DECL_SIZE (TREE_OPERAND (gnu_target, 1))
+ != TYPE_SIZE (TREE_TYPE (gnu_target))
&& type_is_padding_self_referential (gnu_result_type))))
{
gnu_retval = create_temporary ("R", gnu_result_type);
@@ -4563,6 +4630,8 @@ Call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target,
gnat_pushlevel ();
pushed_binding_level = true;
}
+ else
+ pushed_binding_level = false;
/* Create the list of the actual parameters as GCC expects it, namely a
chain of TREE_LIST nodes in which the TREE_VALUE field of each node
@@ -4753,7 +4822,9 @@ Call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target,
may have suppressed a conversion to the Etype of the actual earlier,
since the parent is a procedure call, so put it back here. Note that
we might have a dummy type here if the actual is the dereference of a
- pointer to it, but that's OK if the formal is passed by reference. */
+ pointer to it, but that's OK when the formal is passed by reference.
+ We also do not put back a conversion between an actual and a formal
+ that are unconstrained array types to avoid creating local bounds. */
tree gnu_actual_type = get_unpadded_type (Etype (gnat_actual));
if (TYPE_IS_DUMMY_P (gnu_actual_type))
gcc_assert (is_true_formal_parm && DECL_BY_REF_P (gnu_formal));
@@ -4761,6 +4832,11 @@ Call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target,
&& Nkind (gnat_actual) == N_Unchecked_Type_Conversion)
gnu_actual = unchecked_convert (gnu_actual_type, gnu_actual,
No_Truncation (gnat_actual));
+ else if ((TREE_CODE (TREE_TYPE (gnu_actual)) == UNCONSTRAINED_ARRAY_TYPE
+ || (TREE_CODE (TREE_TYPE (gnu_actual)) == RECORD_TYPE
+ && TYPE_CONTAINS_TEMPLATE_P (TREE_TYPE (gnu_actual))))
+ && TREE_CODE (gnu_formal_type) == UNCONSTRAINED_ARRAY_TYPE)
+ ;
else
gnu_actual = convert (gnu_actual_type, gnu_actual);
@@ -5155,6 +5231,17 @@ Call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target,
That's what has been done historically. */
if (return_type_with_variable_size_p (gnu_result_type))
op_code = INIT_EXPR;
+
+ /* If this is a call to a pure function returning an array of scalar
+ type, try to apply the return slot optimization. */
+ else if ((TYPE_READONLY (gnu_subprog_type)
+ || TYPE_RESTRICT (gnu_subprog_type))
+ && is_array_of_scalar_type (gnu_result_type)
+ && TYPE_MODE (gnu_result_type) == BLKmode
+ && aggregate_value_p (gnu_result_type, gnu_subprog_type)
+ && return_slot_opt_for_pure_call_p (gnu_target, gnu_call))
+ op_code = INIT_EXPR;
+
else
op_code = MODIFY_EXPR;
@@ -5278,7 +5365,7 @@ Handled_Sequence_Of_Statements_to_gnu (Node_Id gnat_node)
because of the unstructured form of EH used by fe_sjlj_eh, there
might be forward edges going to __builtin_setjmp receivers on which
it is uninitialized, although they will never be actually taken. */
- TREE_NO_WARNING (gnu_jmpsave_decl) = 1;
+ suppress_warning (gnu_jmpsave_decl, OPT_Wuninitialized);
gnu_jmpbuf_decl
= create_var_decl (get_identifier ("JMP_BUF"), NULL_TREE,
jmpbuf_type,
@@ -5515,7 +5602,7 @@ Exception_Handler_to_gnu_fe_sjlj (Node_Id gnat_node)
gnu_except_ptr_stack->last (),
convert (TREE_TYPE (gnu_except_ptr_stack->last ()),
build_unary_op (ADDR_EXPR, NULL_TREE, gnu_expr)));
-}
+ }
else
gcc_unreachable ();
@@ -6067,12 +6154,19 @@ Raise_Error_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p)
{
if (!gnu_cond)
gnu_cond = gnat_to_gnu (gnat_cond);
+ if (integer_zerop (gnu_cond))
+ return alloc_stmt_list ();
gnu_result = build3 (COND_EXPR, void_type_node, gnu_cond, gnu_result,
alloc_stmt_list ());
}
}
else
- gnu_result = build1 (NULL_EXPR, *gnu_result_type_p, gnu_result);
+ {
+ /* The condition field must not be present when the node is used as an
+ expression form. */
+ gigi_checking_assert (No (gnat_cond));
+ gnu_result = build1 (NULL_EXPR, *gnu_result_type_p, gnu_result);
+ }
return gnu_result;
}
@@ -6192,12 +6286,12 @@ tree
gnat_to_gnu (Node_Id gnat_node)
{
const Node_Kind kind = Nkind (gnat_node);
- bool went_into_elab_proc = false;
tree gnu_result = error_mark_node; /* Default to no value. */
tree gnu_result_type = void_type_node;
tree gnu_expr, gnu_lhs, gnu_rhs;
Node_Id gnat_temp;
atomic_acces_t aa_type;
+ bool went_into_elab_proc;
bool aa_sync;
/* Save node number for error message and set location information. */
@@ -6229,32 +6323,18 @@ gnat_to_gnu (Node_Id gnat_node)
build_call_raise (CE_Range_Check_Failed, gnat_node,
N_Raise_Constraint_Error));
- if ((statement_node_p (gnat_node) && kind != N_Null_Statement)
- || kind == N_Handled_Sequence_Of_Statements
- || kind == N_Implicit_Label_Declaration)
+ /* If this is a statement and we are at top level, it must be part of the
+ elaboration procedure, so mark us as being in that procedure. */
+ if ((statement_node_p (gnat_node)
+ || kind == N_Handled_Sequence_Of_Statements
+ || kind == N_Implicit_Label_Declaration)
+ && !current_function_decl)
{
- tree current_elab_proc = get_elaboration_procedure ();
-
- /* If this is a statement and we are at top level, it must be part of
- the elaboration procedure, so mark us as being in that procedure. */
- if (!current_function_decl)
- {
- current_function_decl = current_elab_proc;
- went_into_elab_proc = true;
- }
-
- /* If we are in the elaboration procedure, check if we are violating a
- No_Elaboration_Code restriction by having a statement there. Don't
- check for a possible No_Elaboration_Code restriction violation on
- N_Handled_Sequence_Of_Statements, as we want to signal an error on
- every nested real statement instead. This also avoids triggering
- spurious errors on dummy (empty) sequences created by the front-end
- for package bodies in some cases. */
- if (current_function_decl == current_elab_proc
- && kind != N_Handled_Sequence_Of_Statements
- && kind != N_Implicit_Label_Declaration)
- Check_Elaboration_Code_Allowed (gnat_node);
+ current_function_decl = get_elaboration_procedure ();
+ went_into_elab_proc = true;
}
+ else
+ went_into_elab_proc = false;
switch (kind)
{
@@ -6726,6 +6806,8 @@ gnat_to_gnu (Node_Id gnat_node)
else
{
tree gnu_field = gnat_to_gnu_field_decl (gnat_field);
+ tree gnu_offset;
+ struct loop_info_d *loop;
gnu_result
= build_component_ref (gnu_prefix, gnu_field,
@@ -6733,6 +6815,29 @@ gnat_to_gnu (Node_Id gnat_node)
== N_Attribute_Reference)
&& lvalue_required_for_attribute_p
(Parent (gnat_node)));
+
+ /* If optimization is enabled and we are inside a loop, we try to
+ hoist nonconstant but invariant offset computations outside of
+ the loop, since they very likely contain loads that could turn
+ out to be hard to move if they end up in active EH regions. */
+ if (optimize
+ && inside_loop_p ()
+ && TREE_CODE (gnu_result) == COMPONENT_REF
+ && (gnu_offset = component_ref_field_offset (gnu_result))
+ && !TREE_CONSTANT (gnu_offset)
+ && (gnu_offset = gnat_invariant_expr (gnu_offset))
+ && (loop = find_loop ()))
+ {
+ tree invariant
+ = build1 (SAVE_EXPR, TREE_TYPE (gnu_offset), gnu_offset);
+ vec_safe_push (loop->invariants, invariant);
+ tree field = TREE_OPERAND (gnu_result, 1);
+ tree factor
+ = size_int (DECL_OFFSET_ALIGN (field) / BITS_PER_UNIT);
+ /* Divide the offset by its alignment. */
+ TREE_OPERAND (gnu_result, 2)
+ = size_binop (EXACT_DIV_EXPR, invariant, factor);
+ }
}
gnu_result_type = get_unpadded_type (Etype (gnat_node));
@@ -6872,7 +6977,7 @@ gnat_to_gnu (Node_Id gnat_node)
if (align != 0 && align < oalign && !TYPE_ALIGN_OK (gnu_obj_type))
post_error_ne_tree_2
- ("?source alignment (^) '< alignment of & (^)",
+ ("??source alignment (^) '< alignment of & (^)",
gnat_node, Designated_Type (Etype (gnat_node)),
size_int (align / BITS_PER_UNIT), oalign / BITS_PER_UNIT);
}
@@ -7520,8 +7625,10 @@ gnat_to_gnu (Node_Id gnat_node)
if (gnu_return_label_stack->last ())
{
if (gnu_ret_val)
- add_stmt (build_binary_op (MODIFY_EXPR, NULL_TREE, gnu_ret_obj,
- gnu_ret_val));
+ add_stmt_with_node (build_binary_op (MODIFY_EXPR,
+ NULL_TREE, gnu_ret_obj,
+ gnu_ret_val),
+ gnat_node);
gnu_result = build1 (GOTO_EXPR, void_type_node,
gnu_return_label_stack->last ());
@@ -7887,7 +7994,7 @@ gnat_to_gnu (Node_Id gnat_node)
}
Clobber_Setup (gnat_node);
- while ((clobber = Clobber_Get_Next ()))
+ while ((clobber = (char *) Clobber_Get_Next ()))
gnu_clobbers
= tree_cons (NULL_TREE,
build_string (strlen (clobber) + 1, clobber),
@@ -8129,6 +8236,14 @@ gnat_to_gnu (Node_Id gnat_node)
gcc_unreachable ();
}
+ /* If we are in the elaboration procedure, check if we are violating the
+ No_Elaboration_Code restriction by having a non-empty statement. */
+ if (statement_node_p (gnat_node)
+ && !(TREE_CODE (gnu_result) == STATEMENT_LIST
+ && empty_stmt_list_p (gnu_result))
+ && current_function_decl == get_elaboration_procedure ())
+ Check_Elaboration_Code_Allowed (gnat_node);
+
/* If we pushed the processing of the elaboration routine, pop it back. */
if (went_into_elab_proc)
current_function_decl = NULL_TREE;
@@ -8177,7 +8292,7 @@ gnat_to_gnu (Node_Id gnat_node)
/* If the result is a constant that overflowed, raise Constraint_Error. */
if (TREE_CODE (gnu_result) == INTEGER_CST && TREE_OVERFLOW (gnu_result))
{
- post_error ("?`Constraint_Error` will be raised at run time", gnat_node);
+ post_error ("??`Constraint_Error` will be raised at run time", gnat_node);
gnu_result
= build1 (NULL_EXPR, gnu_result_type,
build_call_raise (CE_Overflow_Check_Failed, gnat_node,
@@ -8264,7 +8379,9 @@ gnat_to_gnu (Node_Id gnat_node)
much data. But do not remove it if it is already too small. */
if (type_is_padding_self_referential (TREE_TYPE (gnu_result))
&& !(TREE_CODE (gnu_result) == COMPONENT_REF
- && DECL_BIT_FIELD (TREE_OPERAND (gnu_result, 1))))
+ && DECL_BIT_FIELD (TREE_OPERAND (gnu_result, 1))
+ && DECL_SIZE (TREE_OPERAND (gnu_result, 1))
+ != TYPE_SIZE (TREE_TYPE (gnu_result))))
gnu_result = convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_result))),
gnu_result);
}
@@ -8317,7 +8434,7 @@ tree
gnat_to_gnu_external (Node_Id gnat_node)
{
const int save_force_global = force_global;
- bool went_into_elab_proc = false;
+ bool went_into_elab_proc;
/* Force the local context and create a fake scope that we zap
at the end so declarations will not be stuck either in the
@@ -8327,6 +8444,8 @@ gnat_to_gnu_external (Node_Id gnat_node)
current_function_decl = get_elaboration_procedure ();
went_into_elab_proc = true;
}
+ else
+ went_into_elab_proc = false;
force_global = 0;
gnat_pushlevel ();
@@ -8688,7 +8807,7 @@ gnat_gimplify_expr (tree *expr_p, gimple_seq *pre_p,
else
{
*expr_p = create_tmp_var (type, NULL);
- TREE_NO_WARNING (*expr_p) = 1;
+ suppress_warning (*expr_p);
}
gimplify_and_add (TREE_OPERAND (expr, 0), pre_p);
@@ -8736,6 +8855,31 @@ gnat_gimplify_expr (tree *expr_p, gimple_seq *pre_p,
return GS_UNHANDLED;
+ case CALL_EXPR:
+ /* If we are passing a constant fat pointer CONSTRUCTOR, make sure it is
+ put into static memory; this performs a restricted version of constant
+ propagation on fat pointers in calls. But do not do it for strings to
+ avoid blocking concatenation in the caller when it is inlined. */
+ for (int i = 0; i < call_expr_nargs (expr); i++)
+ {
+ tree arg = *(CALL_EXPR_ARGP (expr) + i);
+
+ if (TREE_CODE (arg) == CONSTRUCTOR
+ && TREE_CONSTANT (arg)
+ && TYPE_IS_FAT_POINTER_P (TREE_TYPE (arg)))
+ {
+ tree t = CONSTRUCTOR_ELT (arg, 0)->value;
+ if (TREE_CODE (t) == NOP_EXPR)
+ t = TREE_OPERAND (t, 0);
+ if (TREE_CODE (t) == ADDR_EXPR)
+ t = TREE_OPERAND (t, 0);
+ if (TREE_CODE (t) != STRING_CST)
+ *(CALL_EXPR_ARGP (expr) + i) = tree_output_constant_def (arg);
+ }
+ }
+
+ return GS_UNHANDLED;
+
case VIEW_CONVERT_EXPR:
op = TREE_OPERAND (expr, 0);
@@ -9131,13 +9275,13 @@ process_freeze_entity (Node_Id gnat_node)
gnu_new = gnat_to_gnu_entity (full_view, NULL_TREE, true);
/* Propagate back-annotations from full view to partial view. */
- if (Unknown_Alignment (gnat_entity))
- Set_Alignment (gnat_entity, Alignment (full_view));
+ if (!Known_Alignment (gnat_entity))
+ Copy_Alignment (gnat_entity, full_view);
- if (Unknown_Esize (gnat_entity))
+ if (!Known_Esize (gnat_entity))
Set_Esize (gnat_entity, Esize (full_view));
- if (Unknown_RM_Size (gnat_entity))
+ if (!Known_RM_Size (gnat_entity))
Set_RM_Size (gnat_entity, RM_Size (full_view));
/* The above call may have defined this entity (the simplest example
@@ -10185,7 +10329,7 @@ validate_unchecked_conversion (Node_Id gnat_node)
|| !alias_sets_conflict_p (get_alias_set (gnu_source_desig_type),
target_alias_set)))
{
- post_error_ne ("?possible aliasing problem for type&",
+ post_error_ne ("??possible aliasing problem for type&",
gnat_node, Target_Type (gnat_node));
post_error ("\\?use -fno-strict-aliasing switch for references",
gnat_node);
@@ -10211,7 +10355,7 @@ validate_unchecked_conversion (Node_Id gnat_node)
|| !alias_sets_conflict_p (get_alias_set (gnu_source_desig_type),
target_alias_set)))
{
- post_error_ne ("?possible aliasing problem for type&",
+ post_error_ne ("??possible aliasing problem for type&",
gnat_node, Target_Type (gnat_node));
post_error ("\\?use -fno-strict-aliasing switch for references",
gnat_node);
@@ -10401,27 +10545,6 @@ set_end_locus_from_node (tree gnu_node, Node_Id gnat_node)
}
}
-/* Return a colon-separated list of encodings contained in encoded Ada
- name. */
-
-static const char *
-extract_encoding (const char *name)
-{
- char *encoding = (char *) ggc_alloc_atomic (strlen (name));
- get_encoding (name, encoding);
- return encoding;
-}
-
-/* Extract the Ada name from an encoded name. */
-
-static const char *
-decode_name (const char *name)
-{
- char *decoded = (char *) ggc_alloc_atomic (strlen (name) * 2 + 60);
- __gnat_decode (name, decoded, 0);
- return decoded;
-}
-
/* Post an error message. MSG is the error message, properly annotated.
NODE is the node at which to post the error and the node to use for the
'&' substitution. */
diff --git a/gcc/ada/gcc-interface/utils.c b/gcc/ada/gcc-interface/utils.c
index 952f032..846d20a 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-2020, Free Software Foundation, Inc. *
+ * Copyright (C) 1992-2021, Free Software Foundation, Inc. *
* *
* GNAT is free software; you can redistribute it and/or modify it under *
* terms of the GNU General Public License as published by the Free Soft- *
@@ -784,7 +784,7 @@ gnat_pushdecl (tree decl, Node_Id gnat_node)
tree context = NULL_TREE;
struct deferred_decl_context_node *deferred_decl_context = NULL;
- /* If explicitely asked to make DECL global or if it's an imported nested
+ /* If explicitly asked to make DECL global or if it's an imported nested
object, short-circuit the regular Scope-based context computation. */
if (!((TREE_PUBLIC (decl) && DECL_EXTERNAL (decl)) || force_global == 1))
{
@@ -836,7 +836,8 @@ gnat_pushdecl (tree decl, Node_Id gnat_node)
if (!deferred_decl_context)
DECL_CONTEXT (decl) = context;
- TREE_NO_WARNING (decl) = (No (gnat_node) || Warnings_Off (gnat_node));
+ suppress_warning (decl, all_warnings,
+ No (gnat_node) || Warnings_Off (gnat_node));
/* Set the location of DECL and emit a declaration for it. */
if (Present (gnat_node) && !renaming_from_instantiation_p (gnat_node))
@@ -1276,7 +1277,7 @@ make_packable_type (tree type, bool in_record, unsigned int max_align)
finish_record_type (new_type, nreverse (new_field_list), 2, false);
relate_alias_sets (new_type, type, ALIAS_SET_COPY);
- if (gnat_encodings == DWARF_GNAT_ENCODINGS_MINIMAL)
+ if (gnat_encodings != DWARF_GNAT_ENCODINGS_ALL)
SET_TYPE_DEBUG_TYPE (new_type, TYPE_DEBUG_TYPE (type));
else if (TYPE_STUB_DECL (type))
SET_DECL_PARALLEL_TYPE (TYPE_STUB_DECL (new_type),
@@ -1547,7 +1548,7 @@ maybe_pad_type (tree type, tree size, unsigned int align,
TYPE_SIZE (record) = size ? size : orig_size;
TYPE_SIZE_UNIT (record)
= convert (sizetype,
- size_binop (CEIL_DIV_EXPR, TYPE_SIZE (record),
+ size_binop (EXACT_DIV_EXPR, TYPE_SIZE (record),
bitsize_unit_node));
/* If we are changing the alignment and the input type is a record with
@@ -1609,7 +1610,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)
+ if (gnat_encodings != DWARF_GNAT_ENCODINGS_ALL)
SET_TYPE_DEBUG_TYPE (record, maybe_debug_type (type));
/* Unless debugging information isn't being written for the input type,
@@ -1637,14 +1638,14 @@ maybe_pad_type (tree type, tree size, unsigned int align,
= create_var_decl (concat_name (name, "XVZ"), NULL_TREE, sizetype,
size_unit, true, global_bindings_p (),
!definition && global_bindings_p (), false,
- false, true, true, NULL, gnat_entity);
+ false, true, true, NULL, gnat_entity, false);
TYPE_SIZE_UNIT (record) = size_unit;
}
/* There is no need to show what we are a subtype of when outputting as
few encodings as possible: regular debugging infomation makes this
redundant. */
- if (gnat_encodings != DWARF_GNAT_ENCODINGS_MINIMAL)
+ if (gnat_encodings == DWARF_GNAT_ENCODINGS_ALL)
{
tree marker = make_node (RECORD_TYPE);
tree orig_name = TYPE_IDENTIFIER (type);
@@ -1721,11 +1722,11 @@ built:
if (Comes_From_Source (gnat_entity))
{
if (is_component_type)
- post_error_ne_tree ("component of& padded{ by ^ bits}?",
+ post_error_ne_tree ("component of& padded{ by ^ bits}??",
gnat_entity, gnat_entity,
size_diffop (size, orig_size));
else if (Present (gnat_error_node))
- post_error_ne_tree ("{^ }bits of & unused?",
+ post_error_ne_tree ("{^ }bits of & unused??",
gnat_error_node, gnat_entity,
size_diffop (size, orig_size));
}
@@ -1970,7 +1971,6 @@ finish_record_type (tree record_type, tree field_list, int rep_level,
{
const enum tree_code orig_code = TREE_CODE (record_type);
const bool had_size = TYPE_SIZE (record_type) != NULL_TREE;
- const bool had_size_unit = TYPE_SIZE_UNIT (record_type) != NULL_TREE;
const bool had_align = TYPE_ALIGN (record_type) > 0;
/* For all-repped records with a size specified, lay the QUAL_UNION_TYPE
out just like a UNION_TYPE, since the size will be fixed. */
@@ -1997,9 +1997,6 @@ finish_record_type (tree record_type, tree field_list, int rep_level,
if (!had_size)
TYPE_SIZE (record_type) = bitsize_zero_node;
-
- if (!had_size_unit)
- TYPE_SIZE_UNIT (record_type) = size_zero_node;
}
else
{
@@ -2155,19 +2152,22 @@ finish_record_type (tree record_type, tree field_list, int rep_level,
/* We need to set the regular sizes if REP_LEVEL is one. */
if (rep_level == 1)
{
+ /* We round TYPE_SIZE and TYPE_SIZE_UNIT up to TYPE_ALIGN separately
+ to avoid having very large masking constants in TYPE_SIZE_UNIT. */
+ const unsigned int align = TYPE_ALIGN (record_type);
+
/* If this is a padding record, we never want to make the size smaller
than what was specified in it, if any. */
- if (TYPE_IS_PADDING_P (record_type) && TYPE_SIZE (record_type))
+ if (TYPE_IS_PADDING_P (record_type) && had_size)
size = TYPE_SIZE (record_type);
-
- tree size_unit = had_size_unit
- ? TYPE_SIZE_UNIT (record_type)
- : convert (sizetype,
- size_binop (CEIL_DIV_EXPR, size,
- bitsize_unit_node));
- const unsigned int align = TYPE_ALIGN (record_type);
+ else
+ size = round_up (size, BITS_PER_UNIT);
TYPE_SIZE (record_type) = variable_size (round_up (size, align));
+
+ tree size_unit
+ = convert (sizetype,
+ size_binop (EXACT_DIV_EXPR, size, bitsize_unit_node));
TYPE_SIZE_UNIT (record_type)
= variable_size (round_up (size_unit, align / BITS_PER_UNIT));
}
@@ -2274,7 +2274,7 @@ rest_of_record_type_compilation (tree record_type)
/* If this record type is of variable size, make a parallel record type that
will tell the debugger how the former is laid out (see exp_dbug.ads). */
- if (var_size && gnat_encodings != DWARF_GNAT_ENCODINGS_MINIMAL)
+ if (var_size && gnat_encodings == DWARF_GNAT_ENCODINGS_ALL)
{
tree new_record_type
= make_node (TREE_CODE (record_type) == QUAL_UNION_TYPE
@@ -3543,9 +3543,6 @@ finish_subprog_decl (tree decl, tree asm_name, tree type)
DECL_BY_REFERENCE (result_decl) = TREE_ADDRESSABLE (type);
DECL_RESULT (decl) = result_decl;
- /* Propagate the "const" property. */
- TREE_READONLY (decl) = TYPE_READONLY (type);
-
/* Propagate the "pure" property. */
DECL_PURE_P (decl) = TYPE_RESTRICT (type);
@@ -7016,8 +7013,7 @@ def_builtin_1 (enum built_in_function fncode,
return;
gcc_assert ((!both_p && !fallback_p)
- || !strncmp (name, "__builtin_",
- strlen ("__builtin_")));
+ || startswith (name, "__builtin_"));
libname = name + strlen ("__builtin_");
decl = add_builtin_function (name, fntype, fncode, fnclass,
diff --git a/gcc/ada/gcc-interface/utils2.c b/gcc/ada/gcc-interface/utils2.c
index 316033b..e8ed4b2 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-2020, Free Software Foundation, Inc. *
+ * Copyright (C) 1992-2021, Free Software Foundation, Inc. *
* *
* GNAT is free software; you can redistribute it and/or modify it under *
* terms of the GNU General Public License as published by the Free Soft- *
@@ -1301,11 +1301,11 @@ build_binary_op (enum tree_code op_code, tree result_type,
if (TYPE_VOLATILE (operation_type))
TREE_THIS_VOLATILE (result) = 1;
}
- else
- TREE_CONSTANT (result)
- |= (TREE_CONSTANT (left_operand) && TREE_CONSTANT (right_operand));
+ else if (TREE_CONSTANT (left_operand) && TREE_CONSTANT (right_operand))
+ TREE_CONSTANT (result) = 1;
- TREE_SIDE_EFFECTS (result) |= has_side_effects;
+ if (has_side_effects)
+ TREE_SIDE_EFFECTS (result) = 1;
/* If we are working with modular types, perform the MOD operation
if something above hasn't eliminated the need for it. */
@@ -1528,7 +1528,9 @@ build_unary_op (enum tree_code op_code, tree result_type, tree operand)
result = build_fold_addr_expr (operand);
}
- TREE_CONSTANT (result) = staticp (operand) || TREE_CONSTANT (operand);
+ if (TREE_CONSTANT (operand) || staticp (operand))
+ TREE_CONSTANT (result) = 1;
+
break;
case INDIRECT_REF:
@@ -1957,14 +1959,19 @@ gnat_build_constructor (tree type, vec<constructor_elt, va_gc> *v)
the elements along the way for possible sorting purposes below. */
FOR_EACH_CONSTRUCTOR_ELT (v, n_elmts, obj, val)
{
- /* The predicate must be in keeping with output_constructor. */
+ /* The predicate must be in keeping with output_constructor and, unlike
+ initializer_constant_valid_p, we accept "&{...}" because we'll put
+ the CONSTRUCTOR into the constant pool during gimplification. */
if ((!TREE_CONSTANT (val) && !TREE_STATIC (val))
|| (TREE_CODE (type) == RECORD_TYPE
&& CONSTRUCTOR_BITFIELD_P (obj)
&& !initializer_constant_valid_for_bitfield_p (val))
- || !initializer_constant_valid_p (val,
- TREE_TYPE (val),
- TYPE_REVERSE_STORAGE_ORDER (type)))
+ || (!initializer_constant_valid_p (val,
+ TREE_TYPE (val),
+ TYPE_REVERSE_STORAGE_ORDER (type))
+ && !(TREE_CODE (val) == ADDR_EXPR
+ && TREE_CODE (TREE_OPERAND (val, 0)) == CONSTRUCTOR
+ && TREE_CONSTANT (TREE_OPERAND (val, 0)))))
allconstant = false;
if (!TREE_READONLY (val))
@@ -2064,7 +2071,9 @@ build_simple_component_ref (tree record, tree field, bool no_fold)
need to warn since this will be done on trying to declare the object. */
if (TREE_CODE (DECL_FIELD_OFFSET (field)) == INTEGER_CST
&& TREE_OVERFLOW (DECL_FIELD_OFFSET (field)))
- return NULL_TREE;
+ return build1 (NULL_EXPR, TREE_TYPE (field),
+ build_call_raise (SE_Object_Too_Large, Empty,
+ N_Raise_Storage_Error));
ref = build3 (COMPONENT_REF, TREE_TYPE (field), record, field, NULL_TREE);
@@ -2098,7 +2107,7 @@ build_simple_component_ref (tree record, tree field, bool no_fold)
return fold (ref);
}
-/* Likewise, but return NULL_EXPR and generate a Constraint_Error if the
+/* Likewise, but return NULL_EXPR and generate a Program_Error if the
field is not found in the record. */
tree
@@ -2108,10 +2117,13 @@ build_component_ref (tree record, tree field, bool no_fold)
if (ref)
return ref;
- /* Assume this is an invalid user field so raise Constraint_Error. */
+ /* The missing field should have been detected in the front-end. */
+ gigi_checking_assert (false);
+
+ /* Assume this is an invalid user field so raise Program_Error. */
return build1 (NULL_EXPR, TREE_TYPE (field),
- build_call_raise (CE_Discriminant_Check_Failed, Empty,
- N_Raise_Constraint_Error));
+ build_call_raise (PE_Explicit_Raise, Empty,
+ N_Raise_Program_Error));
}
/* Helper for build_call_alloc_dealloc, with arguments to be interpreted
@@ -2676,10 +2688,13 @@ gnat_stabilize_reference_1 (tree e, void *data)
gcc_unreachable ();
}
+ /* See gnat_rewrite_reference below for the rationale. */
TREE_READONLY (result) = TREE_READONLY (e);
- TREE_SIDE_EFFECTS (result) |= TREE_SIDE_EFFECTS (e);
TREE_THIS_VOLATILE (result) = TREE_THIS_VOLATILE (e);
+ if (TREE_SIDE_EFFECTS (e))
+ TREE_SIDE_EFFECTS (result) = 1;
+
return result;
}
@@ -2796,18 +2811,18 @@ gnat_rewrite_reference (tree ref, rewrite_fn func, void *data, tree *init)
gcc_unreachable ();
}
- /* TREE_THIS_VOLATILE and TREE_SIDE_EFFECTS set on the initial expression
- may not be sustained across some paths, such as the way via build1 for
- INDIRECT_REF. We reset those flags here in the general case, which is
- consistent with the GCC version of this routine.
+ /* TREE_READONLY and TREE_THIS_VOLATILE set on the initial expression may
+ not be sustained across some paths, such as the one for INDIRECT_REF.
Special care should be taken regarding TREE_SIDE_EFFECTS, because some
paths introduce side-effects where there was none initially (e.g. if a
SAVE_EXPR is built) and we also want to keep track of that. */
TREE_READONLY (result) = TREE_READONLY (ref);
- TREE_SIDE_EFFECTS (result) |= TREE_SIDE_EFFECTS (ref);
TREE_THIS_VOLATILE (result) = TREE_THIS_VOLATILE (ref);
+ if (TREE_SIDE_EFFECTS (ref))
+ TREE_SIDE_EFFECTS (result) = 1;
+
if (code == INDIRECT_REF
|| code == UNCONSTRAINED_ARRAY_REF
|| code == ARRAY_REF
@@ -2946,6 +2961,17 @@ gnat_invariant_expr (tree expr)
if (TREE_CONSTANT (expr))
return fold_convert (type, expr);
+ /* Deal with aligning patterns. */
+ if (TREE_CODE (expr) == BIT_AND_EXPR
+ && TREE_CONSTANT (TREE_OPERAND (expr, 1)))
+ {
+ tree op0 = gnat_invariant_expr (TREE_OPERAND (expr, 0));
+ if (op0)
+ return fold_build2 (BIT_AND_EXPR, type, op0, TREE_OPERAND (expr, 1));
+ else
+ return NULL_TREE;
+ }
+
/* Deal with addition or subtraction of constants. */
if (is_simple_additive_expression (expr, &add, &cst, &minus_p))
{
diff --git a/gcc/ada/gen_il-fields.ads b/gcc/ada/gen_il-fields.ads
new file mode 100644
index 0000000..0a3046e
--- /dev/null
+++ b/gcc/ada/gen_il-fields.ads
@@ -0,0 +1,948 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- G E N _ I L . F I E L D S --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 2020-2021, Free Software Foundation, Inc. --
+-- --
+-- GNAT is 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 Gen_IL.Types;
+
+package Gen_IL.Fields is
+
+ -- The following is "optional field enumeration" -- i.e. it is Field_Enum
+ -- (declared below) plus the special null value No_Field. See the spec of
+ -- Gen_IL.Gen for how to modify this. (Of course, in Ada we have to define
+ -- this backwards from the above conceptual description.)
+
+ -- Note that there are various subranges of this type declared below,
+ -- which might need to be kept in sync when modifying this.
+
+ -- Be sure to put new fields in the appropriate subrange (Field_Enum,
+ -- Node_Header_Field, Node_Field, Entity_Field -- search for comments
+ -- below).
+
+ type Opt_Field_Enum is
+ (No_Field,
+
+ -- Start of node fields:
+
+ Nkind,
+ Sloc,
+ In_List,
+ Rewrite_Ins,
+ Comes_From_Source,
+ Analyzed,
+ Error_Posted,
+ Small_Paren_Count,
+ Check_Actuals,
+ Has_Aspects,
+ Is_Ignored_Ghost_Node,
+ Link,
+
+ Abort_Present,
+ Abortable_Part,
+ Abstract_Present,
+ Accept_Handler_Records,
+ Accept_Statement,
+ Access_Definition,
+ Access_To_Subprogram_Definition,
+ Access_Types_To_Process,
+ Actions,
+ Activation_Chain_Entity,
+ Acts_As_Spec,
+ Actual_Designated_Subtype,
+ Address_Warning_Posted,
+ Aggregate_Bounds,
+ Aliased_Present,
+ Alloc_For_BIP_Return,
+ All_Others,
+ All_Present,
+ Alternatives,
+ Ancestor_Part,
+ Atomic_Sync_Required,
+ Array_Aggregate,
+ Aspect_On_Partial_View,
+ Aspect_Rep_Item,
+ Assignment_OK,
+ Attribute_Name,
+ At_End_Proc,
+ Aux_Decls_Node,
+ Backwards_OK,
+ Bad_Is_Detected,
+ Binding_Chars,
+ Body_Required,
+ Body_To_Inline,
+ Box_Present,
+ By_Ref,
+ Char_Literal_Value,
+ Chars,
+ Check_Address_Alignment,
+ Choice_Parameter,
+ Choices,
+ Class_Present,
+ Classifications,
+ Cleanup_Actions,
+ Comes_From_Extended_Return_Statement,
+ Compile_Time_Known_Aggregate,
+ Component_Associations,
+ Component_Clauses,
+ Component_Definition,
+ Component_Items,
+ Component_List,
+ Component_Name,
+ Componentwise_Assignment,
+ Condition,
+ Condition_Actions,
+ Config_Pragmas,
+ Constant_Present,
+ Constraint,
+ Constraints,
+ Context_Installed,
+ Context_Items,
+ Context_Pending,
+ Contract_Test_Cases,
+ Controlling_Argument,
+ Conversion_OK,
+ Convert_To_Return_False,
+ Corresponding_Aspect,
+ Corresponding_Body,
+ Corresponding_Entry_Body,
+ Corresponding_Formal_Spec,
+ Corresponding_Generic_Association,
+ Corresponding_Integer_Value,
+ Corresponding_Spec,
+ Corresponding_Spec_Of_Stub,
+ Corresponding_Stub,
+ Dcheck_Function,
+ Declarations,
+ Default_Expression,
+ Default_Storage_Pool,
+ Default_Name,
+ Default_Subtype_Mark,
+ Defining_Identifier,
+ Defining_Unit_Name,
+ Delay_Alternative,
+ Delay_Statement,
+ Delta_Expression,
+ Digits_Expression,
+ Discr_Check_Funcs_Built,
+ Discrete_Choices,
+ Discrete_Range,
+ Discrete_Subtype_Definition,
+ Discrete_Subtype_Definitions,
+ Discriminant_Specifications,
+ Discriminant_Type,
+ Do_Discriminant_Check,
+ Do_Division_Check,
+ Do_Length_Check,
+ Do_Overflow_Check,
+ Do_Range_Check,
+ Do_Storage_Check,
+ Elaborate_All_Desirable,
+ Elaborate_All_Present,
+ Elaborate_Desirable,
+ Elaborate_Present,
+ Else_Actions,
+ Else_Statements,
+ Elsif_Parts,
+ Enclosing_Variant,
+ End_Label,
+ End_Span,
+ Entity_Or_Associated_Node,
+ Entry_Body_Formal_Part,
+ Entry_Call_Alternative,
+ Entry_Call_Statement,
+ Entry_Direct_Name,
+ Entry_Index,
+ Entry_Index_Specification,
+ Etype,
+ Exception_Choices,
+ Exception_Handlers,
+ Exception_Junk,
+ Exception_Label,
+ Expansion_Delayed,
+ Explicit_Actual_Parameter,
+ Explicit_Generic_Actual_Parameter,
+ Expression,
+ Expression_Copy,
+ Expressions,
+ First_Bit,
+ First_Inlined_Subprogram,
+ First_Name,
+ First_Named_Actual,
+ First_Real_Statement,
+ First_Subtype_Link,
+ Float_Truncate,
+ Formal_Type_Definition,
+ Forwards_OK,
+ From_Aspect_Specification,
+ From_At_End,
+ From_At_Mod,
+ From_Conditional_Expression,
+ From_Default,
+ Generalized_Indexing,
+ Generic_Associations,
+ Generic_Formal_Declarations,
+ Generic_Parent,
+ Generic_Parent_Type,
+ Handled_Statement_Sequence,
+ Handler_List_Entry,
+ Has_Created_Identifier,
+ Has_Dereference_Action,
+ Has_Dynamic_Length_Check,
+ Has_Init_Expression,
+ Has_Local_Raise,
+ Has_No_Elaboration_Code,
+ Has_Pragma_Suppress_All,
+ Has_Private_View,
+ Has_Relative_Deadline_Pragma,
+ Has_Self_Reference,
+ Has_SP_Choice,
+ Has_Storage_Size_Pragma,
+ Has_Target_Names,
+ Has_Wide_Character,
+ Has_Wide_Wide_Character,
+ Header_Size_Added,
+ Hidden_By_Use_Clause,
+ High_Bound,
+ Identifier,
+ Interface_List,
+ Interface_Present,
+ Implicit_With,
+ Import_Interface_Present,
+ In_Present,
+ Includes_Infinities,
+ Incomplete_View,
+ Inherited_Discriminant,
+ Instance_Spec,
+ Intval,
+ Is_Abort_Block,
+ Is_Accessibility_Actual,
+ Is_Analyzed_Pragma,
+ Is_Asynchronous_Call_Block,
+ Is_Boolean_Aspect,
+ Is_Checked,
+ Is_Checked_Ghost_Pragma,
+ Is_Component_Left_Opnd,
+ Is_Component_Right_Opnd,
+ Is_Controlling_Actual,
+ Is_Declaration_Level_Node,
+ Is_Delayed_Aspect,
+ Is_Disabled,
+ Is_Dispatching_Call,
+ Is_Dynamic_Coextension,
+ Is_Effective_Use_Clause,
+ Is_Elaboration_Checks_OK_Node,
+ Is_Elaboration_Code,
+ Is_Elaboration_Warnings_OK_Node,
+ Is_Elsif,
+ Is_Entry_Barrier_Function,
+ Is_Expanded_Build_In_Place_Call,
+ Is_Expanded_Contract,
+ Is_Finalization_Wrapper,
+ Is_Folded_In_Parser,
+ Is_Generic_Contract_Pragma,
+ Is_Homogeneous_Aggregate,
+ Is_Ignored,
+ Is_Ignored_Ghost_Pragma,
+ Is_In_Discriminant_Check,
+ Is_Inherited_Pragma,
+ Is_Initialization_Block,
+ Is_Known_Guaranteed_ABE,
+ Is_Machine_Number,
+ Is_Null_Loop,
+ Is_Overloaded,
+ Is_Power_Of_2_For_Shift,
+ Is_Preelaborable_Call,
+ Is_Prefixed_Call,
+ Is_Protected_Subprogram_Body,
+ Is_Qualified_Universal_Literal,
+ Is_Read,
+ Is_Source_Call,
+ Is_SPARK_Mode_On_Node,
+ Is_Static_Coextension,
+ Is_Static_Expression,
+ Is_Subprogram_Descriptor,
+ Is_Task_Allocation_Block,
+ Is_Task_Body_Procedure,
+ Is_Task_Master,
+ Is_Write,
+ Iterator_Filter,
+ Iteration_Scheme,
+ Iterator_Specification,
+ Itype,
+ Key_Expression,
+ Kill_Range_Check,
+ Last_Bit,
+ Last_Name,
+ Library_Unit,
+ Label_Construct,
+ Left_Opnd,
+ Limited_View_Installed,
+ Limited_Present,
+ Literals,
+ Local_Raise_Not_OK,
+ Local_Raise_Statements,
+ Loop_Actions,
+ Loop_Parameter_Specification,
+ Low_Bound,
+ Mod_Clause,
+ More_Ids,
+ Multidefined_Bindings,
+ Must_Be_Byte_Aligned,
+ Must_Not_Freeze,
+ Must_Not_Override,
+ Must_Override,
+ Name,
+ Names,
+ Next_Entity,
+ Next_Exit_Statement,
+ Next_Implicit_With,
+ Next_Named_Actual,
+ Next_Pragma,
+ Next_Rep_Item,
+ Next_Use_Clause,
+ No_Ctrl_Actions,
+ No_Elaboration_Check,
+ No_Entities_Ref_In_Spec,
+ No_Initialization,
+ No_Minimize_Eliminate,
+ No_Side_Effect_Removal,
+ No_Truncation,
+ Null_Excluding_Subtype,
+ Null_Exclusion_Present,
+ Null_Exclusion_In_Return_Present,
+ Null_Present,
+ Null_Record_Present,
+ Null_Statement,
+ Object_Definition,
+ Of_Present,
+ Original_Discriminant,
+ Original_Entity,
+ Others_Discrete_Choices,
+ Out_Present,
+ Parameter_Associations,
+ Parameter_Specifications,
+ Parameter_Type,
+ Parent_Spec,
+ Parent_With,
+ Position,
+ Pragma_Argument_Associations,
+ Pragma_Identifier,
+ Pragmas_After,
+ Pragmas_Before,
+ Pre_Post_Conditions,
+ Prefix,
+ Premature_Use,
+ Present_Expr,
+ Prev_Ids,
+ Prev_Use_Clause,
+ Print_In_Hex,
+ Private_Declarations,
+ Private_Present,
+ Procedure_To_Call,
+ Proper_Body,
+ Protected_Definition,
+ Protected_Present,
+ Raises_Constraint_Error,
+ Range_Constraint,
+ Range_Expression,
+ Real_Range_Specification,
+ Realval,
+ Reason,
+ Record_Extension_Part,
+ Redundant_Use,
+ Renaming_Exception,
+ Result_Definition,
+ Return_Object_Declarations,
+ Return_Statement_Entity,
+ Reverse_Present,
+ Right_Opnd,
+ Rounded_Result,
+ Save_Invocation_Graph_Of_Body,
+ SCIL_Controlling_Tag,
+ SCIL_Entity,
+ SCIL_Tag_Value,
+ SCIL_Target_Prim,
+ Scope,
+ Select_Alternatives,
+ Selector_Name,
+ Selector_Names,
+ Shift_Count_OK,
+ Source_Type,
+ Specification,
+ Split_PPC,
+ Statements,
+ Storage_Pool,
+ Subpool_Handle_Name,
+ Strval,
+ Subtype_Indication,
+ Subtype_Mark,
+ Subtype_Marks,
+ Suppress_Assignment_Checks,
+ Suppress_Loop_Warnings,
+ Synchronized_Present,
+ Tagged_Present,
+ Target,
+ Target_Type,
+ Task_Definition,
+ Task_Present,
+ Then_Actions,
+ Then_Statements,
+ Triggering_Alternative,
+ Triggering_Statement,
+ TSS_Elist,
+ Type_Definition,
+ Uneval_Old_Accept,
+ Uneval_Old_Warn,
+ Unit,
+ Unknown_Discriminants_Present,
+ Unreferenced_In_Spec,
+ Variant_Part,
+ Variants,
+ Visible_Declarations,
+ Uninitialized_Variable,
+ Used_Operations,
+ Was_Attribute_Reference,
+ Was_Default_Init_Box_Association,
+ Was_Expression_Function,
+ Was_Originally_Stub,
+
+ -- End of node fields.
+
+ Between_Node_And_Entity_Fields,
+
+ -- Start of entity fields:
+
+ Ekind,
+ Basic_Convention,
+ Abstract_States,
+ Accept_Address,
+ Access_Disp_Table,
+ Access_Disp_Table_Elab_Flag,
+ Access_Subprogram_Wrapper,
+ Activation_Record_Component,
+ Actual_Subtype,
+ Address_Taken,
+ Alignment,
+ Anonymous_Designated_Type,
+ Anonymous_Masters,
+ Anonymous_Object,
+ Associated_Entity,
+ Associated_Formal_Package,
+ Associated_Node_For_Itype,
+ Associated_Storage_Pool,
+ Barrier_Function,
+ BIP_Initialization_Call,
+ Block_Node,
+ Body_Entity,
+ Body_Needed_For_Inlining,
+ Body_Needed_For_SAL,
+ Body_References,
+ C_Pass_By_Copy,
+ Can_Never_Be_Null,
+ Can_Use_Internal_Rep,
+ Checks_May_Be_Suppressed,
+ Class_Wide_Clone,
+ Class_Wide_Type,
+ Cloned_Subtype,
+ Component_Alignment,
+ Component_Bit_Offset,
+ Component_Clause,
+ Component_Size,
+ Component_Type,
+ Contract,
+ Contract_Wrapper,
+ Corresponding_Concurrent_Type,
+ Corresponding_Discriminant,
+ Corresponding_Equality,
+ Corresponding_Function,
+ Corresponding_Procedure,
+ Corresponding_Record_Component,
+ Corresponding_Record_Type,
+ Corresponding_Remote_Type,
+ CR_Discriminant,
+ Current_Use_Clause,
+ Current_Value,
+ Debug_Info_Off,
+ Debug_Renaming_Link,
+ Default_Aspect_Component_Value,
+ Default_Aspect_Value,
+ Default_Expr_Function,
+ Default_Expressions_Processed,
+ Default_Value,
+ Delay_Cleanups,
+ Delay_Subprogram_Descriptors,
+ Delta_Value,
+ Dependent_Instances,
+ Depends_On_Private,
+ Derived_Type_Link,
+ Digits_Value,
+ Predicated_Parent,
+ Predicates_Ignored,
+ Direct_Primitive_Operations,
+ Directly_Designated_Type,
+ Disable_Controlled,
+ Discard_Names,
+ Discriminal,
+ Discriminal_Link,
+ Discriminant_Checking_Func,
+ Discriminant_Constraint,
+ Discriminant_Default_Value,
+ Discriminant_Number,
+ Dispatch_Table_Wrappers,
+ DT_Entry_Count,
+ DT_Offset_To_Top_Func,
+ DT_Position,
+ DTC_Entity,
+ Elaborate_Body_Desirable,
+ Elaboration_Entity,
+ Elaboration_Entity_Required,
+ Encapsulating_State,
+ Enclosing_Scope,
+ Entry_Accepted,
+ Entry_Bodies_Array,
+ Entry_Cancel_Parameter,
+ Entry_Component,
+ Entry_Formal,
+ Entry_Index_Constant,
+ Entry_Max_Queue_Lengths_Array,
+ Entry_Parameters_Type,
+ Enum_Pos_To_Rep,
+ Enumeration_Pos,
+ Enumeration_Rep,
+ Enumeration_Rep_Expr,
+ Equivalent_Type,
+ Esize,
+ Extra_Accessibility,
+ Extra_Accessibility_Of_Result,
+ Extra_Constrained,
+ Extra_Formal,
+ Extra_Formals,
+ Finalization_Master,
+ Finalize_Storage_Only,
+ Finalizer,
+ First_Entity,
+ First_Exit_Statement,
+ First_Index,
+ First_Literal,
+ First_Private_Entity,
+ First_Rep_Item,
+ Freeze_Node,
+ From_Limited_With,
+ Full_View,
+ Generic_Homonym,
+ Generic_Renamings,
+ Handler_Records,
+ Has_Aliased_Components,
+ Has_Alignment_Clause,
+ Has_All_Calls_Remote,
+ Has_Atomic_Components,
+ Has_Biased_Representation,
+ Has_Completion,
+ Has_Completion_In_Body,
+ Has_Complex_Representation,
+ Has_Component_Size_Clause,
+ Has_Constrained_Partial_View,
+ Has_Contiguous_Rep,
+ Has_Controlled_Component,
+ Has_Controlling_Result,
+ Has_Convention_Pragma,
+ Has_Default_Aspect,
+ Has_Delayed_Aspects,
+ Has_Delayed_Freeze,
+ Has_Delayed_Rep_Aspects,
+ Has_Discriminants,
+ Has_Dispatch_Table,
+ Has_Dynamic_Predicate_Aspect,
+ Has_Enumeration_Rep_Clause,
+ Has_Exit,
+ Has_Expanded_Contract,
+ Has_Forward_Instantiation,
+ Has_Fully_Qualified_Name,
+ Has_Gigi_Rep_Item,
+ Has_Homonym,
+ Has_Implicit_Dereference,
+ Has_Independent_Components,
+ Has_Inheritable_Invariants,
+ Has_Inherited_DIC,
+ Has_Inherited_Invariants,
+ Has_Initial_Value,
+ Has_Loop_Entry_Attributes,
+ Has_Machine_Radix_Clause,
+ Has_Master_Entity,
+ Has_Missing_Return,
+ Has_Nested_Block_With_Handler,
+ Has_Nested_Subprogram,
+ Has_Non_Standard_Rep,
+ Has_Object_Size_Clause,
+ Has_Out_Or_In_Out_Parameter,
+ Has_Own_DIC,
+ Has_Own_Invariants,
+ Has_Partial_Visible_Refinement,
+ Has_Per_Object_Constraint,
+ Has_Pragma_Controlled,
+ Has_Pragma_Elaborate_Body,
+ Has_Pragma_Inline,
+ Has_Pragma_Inline_Always,
+ Has_Pragma_No_Inline,
+ Has_Pragma_Ordered,
+ Has_Pragma_Pack,
+ Has_Pragma_Preelab_Init,
+ Has_Pragma_Pure,
+ Has_Pragma_Pure_Function,
+ Has_Pragma_Thread_Local_Storage,
+ Has_Pragma_Unmodified,
+ Has_Pragma_Unreferenced,
+ Has_Pragma_Unreferenced_Objects,
+ Has_Pragma_Unused,
+ Has_Predicates,
+ Has_Primitive_Operations,
+ Has_Private_Ancestor,
+ Has_Private_Declaration,
+ Has_Private_Extension,
+ Has_Protected,
+ Has_Qualified_Name,
+ Has_RACW,
+ Has_Record_Rep_Clause,
+ Has_Recursive_Call,
+ Has_Shift_Operator,
+ Has_Size_Clause,
+ Has_Small_Clause,
+ Has_Specified_Layout,
+ Has_Specified_Stream_Input,
+ Has_Specified_Stream_Output,
+ Has_Specified_Stream_Read,
+ Has_Specified_Stream_Write,
+ Has_Static_Discriminants,
+ Has_Static_Predicate,
+ Has_Static_Predicate_Aspect,
+ Has_Storage_Size_Clause,
+ Has_Stream_Size_Clause,
+ Has_Task,
+ Has_Timing_Event,
+ Has_Thunks,
+ Has_Unchecked_Union,
+ Has_Unknown_Discriminants,
+ Has_Visible_Refinement,
+ Has_Volatile_Components,
+ Has_Xref_Entry,
+ Has_Yield_Aspect,
+ Hiding_Loop_Variable,
+ Hidden_In_Formal_Instance,
+ Homonym,
+ Ignore_SPARK_Mode_Pragmas,
+ Import_Pragma,
+ Incomplete_Actuals,
+ In_Package_Body,
+ In_Private_Part,
+ In_Use,
+ Initialization_Statements,
+ Inner_Instances,
+ Interface_Alias,
+ Interface_Name,
+ Interfaces,
+ Is_Abstract_Subprogram,
+ Is_Abstract_Type,
+ Is_Access_Constant,
+ Is_Activation_Record,
+ Is_Actual_Subtype,
+ Is_Ada_2005_Only,
+ Is_Ada_2012_Only,
+ Is_Ada_2022_Only,
+ Is_Aliased,
+ Is_Asynchronous,
+ Is_Atomic,
+ Is_Bit_Packed_Array,
+ Is_Called,
+ Is_Character_Type,
+ Is_Checked_Ghost_Entity,
+ Is_Child_Unit,
+ Is_Class_Wide_Equivalent_Type,
+ Is_Compilation_Unit,
+ Is_Completely_Hidden,
+ Is_Concurrent_Record_Type,
+ Is_Constr_Subt_For_U_Nominal,
+ Is_Constr_Subt_For_UN_Aliased,
+ Is_Constrained,
+ Is_Constructor,
+ Is_Controlled_Active,
+ Is_Controlling_Formal,
+ Is_CPP_Class,
+ Is_CUDA_Kernel,
+ Is_Descendant_Of_Address,
+ Is_DIC_Procedure,
+ Is_Discrim_SO_Function,
+ Is_Discriminant_Check_Function,
+ Is_Dispatch_Table_Entity,
+ Is_Dispatching_Operation,
+ Is_Elaboration_Checks_OK_Id,
+ Is_Elaboration_Warnings_OK_Id,
+ Is_Eliminated,
+ Is_Entry_Formal,
+ Is_Entry_Wrapper,
+ Is_Exception_Handler,
+ Is_Exported,
+ Is_Finalized_Transient,
+ Is_First_Subtype,
+ Is_Fixed_Lower_Bound_Array_Subtype,
+ Is_Fixed_Lower_Bound_Index_Subtype,
+ Is_Formal_Subprogram,
+ Is_Frozen,
+ Is_Generic_Actual_Subprogram,
+ Is_Generic_Actual_Type,
+ Is_Generic_Instance,
+ Is_Generic_Type,
+ Is_Hidden,
+ Is_Hidden_Non_Overridden_Subpgm,
+ Is_Hidden_Open_Scope,
+ Is_Ignored_Ghost_Entity,
+ Is_Ignored_Transient,
+ Is_Immediately_Visible,
+ Is_Implementation_Defined,
+ Is_Imported,
+ Is_Independent,
+ Is_Initial_Condition_Procedure,
+ Is_Inlined,
+ Is_Inlined_Always,
+ Is_Instantiated,
+ Is_Interface,
+ Is_Internal,
+ Is_Interrupt_Handler,
+ Is_Intrinsic_Subprogram,
+ Is_Invariant_Procedure,
+ Is_Itype,
+ Is_Known_Non_Null,
+ Is_Known_Null,
+ Is_Known_Valid,
+ Is_Limited_Composite,
+ Is_Limited_Interface,
+ Is_Limited_Record,
+ Is_Local_Anonymous_Access,
+ Is_Loop_Parameter,
+ Is_Machine_Code_Subprogram,
+ Is_Non_Static_Subtype,
+ Is_Null_Init_Proc,
+ Is_Obsolescent,
+ Is_Only_Out_Parameter,
+ Is_Package_Body_Entity,
+ Is_Packed,
+ Is_Packed_Array_Impl_Type,
+ Is_Param_Block_Component_Type,
+ Is_Partial_Invariant_Procedure,
+ Is_Potentially_Use_Visible,
+ Is_Predicate_Function,
+ Is_Predicate_Function_M,
+ Is_Preelaborated,
+ Is_Primitive,
+ Is_Primitive_Wrapper,
+ Is_Private_Composite,
+ Is_Private_Descendant,
+ Is_Private_Primitive,
+ Is_Public,
+ Is_Pure,
+ Is_Pure_Unit_Access_Type,
+ Is_RACW_Stub_Type,
+ Is_Raised,
+ Is_Remote_Call_Interface,
+ Is_Remote_Types,
+ Is_Renaming_Of_Object,
+ Is_Return_Object,
+ Is_Safe_To_Reevaluate,
+ Is_Shared_Passive,
+ Is_Static_Type,
+ Is_Statically_Allocated,
+ Is_Tag,
+ Is_Tagged_Type,
+ Is_Thunk,
+ Is_Trivial_Subprogram,
+ Is_True_Constant,
+ Is_Unchecked_Union,
+ Is_Underlying_Full_View,
+ Is_Underlying_Record_View,
+ Is_Unimplemented,
+ Is_Unsigned_Type,
+ Is_Uplevel_Referenced_Entity,
+ Is_Valued_Procedure,
+ Is_Visible_Formal,
+ Is_Visible_Lib_Unit,
+ Is_Volatile_Type,
+ Is_Volatile_Object,
+ Is_Volatile_Full_Access,
+ Is_Wrapper,
+ Itype_Printed,
+ Kill_Elaboration_Checks,
+ Kill_Range_Checks,
+ Known_To_Have_Preelab_Init,
+ Last_Aggregate_Assignment,
+ Last_Assignment,
+ Last_Entity,
+ Limited_View,
+ Linker_Section_Pragma,
+ Lit_Hash,
+ Lit_Indexes,
+ Lit_Strings,
+ Low_Bound_Tested,
+ LSP_Subprogram,
+ Machine_Radix_10,
+ Master_Id,
+ Materialize_Entity,
+ May_Inherit_Delayed_Rep_Aspects,
+ Mechanism,
+ Minimum_Accessibility,
+ Modulus,
+ Must_Be_On_Byte_Boundary,
+ Must_Have_Preelab_Init,
+ Needs_Activation_Record,
+ Needs_Debug_Info,
+ Needs_No_Actuals,
+ Never_Set_In_Source,
+ Next_Inlined_Subprogram,
+ No_Dynamic_Predicate_On_Actual,
+ No_Pool_Assigned,
+ No_Predicate_On_Actual,
+ No_Reordering,
+ No_Return,
+ No_Strict_Aliasing,
+ No_Tagged_Streams_Pragma,
+ Non_Binary_Modulus,
+ Non_Limited_View,
+ Nonzero_Is_True,
+ Normalized_First_Bit,
+ Normalized_Position,
+ Normalized_Position_Max,
+ OK_To_Rename,
+ Optimize_Alignment_Space,
+ Optimize_Alignment_Time,
+ Original_Access_Type,
+ Original_Array_Type,
+ Original_Protected_Subprogram,
+ Original_Record_Component,
+ Overlays_Constant,
+ Overridden_Operation,
+ Package_Instantiation,
+ Packed_Array_Impl_Type,
+ Parent_Subtype,
+ Part_Of_Constituents,
+ Part_Of_References,
+ Partial_View_Has_Unknown_Discr,
+ Pending_Access_Types,
+ Postconditions_Proc,
+ Prev_Entity,
+ Prival,
+ Prival_Link,
+ Private_Dependents,
+ Protected_Body_Subprogram,
+ Protected_Formal,
+ Protected_Subprogram,
+ Protection_Object,
+ Reachable,
+ Receiving_Entry,
+ Referenced,
+ Referenced_As_LHS,
+ Referenced_As_Out_Parameter,
+ Refinement_Constituents,
+ Register_Exception_Call,
+ Related_Array_Object,
+ Related_Expression,
+ Related_Instance,
+ Related_Type,
+ Relative_Deadline_Variable,
+ Renamed_In_Spec,
+ Renamed_Or_Alias, -- Shared among Alias, Renamed_Entity, Renamed_Object
+ Requires_Overriding,
+ Return_Applies_To,
+ Return_Present,
+ Return_Statement,
+ Returns_By_Ref,
+ Reverse_Bit_Order,
+ Reverse_Storage_Order,
+ Rewritten_For_C,
+ RM_Size,
+ Scalar_Range,
+ Scale_Value,
+ Scope_Depth_Value,
+ Sec_Stack_Needed_For_Return,
+ Shared_Var_Procs_Instance,
+ Size_Check_Code,
+ Size_Depends_On_Discriminant,
+ Size_Known_At_Compile_Time,
+ Small_Value,
+ SPARK_Aux_Pragma,
+ SPARK_Aux_Pragma_Inherited,
+ SPARK_Pragma,
+ SPARK_Pragma_Inherited,
+ Spec_Entity,
+ SSO_Set_High_By_Default,
+ SSO_Set_Low_By_Default,
+ Static_Discrete_Predicate,
+ Static_Elaboration_Desired,
+ Static_Initialization,
+ Static_Real_Or_String_Predicate,
+ Status_Flag_Or_Transient_Decl,
+ Storage_Size_Variable,
+ Stored_Constraint,
+ Stores_Attribute_Old_Prefix,
+ Strict_Alignment,
+ String_Literal_Length,
+ String_Literal_Low_Bound,
+ Subprograms_For_Type,
+ Subps_Index,
+ Suppress_Elaboration_Warnings,
+ Suppress_Initialization,
+ Suppress_Style_Checks,
+ Suppress_Value_Tracking_On_Call,
+ Task_Body_Procedure,
+ Thunk_Entity,
+ Treat_As_Volatile,
+ Underlying_Full_View,
+ Underlying_Record_View,
+ Universal_Aliasing,
+ Unset_Reference,
+ Used_As_Generic_Actual,
+ Uses_Lock_Free,
+ Uses_Sec_Stack,
+ Validated_Object,
+ Warnings_Off,
+ Warnings_Off_Used,
+ Warnings_Off_Used_Unmodified,
+ Warnings_Off_Used_Unreferenced,
+ Was_Hidden,
+ Wrapped_Entity
+
+ -- End of entity fields.
+ ); -- Opt_Field_Enum
+
+ subtype Field_Enum is Opt_Field_Enum
+ range Opt_Field_Enum'Succ (No_Field) .. Opt_Field_Enum'Last;
+ -- Enumeration of fields -- Opt_Field_Enum without the special null value
+ -- No_Field.
+
+ subtype Node_Header_Field is Field_Enum with Predicate =>
+ Node_Header_Field in Nkind .. Link | Ekind;
+
+ use Gen_IL.Types;
+
+ subtype Node_Header_Type is Type_Enum range
+ Node_Kind_Type .. Union_Id;
+ -- Types of node header fields
+
+end Gen_IL.Fields;
diff --git a/gcc/ada/gen_il-gen-gen_entities.adb b/gcc/ada/gen_il-gen-gen_entities.adb
new file mode 100644
index 0000000..41dd232
--- /dev/null
+++ b/gcc/ada/gen_il-gen-gen_entities.adb
@@ -0,0 +1,1412 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- G E N _ I L . G E N . G E N _ E N T I T I E S --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 2020-2021, Free Software Foundation, Inc. --
+-- --
+-- GNAT is 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. --
+-- --
+------------------------------------------------------------------------------
+
+procedure Gen_IL.Gen.Gen_Entities is
+
+ procedure Ab -- Short for "Abstract"
+ (T : Abstract_Entity; Parent : Abstract_Type;
+ Fields : Field_Sequence := No_Fields)
+ renames Create_Abstract_Entity_Type;
+ procedure Cc -- Short for "ConCrete"
+ (T : Concrete_Entity; Parent : Abstract_Type;
+ Fields : Field_Sequence := No_Fields)
+ renames Create_Concrete_Entity_Type;
+
+ -- No Sy (Syntactic) fields in entities
+ function Sm -- Short for "Semantic"
+ (Field : Field_Enum; Field_Type : Type_Enum;
+ Type_Only : Type_Only_Enum := No_Type_Only;
+ Pre, Pre_Get, Pre_Set : String := "") return Field_Desc
+ renames Create_Semantic_Field;
+
+ procedure Union (T : Abstract_Entity; Children : Type_Array)
+ renames Create_Entity_Union_Type;
+
+begin -- Gen_IL.Gen.Gen_Entities
+ pragma Style_Checks ("M200");
+
+ Create_Root_Entity_Type (Entity_Kind,
+ (Sm (Ekind, Entity_Kind_Type),
+ Sm (Basic_Convention, Convention_Id),
+ Sm (Address_Taken, Flag),
+ Sm (Associated_Entity, Node_Id),
+ Sm (Can_Never_Be_Null, Flag),
+ Sm (Checks_May_Be_Suppressed, Flag),
+ Sm (Debug_Info_Off, Flag),
+ Sm (Default_Expressions_Processed, Flag),
+ Sm (Delay_Cleanups, Flag),
+ Sm (Delay_Subprogram_Descriptors, Flag),
+ Sm (Depends_On_Private, Flag),
+ Sm (Disable_Controlled, Flag, Base_Type_Only),
+ Sm (Discard_Names, Flag),
+ Sm (First_Rep_Item, Node_Id),
+ Sm (Freeze_Node, Node_Id),
+ Sm (From_Limited_With, Flag),
+ Sm (Has_Aliased_Components, Flag, Impl_Base_Type_Only),
+ Sm (Has_Alignment_Clause, Flag),
+ Sm (Has_All_Calls_Remote, Flag),
+ Sm (Has_Atomic_Components, Flag, Impl_Base_Type_Only),
+ Sm (Has_Biased_Representation, Flag),
+ Sm (Has_Completion, Flag),
+ Sm (Has_Contiguous_Rep, Flag),
+ Sm (Has_Controlled_Component, Flag, Base_Type_Only),
+ Sm (Has_Controlling_Result, Flag),
+ Sm (Has_Convention_Pragma, Flag),
+ Sm (Has_Default_Aspect, Flag, Base_Type_Only),
+ Sm (Has_Delayed_Aspects, Flag),
+ Sm (Has_Delayed_Freeze, Flag),
+ Sm (Has_Delayed_Rep_Aspects, Flag),
+ Sm (Has_Exit, Flag),
+ Sm (Has_Forward_Instantiation, Flag),
+ Sm (Has_Fully_Qualified_Name, Flag),
+ Sm (Has_Gigi_Rep_Item, Flag),
+ Sm (Has_Homonym, Flag),
+ Sm (Has_Implicit_Dereference, Flag),
+ Sm (Has_Independent_Components, Flag, Impl_Base_Type_Only),
+ Sm (Has_Master_Entity, Flag),
+ Sm (Has_Nested_Block_With_Handler, Flag),
+ Sm (Has_Non_Standard_Rep, Flag, Impl_Base_Type_Only),
+ Sm (Has_Per_Object_Constraint, Flag),
+ Sm (Has_Pragma_Elaborate_Body, Flag),
+ Sm (Has_Pragma_Inline, Flag),
+ Sm (Has_Pragma_Inline_Always, Flag),
+ Sm (Has_Pragma_No_Inline, Flag),
+ Sm (Has_Pragma_Preelab_Init, Flag),
+ Sm (Has_Pragma_Pure, Flag),
+ Sm (Has_Pragma_Pure_Function, Flag),
+ Sm (Has_Pragma_Thread_Local_Storage, Flag),
+ Sm (Has_Pragma_Unmodified, Flag),
+ Sm (Has_Pragma_Unreferenced, Flag),
+ Sm (Has_Pragma_Unused, Flag),
+ Sm (Has_Private_Ancestor, Flag),
+ Sm (Has_Private_Declaration, Flag),
+ Sm (Has_Protected, Flag, Base_Type_Only),
+ Sm (Has_Qualified_Name, Flag),
+ Sm (Has_Size_Clause, Flag),
+ Sm (Has_Stream_Size_Clause, Flag),
+ Sm (Has_Task, Flag, Base_Type_Only),
+ Sm (Has_Timing_Event, Flag, Base_Type_Only),
+ Sm (Has_Thunks, Flag),
+ Sm (Has_Unchecked_Union, Flag, Base_Type_Only),
+ Sm (Has_Volatile_Components, Flag, Impl_Base_Type_Only),
+ Sm (Has_Xref_Entry, Flag),
+ Sm (Has_Yield_Aspect, Flag),
+ Sm (Homonym, Node_Id),
+ Sm (In_Package_Body, Flag),
+ Sm (In_Private_Part, Flag),
+ Sm (In_Use, Flag),
+ Sm (Is_Ada_2005_Only, Flag),
+ Sm (Is_Ada_2012_Only, Flag),
+ Sm (Is_Ada_2022_Only, Flag),
+ Sm (Is_Aliased, Flag),
+ Sm (Is_Atomic, Flag),
+ Sm (Is_Bit_Packed_Array, Flag, Impl_Base_Type_Only),
+ Sm (Is_Character_Type, Flag),
+ Sm (Is_Checked_Ghost_Entity, Flag),
+ Sm (Is_Child_Unit, Flag),
+ Sm (Is_Class_Wide_Equivalent_Type, Flag),
+ Sm (Is_Compilation_Unit, Flag),
+ Sm (Is_Concurrent_Record_Type, Flag),
+ Sm (Is_Constr_Subt_For_U_Nominal, Flag),
+ Sm (Is_Constr_Subt_For_UN_Aliased, Flag),
+ Sm (Is_Constrained, Flag),
+ Sm (Is_Constructor, Flag),
+ Sm (Is_Controlled_Active, Flag, Base_Type_Only),
+ Sm (Is_CPP_Class, Flag),
+ Sm (Is_Descendant_Of_Address, Flag),
+ Sm (Is_Discrim_SO_Function, Flag),
+ Sm (Is_Discriminant_Check_Function, Flag),
+ Sm (Is_Dispatch_Table_Entity, Flag),
+ Sm (Is_Dispatching_Operation, Flag),
+ Sm (Is_Eliminated, Flag),
+ Sm (Is_Entry_Formal, Flag),
+ Sm (Is_Entry_Wrapper, Flag),
+ Sm (Is_Exported, Flag),
+ Sm (Is_First_Subtype, Flag),
+ Sm (Is_Formal_Subprogram, Flag),
+ Sm (Is_Frozen, Flag),
+ Sm (Is_Generic_Instance, Flag),
+ Sm (Is_Generic_Type, Flag),
+ Sm (Is_Hidden, Flag),
+ Sm (Is_Hidden_Non_Overridden_Subpgm, Flag),
+ Sm (Is_Hidden_Open_Scope, Flag),
+ Sm (Is_Ignored_Ghost_Entity, Flag),
+ Sm (Is_Immediately_Visible, Flag),
+ Sm (Is_Implementation_Defined, Flag),
+ Sm (Is_Imported, Flag),
+ Sm (Is_Independent, Flag),
+ Sm (Is_Inlined, Flag),
+ Sm (Is_Instantiated, Flag),
+ Sm (Is_Interface, Flag),
+ Sm (Is_Internal, Flag),
+ Sm (Is_Interrupt_Handler, Flag),
+ Sm (Is_Intrinsic_Subprogram, Flag),
+ Sm (Is_Itype, Flag),
+ Sm (Is_Known_Non_Null, Flag),
+ Sm (Is_Known_Null, Flag),
+ Sm (Is_Known_Valid, Flag),
+ Sm (Is_Limited_Composite, Flag),
+ Sm (Is_Limited_Interface, Flag),
+ Sm (Is_Limited_Record, Flag),
+ Sm (Is_Loop_Parameter, Flag),
+ Sm (Is_Obsolescent, Flag),
+ Sm (Is_Package_Body_Entity, Flag),
+ Sm (Is_Packed, Flag, Impl_Base_Type_Only),
+ Sm (Is_Packed_Array_Impl_Type, Flag),
+ Sm (Is_Potentially_Use_Visible, Flag),
+ Sm (Is_Preelaborated, Flag),
+ Sm (Is_Private_Descendant, Flag),
+ Sm (Is_Public, Flag),
+ Sm (Is_Pure, Flag),
+ Sm (Is_Remote_Call_Interface, Flag),
+ Sm (Is_Remote_Types, Flag),
+ Sm (Is_Renaming_Of_Object, Flag),
+ Sm (Is_Return_Object, Flag),
+ Sm (Is_Safe_To_Reevaluate, Flag),
+ Sm (Is_Shared_Passive, Flag),
+ Sm (Is_Static_Type, Flag),
+ Sm (Is_Statically_Allocated, Flag),
+ Sm (Is_Tag, Flag),
+ Sm (Is_Tagged_Type, Flag),
+ Sm (Is_Thunk, Flag),
+ Sm (Is_Trivial_Subprogram, Flag),
+ Sm (Is_True_Constant, Flag),
+ Sm (Is_Unchecked_Union, Flag, Impl_Base_Type_Only),
+ Sm (Is_Underlying_Full_View, Flag),
+ Sm (Is_Underlying_Record_View, Flag, Base_Type_Only),
+ Sm (Is_Unimplemented, Flag),
+ Sm (Is_Uplevel_Referenced_Entity, Flag),
+ Sm (Is_Visible_Formal, Flag),
+ Sm (Is_Visible_Lib_Unit, Flag),
+ Sm (Is_Volatile_Type, Flag),
+ Sm (Is_Volatile_Object, Flag),
+ Sm (Is_Volatile_Full_Access, Flag),
+ Sm (Is_Wrapper, Flag),
+ Sm (Kill_Elaboration_Checks, Flag),
+ Sm (Kill_Range_Checks, Flag),
+ Sm (Low_Bound_Tested, Flag),
+ Sm (Materialize_Entity, Flag),
+ Sm (May_Inherit_Delayed_Rep_Aspects, Flag),
+ Sm (Needs_Activation_Record, Flag),
+ Sm (Needs_Debug_Info, Flag),
+ Sm (Never_Set_In_Source, Flag),
+ Sm (No_Return, Flag),
+ Sm (Overlays_Constant, Flag),
+ Sm (Prev_Entity, Node_Id),
+ Sm (Reachable, Flag),
+ Sm (Referenced, Flag),
+ Sm (Referenced_As_LHS, Flag),
+ Sm (Referenced_As_Out_Parameter, Flag),
+ Sm (Return_Present, Flag),
+ Sm (Returns_By_Ref, Flag),
+ Sm (Sec_Stack_Needed_For_Return, Flag),
+ Sm (Size_Depends_On_Discriminant, Flag),
+ Sm (Size_Known_At_Compile_Time, Flag),
+ Sm (Stores_Attribute_Old_Prefix, Flag),
+ Sm (Strict_Alignment, Flag, Impl_Base_Type_Only),
+ Sm (Suppress_Elaboration_Warnings, Flag),
+ Sm (Suppress_Style_Checks, Flag),
+ Sm (Suppress_Value_Tracking_On_Call, Flag),
+ Sm (Treat_As_Volatile, Flag),
+ Sm (Used_As_Generic_Actual, Flag),
+ Sm (Uses_Sec_Stack, Flag),
+ Sm (Warnings_Off, Flag),
+ Sm (Warnings_Off_Used, Flag),
+ Sm (Warnings_Off_Used_Unmodified, Flag),
+ Sm (Warnings_Off_Used_Unreferenced, Flag),
+ Sm (Was_Hidden, Flag)));
+
+ Ab (Void_Or_Type_Kind, Entity_Kind);
+
+ Cc (E_Void, Void_Or_Type_Kind,
+ -- The initial Ekind value for a newly created entity. Also used as the
+ -- Ekind for Standard_Void_Type, a type entity in Standard used as a
+ -- dummy type for the return type of a procedure (the reason we create
+ -- this type is to share the circuits for performing overload
+ -- resolution on calls).
+ (Sm (Alignment, Unat),
+ Sm (Contract, Node_Id),
+ Sm (Is_Elaboration_Warnings_OK_Id, Flag),
+ Sm (Original_Record_Component, Node_Id),
+ Sm (Scope_Depth_Value, Uint),
+ Sm (SPARK_Pragma, Node_Id),
+ Sm (SPARK_Pragma_Inherited, Flag),
+ Sm (Current_Value, Node_Id), -- setter only
+ Sm (Has_Predicates, Flag), -- setter only
+ Sm (Initialization_Statements, Node_Id), -- setter only
+ Sm (Is_Param_Block_Component_Type, Flag, Base_Type_Only),
+ -- setter only
+
+ Sm (Package_Instantiation, Node_Id), -- setter only
+ Sm (Related_Expression, Node_Id), -- setter only
+
+ -- If we set the Ekind field properly before setting the following
+ -- fields, then these would not be needed in E_Void.
+ Sm (Accept_Address, Elist_Id),
+ Sm (Associated_Formal_Package, Node_Id),
+ Sm (Associated_Node_For_Itype, Node_Id),
+ Sm (Corresponding_Remote_Type, Node_Id),
+ Sm (CR_Discriminant, Node_Id),
+ Sm (Debug_Renaming_Link, Node_Id),
+ Sm (Discriminal_Link, Node_Id),
+ Sm (Discriminant_Default_Value, Node_Id),
+ Sm (Discriminant_Number, Upos),
+ Sm (Enclosing_Scope, Node_Id),
+ Sm (Entry_Bodies_Array, Node_Id,
+ Pre => "Has_Entries (N)"),
+ Sm (Entry_Cancel_Parameter, Node_Id),
+ Sm (Entry_Component, Node_Id),
+ Sm (Entry_Formal, Node_Id),
+ Sm (Entry_Parameters_Type, Node_Id),
+ Sm (Esize, Uint),
+ Sm (RM_Size, Uint),
+ Sm (Extra_Formal, Node_Id),
+ Sm (First_Entity, Node_Id),
+ Sm (Generic_Homonym, Node_Id),
+ Sm (Generic_Renamings, Elist_Id),
+ Sm (Handler_Records, List_Id),
+ Sm (Has_Static_Discriminants, Flag),
+ Sm (Inner_Instances, Elist_Id),
+ Sm (Interface_Name, Node_Id),
+ Sm (Last_Entity, Node_Id),
+ Sm (Next_Inlined_Subprogram, Node_Id),
+ Sm (Renamed_Or_Alias, Node_Id), -- See Einfo.Utils
+ Sm (Return_Applies_To, Node_Id),
+ Sm (Scalar_Range, Node_Id),
+ Sm (Scale_Value, Uint),
+ Sm (Unset_Reference, Node_Id)));
+ -- For the above "setter only" fields, the setters are called for E_Void,
+ -- but not getters; the Ekind is modified before any such getters are
+ -- called.
+
+ Ab (Exception_Or_Object_Kind, Entity_Kind);
+
+ Ab (Object_Kind, Exception_Or_Object_Kind,
+ (Sm (Current_Value, Node_Id),
+ Sm (Renamed_Or_Alias, Node_Id)));
+
+ Ab (Record_Field_Kind, Object_Kind,
+ (Sm (Component_Bit_Offset, Uint),
+ Sm (Component_Clause, Node_Id),
+ Sm (Corresponding_Record_Component, Node_Id),
+ Sm (Entry_Formal, Node_Id),
+ Sm (Esize, Uint),
+ Sm (Interface_Name, Node_Id),
+ Sm (Normalized_First_Bit, Uint),
+ Sm (Normalized_Position, Uint),
+ Sm (Normalized_Position_Max, Uint),
+ Sm (Original_Record_Component, Node_Id)));
+
+ Cc (E_Component, Record_Field_Kind,
+ -- Components (other than discriminants) of a record declaration,
+ -- private declarations of protected objects.
+ (Sm (Discriminant_Checking_Func, Node_Id),
+ Sm (DT_Entry_Count, Uint,
+ Pre => "Is_Tag (N)"),
+ Sm (DT_Offset_To_Top_Func, Node_Id,
+ Pre => "Is_Tag (N)"),
+ Sm (Prival, Node_Id,
+ Pre => "Is_Protected_Component (N)"),
+ Sm (Related_Type, Node_Id)));
+
+ Ab (Allocatable_Kind, Object_Kind,
+ (Sm (Activation_Record_Component, Node_Id),
+ Sm (Alignment, Unat),
+ Sm (Esize, Uint),
+ Sm (Interface_Name, Node_Id),
+ Sm (Is_Finalized_Transient, Flag),
+ Sm (Is_Ignored_Transient, Flag),
+ Sm (Linker_Section_Pragma, Node_Id),
+ Sm (Related_Expression, Node_Id),
+ Sm (Status_Flag_Or_Transient_Decl, Node_Id)));
+
+ Ab (Constant_Or_Variable_Kind, Allocatable_Kind,
+ (Sm (Actual_Subtype, Node_Id),
+ Sm (BIP_Initialization_Call, Node_Id),
+ Sm (Contract, Node_Id),
+ Sm (Discriminal_Link, Node_Id),
+ Sm (Encapsulating_State, Node_Id),
+ Sm (Extra_Accessibility, Node_Id),
+ Sm (Initialization_Statements, Node_Id),
+ Sm (Is_Elaboration_Checks_OK_Id, Flag),
+ Sm (Is_Elaboration_Warnings_OK_Id, Flag),
+ Sm (Last_Aggregate_Assignment, Node_Id),
+ Sm (Optimize_Alignment_Space, Flag),
+ Sm (Optimize_Alignment_Time, Flag),
+ Sm (Prival_Link, Node_Id),
+ Sm (Related_Type, Node_Id),
+ Sm (Return_Statement, Node_Id),
+ Sm (Size_Check_Code, Node_Id),
+ Sm (SPARK_Pragma, Node_Id),
+ Sm (SPARK_Pragma_Inherited, Flag)));
+
+ Cc (E_Constant, Constant_Or_Variable_Kind,
+ -- Constants created by an object declaration with a constant keyword
+ (Sm (Full_View, Node_Id)));
+
+ Cc (E_Discriminant, Record_Field_Kind,
+ -- A discriminant, created by the use of a discriminant in a type
+ -- declaration.
+ (Sm (Corresponding_Discriminant, Node_Id),
+ Sm (CR_Discriminant, Node_Id),
+ Sm (Discriminal, Node_Id),
+ Sm (Discriminant_Default_Value, Node_Id),
+ Sm (Discriminant_Number, Upos),
+ Sm (Is_Completely_Hidden, Flag)));
+
+ Cc (E_Loop_Parameter, Allocatable_Kind);
+ -- A loop parameter created by a for loop
+
+ Cc (E_Variable, Constant_Or_Variable_Kind,
+ -- Variables created by an object declaration with no constant keyword
+ (Sm (Anonymous_Designated_Type, Node_Id),
+ Sm (Debug_Renaming_Link, Node_Id),
+ Sm (Extra_Constrained, Node_Id),
+ Sm (Has_Initial_Value, Flag),
+ Sm (Hiding_Loop_Variable, Node_Id),
+ Sm (Last_Assignment, Node_Id),
+ Sm (OK_To_Rename, Flag),
+ Sm (Part_Of_Constituents, Elist_Id),
+ Sm (Part_Of_References, Elist_Id),
+ Sm (Shared_Var_Procs_Instance, Node_Id),
+ Sm (Suppress_Initialization, Flag),
+ Sm (Unset_Reference, Node_Id),
+ Sm (Validated_Object, Node_Id)));
+
+ Ab (Formal_Kind, Object_Kind,
+ -- Formal parameters are also objects
+ (Sm (Activation_Record_Component, Node_Id),
+ Sm (Actual_Subtype, Node_Id),
+ Sm (Alignment, Unat),
+ Sm (Default_Expr_Function, Node_Id),
+ Sm (Default_Value, Node_Id),
+ Sm (Entry_Component, Node_Id),
+ Sm (Esize, Uint),
+ Sm (Extra_Accessibility, Node_Id),
+ Sm (Extra_Constrained, Node_Id),
+ Sm (Extra_Formal, Node_Id),
+ Sm (Has_Initial_Value, Flag),
+ Sm (Is_Controlling_Formal, Flag),
+ Sm (Is_Only_Out_Parameter, Flag),
+ Sm (Linker_Section_Pragma, Node_Id),
+ Sm (Mechanism, Mechanism_Type),
+ Sm (Minimum_Accessibility, Node_Id),
+ Sm (Protected_Formal, Node_Id),
+ Sm (Spec_Entity, Node_Id),
+ Sm (Unset_Reference, Node_Id)));
+
+ Cc (E_Out_Parameter, Formal_Kind,
+ -- An out parameter of a subprogram or entry
+ (Sm (Last_Assignment, Node_Id)));
+
+ Cc (E_In_Out_Parameter, Formal_Kind,
+ -- An in-out parameter of a subprogram or entry
+ (Sm (Last_Assignment, Node_Id)));
+
+ Cc (E_In_Parameter, Formal_Kind,
+ -- An in parameter of a subprogram or entry
+ (Sm (Discriminal_Link, Node_Id),
+ Sm (Discriminant_Default_Value, Node_Id),
+ Sm (Is_Activation_Record, Flag)));
+
+ Ab (Formal_Object_Kind, Object_Kind,
+ -- Generic formal objects are also objects
+ (Sm (Entry_Component, Node_Id),
+ Sm (Esize, Uint)));
+
+ Cc (E_Generic_In_Out_Parameter, Formal_Object_Kind,
+ -- A generic in out parameter, created by the use of a generic in out
+ -- parameter in a generic declaration.
+ (Sm (Actual_Subtype, Node_Id)));
+
+ Cc (E_Generic_In_Parameter, Formal_Object_Kind);
+ -- A generic in parameter, created by the use of a generic in
+ -- parameter in a generic declaration.
+
+ Ab (Named_Kind, Entity_Kind,
+ (Sm (Renamed_Or_Alias, Node_Id)));
+
+ Cc (E_Named_Integer, Named_Kind);
+ -- Named numbers created by a number declaration with an integer value
+
+ Cc (E_Named_Real, Named_Kind);
+ -- Named numbers created by a number declaration with a real value
+
+ Ab (Type_Kind, Void_Or_Type_Kind,
+ (Sm (Alignment, Unat),
+ Sm (Associated_Node_For_Itype, Node_Id),
+ Sm (Can_Use_Internal_Rep, Flag, Base_Type_Only,
+ Pre => "Ekind (Base_Type (N)) in Access_Subprogram_Kind"),
+ Sm (Class_Wide_Type, Node_Id),
+ Sm (Contract, Node_Id),
+ Sm (Current_Use_Clause, Node_Id),
+ Sm (Derived_Type_Link, Node_Id),
+ Sm (Direct_Primitive_Operations, Elist_Id),
+ Sm (Predicates_Ignored, Flag),
+ Sm (Esize, Uint),
+ Sm (Finalize_Storage_Only, Flag, Base_Type_Only),
+ Sm (Full_View, Node_Id),
+ Sm (Has_Completion_In_Body, Flag),
+ Sm (Has_Constrained_Partial_View, Flag, Base_Type_Only),
+ Sm (Has_Discriminants, Flag),
+ Sm (Has_Dispatch_Table, Flag,
+ Pre => "Is_Tagged_Type (N)"),
+ Sm (Has_Dynamic_Predicate_Aspect, Flag),
+ Sm (Has_Inheritable_Invariants, Flag, Base_Type_Only),
+ Sm (Has_Inherited_DIC, Flag, Base_Type_Only),
+ Sm (Has_Inherited_Invariants, Flag, Base_Type_Only),
+ Sm (Has_Object_Size_Clause, Flag),
+ Sm (Has_Own_DIC, Flag, Base_Type_Only),
+ Sm (Has_Own_Invariants, Flag, Base_Type_Only),
+ Sm (Has_Pragma_Unreferenced_Objects, Flag),
+ Sm (Has_Predicates, Flag),
+ Sm (Has_Primitive_Operations, Flag, Base_Type_Only),
+ Sm (Has_Private_Extension, Flag,
+ Pre => "Is_Tagged_Type (N)"),
+ Sm (Has_Specified_Layout, Flag, Impl_Base_Type_Only),
+ Sm (Has_Specified_Stream_Input, Flag),
+ Sm (Has_Specified_Stream_Output, Flag),
+ Sm (Has_Specified_Stream_Read, Flag),
+ Sm (Has_Specified_Stream_Write, Flag),
+ Sm (Has_Static_Discriminants, Flag),
+ Sm (Has_Static_Predicate, Flag),
+ Sm (Has_Static_Predicate_Aspect, Flag),
+ Sm (Has_Unknown_Discriminants, Flag),
+ Sm (Interface_Name, Node_Id),
+ Sm (Is_Abstract_Type, Flag),
+ Sm (Is_Actual_Subtype, Flag),
+ Sm (Is_Asynchronous, Flag),
+ Sm (Is_Fixed_Lower_Bound_Array_Subtype, Flag),
+ Sm (Is_Fixed_Lower_Bound_Index_Subtype, Flag),
+ Sm (Is_Generic_Actual_Type, Flag),
+ Sm (Is_Non_Static_Subtype, Flag),
+ Sm (Is_Private_Composite, Flag),
+ Sm (Is_RACW_Stub_Type, Flag),
+ Sm (Is_Unsigned_Type, Flag),
+ Sm (Itype_Printed, Flag,
+ Pre => "Is_Itype (N)"),
+ Sm (Known_To_Have_Preelab_Init, Flag),
+ Sm (Linker_Section_Pragma, Node_Id),
+ Sm (Must_Be_On_Byte_Boundary, Flag),
+ Sm (Must_Have_Preelab_Init, Flag),
+ Sm (No_Tagged_Streams_Pragma, Node_Id,
+ Pre => "Is_Tagged_Type (N)"),
+ Sm (Non_Binary_Modulus, Flag, Base_Type_Only),
+ Sm (Optimize_Alignment_Space, Flag),
+ Sm (Optimize_Alignment_Time, Flag),
+ Sm (Partial_View_Has_Unknown_Discr, Flag),
+ Sm (Pending_Access_Types, Elist_Id),
+ Sm (Related_Expression, Node_Id),
+ Sm (RM_Size, Uint),
+ Sm (SPARK_Pragma, Node_Id),
+ Sm (SPARK_Pragma_Inherited, Flag),
+ Sm (Subprograms_For_Type, Elist_Id),
+ Sm (Suppress_Initialization, Flag),
+ Sm (Universal_Aliasing, Flag, Impl_Base_Type_Only),
+ Sm (Renamed_Or_Alias, Node_Id)));
+
+ Ab (Elementary_Kind, Type_Kind);
+
+ Ab (Scalar_Kind, Elementary_Kind,
+ (Sm (Default_Aspect_Value, Node_Id, Base_Type_Only),
+ Sm (Scalar_Range, Node_Id)));
+
+ Ab (Discrete_Kind, Scalar_Kind,
+ (Sm (No_Dynamic_Predicate_On_Actual, Flag),
+ Sm (No_Predicate_On_Actual, Flag),
+ Sm (Static_Discrete_Predicate, List_Id)));
+
+ Ab (Enumeration_Kind, Discrete_Kind,
+ (Sm (First_Literal, Node_Id),
+ Sm (Has_Enumeration_Rep_Clause, Flag),
+ Sm (Has_Pragma_Ordered, Flag, Impl_Base_Type_Only),
+ Sm (Lit_Indexes, Node_Id),
+ Sm (Lit_Strings, Node_Id),
+ Sm (Nonzero_Is_True, Flag, Base_Type_Only,
+ Pre => "Root_Type (N) = Standard_Boolean"),
+ Sm (Lit_Hash, Node_Id, Root_Type_Only)));
+
+ Cc (E_Enumeration_Type, Enumeration_Kind,
+ -- Enumeration types, created by an enumeration type declaration
+ (Sm (Enum_Pos_To_Rep, Node_Id),
+ Sm (First_Entity, Node_Id)));
+
+ Cc (E_Enumeration_Subtype, Enumeration_Kind);
+ -- Enumeration subtypes, created by an explicit or implicit subtype
+ -- declaration applied to an enumeration type or subtype.
+
+ Ab (Integer_Kind, Discrete_Kind,
+ (Sm (Has_Shift_Operator, Flag, Base_Type_Only)));
+
+ Ab (Signed_Integer_Kind, Integer_Kind,
+ (Sm (First_Entity, Node_Id)));
+
+ Cc (E_Signed_Integer_Type, Signed_Integer_Kind);
+ -- Signed integer type, used for the anonymous base type of the
+ -- integer subtype created by an integer type declaration.
+
+ Cc (E_Signed_Integer_Subtype, Signed_Integer_Kind);
+ -- Signed integer subtype, created by either an integer subtype or
+ -- integer type declaration (in the latter case an integer type is
+ -- created for the base type, and this is the first named subtype).
+
+ Ab (Modular_Integer_Kind, Integer_Kind,
+ (Sm (Modulus, Uint, Base_Type_Only),
+ Sm (Original_Array_Type, Node_Id)));
+
+ Cc (E_Modular_Integer_Type, Modular_Integer_Kind);
+ -- Modular integer type, used for the anonymous base type of the
+ -- integer subtype created by a modular integer type declaration.
+
+ Cc (E_Modular_Integer_Subtype, Modular_Integer_Kind);
+ -- Modular integer subtype, created by either an modular subtype
+ -- or modular type declaration (in the latter case a modular type
+ -- is created for the base type, and this is the first named subtype).
+
+ Ab (Real_Kind, Scalar_Kind,
+ (Sm (Static_Real_Or_String_Predicate, Node_Id)));
+
+ Ab (Fixed_Point_Kind, Real_Kind,
+ (Sm (Delta_Value, Ureal),
+ Sm (Small_Value, Ureal)));
+
+ Ab (Ordinary_Fixed_Point_Kind, Fixed_Point_Kind,
+ (Sm (Has_Small_Clause, Flag)));
+
+ Cc (E_Ordinary_Fixed_Point_Type, Ordinary_Fixed_Point_Kind);
+ -- Ordinary fixed type, used for the anonymous base type of the fixed
+ -- subtype created by an ordinary fixed point type declaration.
+
+ Cc (E_Ordinary_Fixed_Point_Subtype, Ordinary_Fixed_Point_Kind);
+ -- Ordinary fixed point subtype, created by either an ordinary fixed
+ -- point subtype or ordinary fixed point type declaration (in the
+ -- latter case a fixed point type is created for the base type, and
+ -- this is the first named subtype).
+
+ Ab (Decimal_Fixed_Point_Kind, Fixed_Point_Kind,
+ (Sm (Digits_Value, Uint),
+ Sm (Has_Machine_Radix_Clause, Flag),
+ Sm (Machine_Radix_10, Flag),
+ Sm (Scale_Value, Uint)));
+
+ Cc (E_Decimal_Fixed_Point_Type, Decimal_Fixed_Point_Kind);
+ -- Decimal fixed type, used for the anonymous base type of the decimal
+ -- fixed subtype created by an ordinary fixed point type declaration.
+
+ Cc (E_Decimal_Fixed_Point_Subtype, Decimal_Fixed_Point_Kind);
+ -- Decimal fixed point subtype, created by either a decimal fixed point
+ -- subtype or decimal fixed point type declaration (in the latter case
+ -- a fixed point type is created for the base type, and this is the
+ -- first named subtype).
+
+ Ab (Float_Kind, Real_Kind,
+ (Sm (Digits_Value, Uint)));
+
+ Cc (E_Floating_Point_Type, Float_Kind);
+ -- Floating point type, used for the anonymous base type of the
+ -- floating point subtype created by a floating point type declaration.
+
+ Cc (E_Floating_Point_Subtype, Float_Kind);
+ -- Floating point subtype, created by either a floating point subtype
+ -- or floating point type declaration (in the latter case a floating
+ -- point type is created for the base type, and this is the first
+ -- named subtype).
+
+ Ab (Access_Kind, Elementary_Kind,
+ (Sm (Associated_Storage_Pool, Node_Id, Root_Type_Only),
+ Sm (Directly_Designated_Type, Node_Id),
+ Sm (Finalization_Master, Node_Id, Root_Type_Only),
+ Sm (Has_Pragma_Controlled, Flag, Impl_Base_Type_Only),
+ Sm (Has_Storage_Size_Clause, Flag, Impl_Base_Type_Only),
+ Sm (Is_Access_Constant, Flag),
+ Sm (Is_Local_Anonymous_Access, Flag),
+ Sm (Is_Param_Block_Component_Type, Flag, Base_Type_Only),
+ Sm (Is_Pure_Unit_Access_Type, Flag),
+ Sm (Master_Id, Node_Id),
+ Sm (No_Pool_Assigned, Flag, Root_Type_Only),
+ Sm (No_Strict_Aliasing, Flag, Base_Type_Only),
+ Sm (Storage_Size_Variable, Node_Id, Impl_Base_Type_Only)));
+
+ Cc (E_Access_Type, Access_Kind);
+ -- An access type created by an access type declaration with no all
+ -- keyword present. Note that the predefined type Any_Access, which
+ -- has E_Access_Type Ekind, is used to label NULL in the upwards pass
+ -- of type analysis, to be replaced by the true access type in the
+ -- downwards resolution pass.
+
+ Cc (E_Access_Subtype, Access_Kind);
+ -- An access subtype created by a subtype declaration for any access
+ -- type (whether or not it is a general access type).
+
+ Cc (E_Access_Attribute_Type, Access_Kind);
+ -- An access type created for an access attribute (one of 'Access,
+ -- 'Unrestricted_Access, or Unchecked_Access).
+
+ Cc (E_Allocator_Type, Access_Kind);
+ -- A special internal type used to label allocators and references to
+ -- objects using 'Reference. This is needed because special resolution
+ -- rules apply to these constructs. On the resolution pass, this type
+ -- is almost always replaced by the actual access type, but if the
+ -- context does not provide one, the backend will see Allocator_Type
+ -- itself (which will already have been frozen).
+
+ Cc (E_General_Access_Type, Access_Kind,
+ -- An access type created by an access type declaration with the all
+ -- keyword present.
+ (Sm (First_Entity, Node_Id)));
+
+ Ab (Access_Subprogram_Kind, Access_Kind);
+
+ Cc (E_Access_Subprogram_Type, Access_Subprogram_Kind,
+ -- An access-to-subprogram type, created by an access-to-subprogram
+ -- declaration.
+ (Sm (Equivalent_Type, Node_Id),
+ Sm (Original_Access_Type, Node_Id)));
+
+ Ab (Access_Protected_Kind, Access_Subprogram_Kind,
+ (Sm (Equivalent_Type, Node_Id)));
+
+ Cc (E_Access_Protected_Subprogram_Type, Access_Protected_Kind);
+ -- An access to a protected subprogram, created by the corresponding
+ -- declaration. Values of such a type denote both a protected object
+ -- and a protected operation within, and have different compile-time
+ -- and run-time properties than other access-to-subprogram values.
+
+ Cc (E_Anonymous_Access_Protected_Subprogram_Type, Access_Protected_Kind);
+ -- An anonymous access-to-protected-subprogram type, created by an
+ -- access-to-subprogram declaration.
+
+ Cc (E_Anonymous_Access_Subprogram_Type, Access_Subprogram_Kind);
+ -- An anonymous access-to-subprogram type, created by an access-to-
+ -- subprogram declaration, or generated for a current instance of
+ -- a type name appearing within a component definition that has an
+ -- anonymous access-to-subprogram type.
+
+ Cc (E_Anonymous_Access_Type, Access_Kind);
+ -- An anonymous access-to-object type
+
+ Ab (Composite_Kind, Type_Kind,
+ (Sm (Discriminant_Constraint, Elist_Id,
+ Pre_Get => "Has_Discriminants (N) or else Is_Constrained (N)")));
+
+ Ab (Aggregate_Kind, Composite_Kind,
+ (Sm (Component_Alignment, Component_Alignment_Kind, Base_Type_Only),
+ Sm (Has_Pragma_Pack, Flag, Impl_Base_Type_Only),
+ Sm (Reverse_Storage_Order, Flag, Base_Type_Only),
+ Sm (SSO_Set_High_By_Default, Flag, Base_Type_Only),
+ Sm (SSO_Set_Low_By_Default, Flag, Base_Type_Only)));
+
+ Ab (Array_Kind, Aggregate_Kind,
+ (Sm (Component_Size, Uint, Impl_Base_Type_Only),
+ Sm (Component_Type, Node_Id, Impl_Base_Type_Only),
+ Sm (Default_Aspect_Component_Value, Node_Id, Base_Type_Only),
+ Sm (First_Index, Node_Id),
+ Sm (Has_Component_Size_Clause, Flag, Impl_Base_Type_Only),
+ Sm (Original_Array_Type, Node_Id),
+ Sm (Packed_Array_Impl_Type, Node_Id),
+ Sm (Related_Array_Object, Node_Id)));
+
+ Cc (E_Array_Type, Array_Kind,
+ -- An array type created by an array type declaration. Includes all
+ -- cases of arrays, except for string types.
+ (Sm (First_Entity, Node_Id),
+ Sm (Static_Real_Or_String_Predicate, Node_Id)));
+
+ Cc (E_Array_Subtype, Array_Kind,
+ -- An array subtype, created by an explicit array subtype declaration,
+ -- or the use of an anonymous array subtype.
+ (Sm (Predicated_Parent, Node_Id),
+ Sm (First_Entity, Node_Id),
+ Sm (Static_Real_Or_String_Predicate, Node_Id)));
+
+ Cc (E_String_Literal_Subtype, Array_Kind,
+ -- A special string subtype, used only to describe the type of a string
+ -- literal (will always be one dimensional, with literal bounds).
+ (Sm (String_Literal_Length, Unat),
+ Sm (String_Literal_Low_Bound, Node_Id)));
+
+ Ab (Class_Wide_Kind, Aggregate_Kind,
+ (Sm (C_Pass_By_Copy, Flag, Impl_Base_Type_Only),
+ Sm (Equivalent_Type, Node_Id),
+ Sm (First_Entity, Node_Id),
+ Sm (Has_Complex_Representation, Flag, Impl_Base_Type_Only),
+ Sm (Has_Record_Rep_Clause, Flag, Impl_Base_Type_Only),
+ Sm (Interfaces, Elist_Id),
+ Sm (Last_Entity, Node_Id),
+ Sm (No_Reordering, Flag, Impl_Base_Type_Only),
+ Sm (Non_Limited_View, Node_Id),
+ Sm (Parent_Subtype, Node_Id, Base_Type_Only),
+ Sm (Reverse_Bit_Order, Flag, Base_Type_Only),
+ Sm (Stored_Constraint, Elist_Id)));
+
+ Cc (E_Class_Wide_Type, Class_Wide_Kind,
+ -- A class wide type, created by any tagged type declaration (i.e. if
+ -- a tagged type is declared, the corresponding class type is always
+ -- created, using this Ekind value).
+ (Sm (Corresponding_Remote_Type, Node_Id),
+ Sm (Scalar_Range, Node_Id)));
+
+ Cc (E_Class_Wide_Subtype, Class_Wide_Kind,
+ -- A subtype of a class wide type, created by a subtype declaration
+ -- used to declare a subtype of a class type.
+ (Sm (Cloned_Subtype, Node_Id)));
+
+ Cc (E_Record_Type, Aggregate_Kind,
+ -- A record type, created by a record type declaration
+ (Sm (Access_Disp_Table, Elist_Id, Impl_Base_Type_Only),
+ Sm (Access_Disp_Table_Elab_Flag, Node_Id, Impl_Base_Type_Only),
+ Sm (C_Pass_By_Copy, Flag, Impl_Base_Type_Only),
+ Sm (Corresponding_Concurrent_Type, Node_Id),
+ Sm (Corresponding_Remote_Type, Node_Id),
+ Sm (Dispatch_Table_Wrappers, Elist_Id, Impl_Base_Type_Only),
+ Sm (First_Entity, Node_Id),
+ Sm (Has_Complex_Representation, Flag, Impl_Base_Type_Only),
+ Sm (Has_Record_Rep_Clause, Flag, Impl_Base_Type_Only),
+ Sm (Interfaces, Elist_Id),
+ Sm (Last_Entity, Node_Id),
+ Sm (No_Reordering, Flag, Impl_Base_Type_Only),
+ Sm (Parent_Subtype, Node_Id, Base_Type_Only),
+ Sm (Reverse_Bit_Order, Flag, Base_Type_Only),
+ Sm (Stored_Constraint, Elist_Id),
+ Sm (Underlying_Record_View, Node_Id)));
+
+ Cc (E_Record_Subtype, Aggregate_Kind,
+ -- A record subtype, created by a record subtype declaration
+ (Sm (Access_Disp_Table, Elist_Id, Impl_Base_Type_Only),
+ Sm (Access_Disp_Table_Elab_Flag, Node_Id, Impl_Base_Type_Only),
+ Sm (C_Pass_By_Copy, Flag, Impl_Base_Type_Only),
+ Sm (Cloned_Subtype, Node_Id),
+ Sm (Corresponding_Remote_Type, Node_Id),
+ Sm (Predicated_Parent, Node_Id),
+ Sm (Dispatch_Table_Wrappers, Elist_Id, Impl_Base_Type_Only),
+ Sm (First_Entity, Node_Id),
+ Sm (Has_Complex_Representation, Flag, Impl_Base_Type_Only),
+ Sm (Has_Record_Rep_Clause, Flag, Impl_Base_Type_Only),
+ Sm (Interfaces, Elist_Id),
+ Sm (Last_Entity, Node_Id),
+ Sm (No_Reordering, Flag, Impl_Base_Type_Only),
+ Sm (Parent_Subtype, Node_Id, Base_Type_Only),
+ Sm (Reverse_Bit_Order, Flag, Base_Type_Only),
+ Sm (Stored_Constraint, Elist_Id),
+ Sm (Underlying_Record_View, Node_Id)));
+
+ Ab (Incomplete_Or_Private_Kind, Composite_Kind,
+ (Sm (First_Entity, Node_Id),
+ Sm (Last_Entity, Node_Id),
+ Sm (Private_Dependents, Elist_Id),
+ Sm (Stored_Constraint, Elist_Id)));
+
+ Ab (Private_Kind, Incomplete_Or_Private_Kind,
+ (Sm (Underlying_Full_View, Node_Id)));
+
+ Cc (E_Record_Type_With_Private, Private_Kind,
+ -- Used for types defined by a private extension declaration,
+ -- and for tagged private types. Includes the fields for both
+ -- private types and for record types (with the sole exception of
+ -- Corresponding_Concurrent_Type which is obviously not needed). This
+ -- entity is considered to be both a record type and a private type.
+ (Sm (Access_Disp_Table, Elist_Id, Impl_Base_Type_Only),
+ Sm (Access_Disp_Table_Elab_Flag, Node_Id, Impl_Base_Type_Only),
+ Sm (C_Pass_By_Copy, Flag, Impl_Base_Type_Only),
+ Sm (Component_Alignment, Component_Alignment_Kind, Base_Type_Only),
+ Sm (Corresponding_Remote_Type, Node_Id),
+ Sm (Has_Complex_Representation, Flag, Impl_Base_Type_Only),
+ Sm (Has_Pragma_Pack, Flag, Impl_Base_Type_Only),
+ Sm (Has_Record_Rep_Clause, Flag, Impl_Base_Type_Only),
+ Sm (Interfaces, Elist_Id),
+ Sm (No_Reordering, Flag, Impl_Base_Type_Only),
+ Sm (Parent_Subtype, Node_Id, Base_Type_Only),
+ Sm (Reverse_Bit_Order, Flag, Base_Type_Only),
+ Sm (Reverse_Storage_Order, Flag, Base_Type_Only),
+ Sm (SSO_Set_High_By_Default, Flag, Base_Type_Only),
+ Sm (SSO_Set_Low_By_Default, Flag, Base_Type_Only),
+ Sm (Underlying_Record_View, Node_Id)));
+
+ Cc (E_Record_Subtype_With_Private, Private_Kind,
+ -- A subtype of a type defined by a private extension declaration
+ (Sm (C_Pass_By_Copy, Flag, Impl_Base_Type_Only),
+ Sm (Component_Alignment, Component_Alignment_Kind, Base_Type_Only),
+ Sm (Corresponding_Remote_Type, Node_Id),
+ Sm (Predicated_Parent, Node_Id),
+ Sm (Has_Complex_Representation, Flag, Impl_Base_Type_Only),
+ Sm (Has_Pragma_Pack, Flag, Impl_Base_Type_Only),
+ Sm (Has_Record_Rep_Clause, Flag, Impl_Base_Type_Only),
+ Sm (Interfaces, Elist_Id),
+ Sm (No_Reordering, Flag, Impl_Base_Type_Only),
+ Sm (Parent_Subtype, Node_Id, Base_Type_Only),
+ Sm (Reverse_Bit_Order, Flag, Base_Type_Only),
+ Sm (Reverse_Storage_Order, Flag, Base_Type_Only),
+ Sm (SSO_Set_High_By_Default, Flag, Base_Type_Only),
+ Sm (SSO_Set_Low_By_Default, Flag, Base_Type_Only)));
+
+ Cc (E_Private_Type, Private_Kind,
+ -- A private type, created by a private type declaration that has
+ -- neither the keyword limited nor the keyword tagged.
+ (Sm (Scalar_Range, Node_Id),
+ Sm (Scope_Depth_Value, Uint)));
+
+ Cc (E_Private_Subtype, Private_Kind,
+ -- A subtype of a private type, created by a subtype declaration used
+ -- to declare a subtype of a private type.
+ (Sm (Scope_Depth_Value, Uint)));
+
+ Cc (E_Limited_Private_Type, Private_Kind,
+ -- A limited private type, created by a private type declaration that
+ -- has the keyword limited, but not the keyword tagged.
+ (Sm (Scalar_Range, Node_Id),
+ Sm (Scope_Depth_Value, Uint)));
+
+ Cc (E_Limited_Private_Subtype, Private_Kind,
+ -- A subtype of a limited private type, created by a subtype declaration
+ -- used to declare a subtype of a limited private type.
+ (Sm (Scope_Depth_Value, Uint)));
+
+ Ab (Incomplete_Kind, Incomplete_Or_Private_Kind,
+ (Sm (Non_Limited_View, Node_Id)));
+
+ Cc (E_Incomplete_Type, Incomplete_Kind,
+ -- An incomplete type, created by an incomplete type declaration
+ (Sm (Scalar_Range, Node_Id)));
+
+ Cc (E_Incomplete_Subtype, Incomplete_Kind);
+ -- An incomplete subtype, created by a subtype declaration where the
+ -- subtype mark denotes an incomplete type.
+
+ Ab (Concurrent_Kind, Composite_Kind,
+ (Sm (Corresponding_Record_Type, Node_Id),
+ Sm (First_Entity, Node_Id),
+ Sm (First_Private_Entity, Node_Id),
+ Sm (Last_Entity, Node_Id),
+ Sm (Scope_Depth_Value, Uint),
+ Sm (Stored_Constraint, Elist_Id)));
+
+ Ab (Task_Kind, Concurrent_Kind,
+ (Sm (Has_Storage_Size_Clause, Flag, Impl_Base_Type_Only),
+ Sm (Is_Elaboration_Checks_OK_Id, Flag),
+ Sm (Is_Elaboration_Warnings_OK_Id, Flag),
+ Sm (Relative_Deadline_Variable, Node_Id, Impl_Base_Type_Only),
+ Sm (Storage_Size_Variable, Node_Id, Impl_Base_Type_Only),
+ Sm (Task_Body_Procedure, Node_Id)));
+
+ Cc (E_Task_Type, Task_Kind,
+ -- A task type, created by a task type declaration. An entity with this
+ -- Ekind is also created to describe the anonymous type of a task that
+ -- is created by a single task declaration.
+ (Sm (Anonymous_Object, Node_Id),
+ Sm (Ignore_SPARK_Mode_Pragmas, Flag),
+ Sm (SPARK_Aux_Pragma, Node_Id),
+ Sm (SPARK_Aux_Pragma_Inherited, Flag)));
+
+ Cc (E_Task_Subtype, Task_Kind);
+ -- A subtype of a task type, created by a subtype declaration used to
+ -- declare a subtype of a task type.
+
+ Ab (Protected_Kind, Concurrent_Kind,
+ (Sm (Entry_Bodies_Array, Node_Id,
+ Pre => "Has_Entries (N)"),
+ Sm (Uses_Lock_Free, Flag)));
+
+ Cc (E_Protected_Type, Protected_Kind,
+ -- A protected type, created by a protected type declaration. An entity
+ -- with this Ekind is also created to describe the anonymous type of
+ -- a protected object created by a single protected declaration.
+ (Sm (Anonymous_Object, Node_Id),
+ Sm (Entry_Max_Queue_Lengths_Array, Node_Id),
+ Sm (Ignore_SPARK_Mode_Pragmas, Flag),
+ Sm (SPARK_Aux_Pragma, Node_Id),
+ Sm (SPARK_Aux_Pragma_Inherited, Flag)));
+
+ Cc (E_Protected_Subtype, Protected_Kind);
+ -- A subtype of a protected type, created by a subtype declaration used
+ -- to declare a subtype of a protected type.
+
+ Cc (E_Exception_Type, Type_Kind,
+ -- The type of an exception created by an exception declaration
+ (Sm (Equivalent_Type, Node_Id)));
+
+ Cc (E_Subprogram_Type, Type_Kind,
+ -- This is the designated type of an Access_To_Subprogram. Has type and
+ -- signature like a subprogram entity, so can appear in calls, which
+ -- are resolved like regular calls, except that such an entity is not
+ -- overloadable.
+ (Sm (Access_Subprogram_Wrapper, Node_Id),
+ Sm (Extra_Accessibility_Of_Result, Node_Id),
+ Sm (Extra_Formals, Node_Id),
+ Sm (First_Entity, Node_Id),
+ Sm (Last_Entity, Node_Id),
+ Sm (Needs_No_Actuals, Flag)));
+
+ Ab (Overloadable_Kind, Entity_Kind,
+ (Sm (Renamed_Or_Alias, Node_Id),
+ Sm (Extra_Formals, Node_Id),
+ Sm (Is_Abstract_Subprogram, Flag),
+ Sm (Is_Primitive, Flag),
+ Sm (Needs_No_Actuals, Flag),
+ Sm (Requires_Overriding, Flag)));
+
+ Cc (E_Enumeration_Literal, Overloadable_Kind,
+ -- An enumeration literal, created by the use of the literal in an
+ -- enumeration type definition.
+ (Sm (Enumeration_Pos, Unat),
+ Sm (Enumeration_Rep, Valid_Uint),
+ Sm (Enumeration_Rep_Expr, Node_Id),
+ Sm (Esize, Uint),
+ Sm (Alignment, Unat),
+ Sm (Interface_Name, Node_Id)));
+
+ Ab (Subprogram_Kind, Overloadable_Kind,
+ (Sm (Body_Needed_For_SAL, Flag),
+ Sm (Class_Wide_Clone, Node_Id),
+ Sm (Contract, Node_Id),
+ Sm (Elaboration_Entity, Node_Id),
+ Sm (Elaboration_Entity_Required, Flag),
+ Sm (First_Entity, Node_Id),
+ Sm (Has_Expanded_Contract, Flag),
+ Sm (Has_Nested_Subprogram, Flag),
+ Sm (Has_Out_Or_In_Out_Parameter, Flag),
+ Sm (Has_Recursive_Call, Flag),
+ Sm (Ignore_SPARK_Mode_Pragmas, Flag),
+ Sm (Import_Pragma, Node_Id),
+ Sm (Interface_Alias, Node_Id),
+ Sm (Interface_Name, Node_Id),
+ Sm (Is_Elaboration_Checks_OK_Id, Flag),
+ Sm (Is_Elaboration_Warnings_OK_Id, Flag),
+ Sm (Is_Machine_Code_Subprogram, Flag),
+ Sm (Last_Entity, Node_Id),
+ Sm (Linker_Section_Pragma, Node_Id),
+ Sm (Overridden_Operation, Node_Id),
+ Sm (Protected_Body_Subprogram, Node_Id),
+ Sm (Scope_Depth_Value, Uint),
+ Sm (SPARK_Pragma, Node_Id),
+ Sm (SPARK_Pragma_Inherited, Flag),
+ Sm (Subps_Index, Uint)));
+
+ Cc (E_Function, Subprogram_Kind,
+ -- A function, created by a function declaration or a function body
+ -- that acts as its own declaration.
+ (Sm (Anonymous_Masters, Elist_Id),
+ Sm (Corresponding_Equality, Node_Id,
+ Pre => "not Comes_From_Source (N) and then Chars (N) = Name_Op_Ne"),
+ Sm (Corresponding_Procedure, Node_Id),
+ Sm (DT_Position, Uint,
+ Pre_Get => "Present (DTC_Entity (N))"),
+ Sm (DTC_Entity, Node_Id),
+ Sm (Extra_Accessibility_Of_Result, Node_Id),
+ Sm (Generic_Renamings, Elist_Id),
+ Sm (Handler_Records, List_Id),
+ Sm (Has_Missing_Return, Flag),
+ Sm (Inner_Instances, Elist_Id),
+ Sm (Is_Called, Flag),
+ Sm (Is_CUDA_Kernel, Flag),
+ Sm (Is_DIC_Procedure, Flag),
+ Sm (Is_Generic_Actual_Subprogram, Flag),
+ Sm (Is_Initial_Condition_Procedure, Flag),
+ Sm (Is_Inlined_Always, Flag),
+ Sm (Is_Invariant_Procedure, Flag),
+ Sm (Is_Partial_Invariant_Procedure, Flag),
+ Sm (Is_Predicate_Function, Flag),
+ Sm (Is_Predicate_Function_M, Flag),
+ Sm (Is_Primitive_Wrapper, Flag),
+ Sm (Is_Private_Primitive, Flag),
+ Sm (LSP_Subprogram, Node_Id),
+ Sm (Mechanism, Mechanism_Type),
+ Sm (Next_Inlined_Subprogram, Node_Id),
+ Sm (Original_Protected_Subprogram, Node_Id),
+ Sm (Postconditions_Proc, Node_Id),
+ Sm (Protected_Subprogram, Node_Id),
+ Sm (Protection_Object, Node_Id),
+ Sm (Related_Expression, Node_Id),
+ Sm (Rewritten_For_C, Flag),
+ Sm (Thunk_Entity, Node_Id,
+ Pre => "Is_Thunk (N)"),
+ Sm (Wrapped_Entity, Node_Id,
+ Pre => "Is_Primitive_Wrapper (N)")));
+
+ Cc (E_Operator, Subprogram_Kind,
+ -- A predefined operator, appearing in Standard, or an implicitly
+ -- defined concatenation operator created whenever an array is declared.
+ -- We do not make normal derived operators explicit in the tree, but the
+ -- concatenation operators are made explicit.
+ (Sm (Extra_Accessibility_Of_Result, Node_Id),
+ Sm (LSP_Subprogram, Node_Id)));
+
+ Cc (E_Procedure, Subprogram_Kind,
+ -- A procedure, created by a procedure declaration or a procedure
+ -- body that acts as its own declaration.
+ (Sm (Anonymous_Masters, Elist_Id),
+ Sm (Associated_Node_For_Itype, Node_Id),
+ Sm (Corresponding_Function, Node_Id),
+ Sm (DT_Position, Uint,
+ Pre_Get => "Present (DTC_Entity (N))"),
+ Sm (DTC_Entity, Node_Id),
+ Sm (Entry_Parameters_Type, Node_Id),
+ Sm (Generic_Renamings, Elist_Id),
+ Sm (Handler_Records, List_Id),
+ Sm (Inner_Instances, Elist_Id),
+ Sm (Is_Asynchronous, Flag),
+ Sm (Is_Called, Flag),
+ Sm (Is_CUDA_Kernel, Flag),
+ Sm (Is_DIC_Procedure, Flag),
+ Sm (Is_Generic_Actual_Subprogram, Flag),
+ Sm (Is_Initial_Condition_Procedure, Flag),
+ Sm (Is_Inlined_Always, Flag),
+ Sm (Is_Invariant_Procedure, Flag),
+ Sm (Is_Null_Init_Proc, Flag),
+ Sm (Is_Partial_Invariant_Procedure, Flag),
+ Sm (Is_Predicate_Function, Flag),
+ Sm (Is_Predicate_Function_M, Flag),
+ Sm (Is_Primitive_Wrapper, Flag),
+ Sm (Is_Private_Primitive, Flag),
+ Sm (Is_Valued_Procedure, Flag),
+ Sm (LSP_Subprogram, Node_Id),
+ Sm (Next_Inlined_Subprogram, Node_Id),
+ Sm (Original_Protected_Subprogram, Node_Id),
+ Sm (Postconditions_Proc, Node_Id),
+ Sm (Protected_Subprogram, Node_Id),
+ Sm (Protection_Object, Node_Id),
+ Sm (Receiving_Entry, Node_Id),
+ Sm (Static_Initialization, Node_Id,
+ Pre => "not Is_Dispatching_Operation (N)"),
+ Sm (Thunk_Entity, Node_Id,
+ Pre => "Is_Thunk (N)"),
+ Sm (Wrapped_Entity, Node_Id,
+ Pre => "Is_Primitive_Wrapper (N)")));
+
+ Cc (E_Abstract_State, Overloadable_Kind,
+ -- A state abstraction. Used to designate entities introduced by aspect
+ -- or pragma Abstract_State. The entity carries the various properties
+ -- of the state.
+ (Sm (Body_References, Elist_Id),
+ Sm (Encapsulating_State, Node_Id),
+ Sm (First_Entity, Node_Id),
+ Sm (Has_Partial_Visible_Refinement, Flag),
+ Sm (Has_Visible_Refinement, Flag),
+ Sm (Non_Limited_View, Node_Id),
+ Sm (Part_Of_Constituents, Elist_Id),
+ Sm (Refinement_Constituents, Elist_Id),
+ Sm (SPARK_Pragma, Node_Id),
+ Sm (SPARK_Pragma_Inherited, Flag)));
+
+ Cc (E_Entry, Overloadable_Kind,
+ -- An entry, created by an entry declaration in a task or protected
+ -- object.
+ (Sm (Accept_Address, Elist_Id),
+ Sm (Barrier_Function, Node_Id),
+ Sm (Contract, Node_Id),
+ Sm (Contract_Wrapper, Node_Id),
+ Sm (Elaboration_Entity, Node_Id),
+ Sm (Elaboration_Entity_Required, Flag),
+ Sm (Entry_Accepted, Flag),
+ Sm (Entry_Parameters_Type, Node_Id),
+ Sm (First_Entity, Node_Id),
+ Sm (Has_Out_Or_In_Out_Parameter, Flag),
+ Sm (Ignore_SPARK_Mode_Pragmas, Flag),
+ Sm (Is_Elaboration_Checks_OK_Id, Flag),
+ Sm (Is_Elaboration_Warnings_OK_Id, Flag),
+ Sm (Last_Entity, Node_Id),
+ Sm (Postconditions_Proc, Node_Id),
+ Sm (Protected_Body_Subprogram, Node_Id),
+ Sm (Protection_Object, Node_Id),
+ Sm (Scope_Depth_Value, Uint),
+ Sm (SPARK_Pragma, Node_Id),
+ Sm (SPARK_Pragma_Inherited, Flag)));
+
+ Cc (E_Entry_Family, Entity_Kind,
+ -- An entry family, created by an entry family declaration in a
+ -- task or protected type definition.
+ (Sm (Accept_Address, Elist_Id),
+ Sm (Barrier_Function, Node_Id),
+ Sm (Contract, Node_Id),
+ Sm (Contract_Wrapper, Node_Id),
+ Sm (Elaboration_Entity, Node_Id),
+ Sm (Elaboration_Entity_Required, Flag),
+ Sm (Entry_Accepted, Flag),
+ Sm (Entry_Parameters_Type, Node_Id),
+ Sm (Extra_Formals, Node_Id),
+ Sm (First_Entity, Node_Id),
+ Sm (Has_Out_Or_In_Out_Parameter, Flag),
+ Sm (Ignore_SPARK_Mode_Pragmas, Flag),
+ Sm (Is_Elaboration_Checks_OK_Id, Flag),
+ Sm (Is_Elaboration_Warnings_OK_Id, Flag),
+ Sm (Last_Entity, Node_Id),
+ Sm (Needs_No_Actuals, Flag),
+ Sm (Postconditions_Proc, Node_Id),
+ Sm (Protected_Body_Subprogram, Node_Id),
+ Sm (Protection_Object, Node_Id),
+ Sm (Renamed_Or_Alias, Node_Id),
+ Sm (Scope_Depth_Value, Uint),
+ Sm (SPARK_Pragma, Node_Id),
+ Sm (SPARK_Pragma_Inherited, Flag)));
+
+ Cc (E_Block, Entity_Kind,
+ -- A block identifier, created by an explicit or implicit label on
+ -- a block or declare statement.
+ (Sm (Block_Node, Node_Id),
+ Sm (Entry_Cancel_Parameter, Node_Id),
+ Sm (First_Entity, Node_Id),
+ Sm (Is_Exception_Handler, Flag),
+ Sm (Last_Entity, Node_Id),
+ Sm (Renamed_Or_Alias, Node_Id),
+ Sm (Return_Applies_To, Node_Id),
+ Sm (Scope_Depth_Value, Uint)));
+
+ Cc (E_Entry_Index_Parameter, Entity_Kind,
+ -- An entry index parameter created by an entry index specification
+ -- for the body of a protected entry family.
+ (Sm (Entry_Index_Constant, Node_Id)));
+
+ Cc (E_Exception, Exception_Or_Object_Kind,
+ -- An exception created by an exception declaration. The exception
+ -- itself uses E_Exception for the Ekind, the implicit type that is
+ -- created to represent its type uses the Ekind E_Exception_Type.
+ (Sm (Alignment, Unat),
+ Sm (Esize, Uint),
+ Sm (Interface_Name, Node_Id),
+ Sm (Is_Raised, Flag),
+ Sm (Register_Exception_Call, Node_Id),
+ Sm (Renamed_Or_Alias, Node_Id)));
+
+ Ab (Generic_Unit_Kind, Entity_Kind,
+ (Sm (Body_Needed_For_SAL, Flag),
+ Sm (Contract, Node_Id),
+ Sm (Elaboration_Entity, Node_Id),
+ Sm (Elaboration_Entity_Required, Flag),
+ Sm (First_Entity, Node_Id),
+ Sm (Ignore_SPARK_Mode_Pragmas, Flag),
+ Sm (Inner_Instances, Elist_Id),
+ Sm (Interface_Name, Node_Id),
+ Sm (Is_Elaboration_Checks_OK_Id, Flag),
+ Sm (Is_Elaboration_Warnings_OK_Id, Flag),
+ Sm (Last_Entity, Node_Id),
+ Sm (Renamed_Or_Alias, Node_Id),
+ Sm (Scope_Depth_Value, Uint),
+ Sm (SPARK_Pragma, Node_Id),
+ Sm (SPARK_Pragma_Inherited, Flag)));
+
+ Ab (Generic_Subprogram_Kind, Generic_Unit_Kind,
+ (Sm (Has_Out_Or_In_Out_Parameter, Flag),
+ Sm (Is_Primitive, Flag),
+ Sm (Next_Inlined_Subprogram, Node_Id),
+ Sm (Overridden_Operation, Node_Id)));
+
+ Cc (E_Generic_Function, Generic_Subprogram_Kind,
+ -- A generic function. This is the entity for a generic function
+ -- created by a generic subprogram declaration.
+ (Sm (Has_Missing_Return, Flag)));
+
+ Cc (E_Generic_Procedure, Generic_Subprogram_Kind);
+ -- A generic function. This is the entity for a generic procedure
+ -- created by a generic subprogram declaration.
+
+ Cc (E_Generic_Package, Generic_Unit_Kind,
+ -- A generic package, this is the entity for a generic package created
+ -- by a generic package declaration.
+ (Sm (Abstract_States, Elist_Id),
+ Sm (Body_Entity, Node_Id),
+ Sm (First_Private_Entity, Node_Id),
+ Sm (Generic_Homonym, Node_Id),
+ Sm (Package_Instantiation, Node_Id),
+ Sm (SPARK_Aux_Pragma, Node_Id),
+ Sm (SPARK_Aux_Pragma_Inherited, Flag)));
+
+ Cc (E_Label, Entity_Kind,
+ -- The defining entity for a label. Note that this is created by the
+ -- implicit label declaration, not the occurrence of the label itself,
+ -- which is simply a direct name referring to the label.
+ (Sm (Enclosing_Scope, Node_Id),
+ Sm (Renamed_Or_Alias, Node_Id)));
+
+ Cc (E_Loop, Entity_Kind,
+ -- A loop identifier, created by an explicit or implicit label on a
+ -- loop statement.
+ (Sm (First_Entity, Node_Id),
+ Sm (First_Exit_Statement, Node_Id),
+ Sm (Has_Loop_Entry_Attributes, Flag),
+ Sm (Last_Entity, Node_Id),
+ Sm (Renamed_Or_Alias, Node_Id),
+ Sm (Scope_Depth_Value, Uint)));
+
+ Cc (E_Return_Statement, Entity_Kind,
+ -- A dummy entity created for each return statement. Used to hold
+ -- information about the return statement (what it applies to) and in
+ -- rules checking. For example, a simple_return_statement that applies
+ -- to an extended_return_statement cannot have an expression; this
+ -- requires putting the E_Return_Statement entity for the
+ -- extended_return_statement on the scope stack.
+ (Sm (First_Entity, Node_Id),
+ Sm (Last_Entity, Node_Id),
+ Sm (Return_Applies_To, Node_Id),
+ Sm (Scope_Depth_Value, Uint)));
+
+ Cc (E_Package, Entity_Kind,
+ -- A package, created by a package declaration
+ (Sm (Abstract_States, Elist_Id),
+ Sm (Anonymous_Masters, Elist_Id),
+ Sm (Associated_Formal_Package, Node_Id),
+ Sm (Body_Entity, Node_Id),
+ Sm (Body_Needed_For_Inlining, Flag),
+ Sm (Body_Needed_For_SAL, Flag),
+ Sm (Contract, Node_Id),
+ Sm (Current_Use_Clause, Node_Id),
+ Sm (Dependent_Instances, Elist_Id,
+ Pre => "Is_Generic_Instance (N)"),
+ Sm (Elaborate_Body_Desirable, Flag),
+ Sm (Elaboration_Entity, Node_Id),
+ Sm (Elaboration_Entity_Required, Flag),
+ Sm (Finalizer, Node_Id),
+ Sm (First_Entity, Node_Id),
+ Sm (First_Private_Entity, Node_Id),
+ Sm (Generic_Renamings, Elist_Id),
+ Sm (Handler_Records, List_Id),
+ Sm (Has_RACW, Flag),
+ Sm (Hidden_In_Formal_Instance, Elist_Id),
+ Sm (Ignore_SPARK_Mode_Pragmas, Flag),
+ Sm (Incomplete_Actuals, Elist_Id),
+ Sm (Inner_Instances, Elist_Id),
+ Sm (Interface_Name, Node_Id),
+ Sm (Is_Called, Flag),
+ Sm (Is_Elaboration_Checks_OK_Id, Flag),
+ Sm (Is_Elaboration_Warnings_OK_Id, Flag),
+ Sm (Last_Entity, Node_Id),
+ Sm (Limited_View, Node_Id),
+ Sm (Package_Instantiation, Node_Id),
+ Sm (Related_Instance, Node_Id),
+ Sm (Renamed_In_Spec, Flag),
+ Sm (Renamed_Or_Alias, Node_Id),
+ Sm (Scope_Depth_Value, Uint),
+ Sm (SPARK_Aux_Pragma, Node_Id),
+ Sm (SPARK_Aux_Pragma_Inherited, Flag),
+ Sm (SPARK_Pragma, Node_Id),
+ Sm (SPARK_Pragma_Inherited, Flag),
+ Sm (Static_Elaboration_Desired, Flag)));
+
+ Cc (E_Package_Body, Entity_Kind,
+ -- A package body. This entity serves only limited functions, since
+ -- most semantic analysis uses the package entity (E_Package). However
+ -- there are some attributes that are significant for the body entity.
+ -- For example, collection of exception handlers.
+ (Sm (Contract, Node_Id),
+ Sm (Finalizer, Node_Id),
+ Sm (First_Entity, Node_Id),
+ Sm (Handler_Records, List_Id),
+ Sm (Ignore_SPARK_Mode_Pragmas, Flag),
+ Sm (Last_Entity, Node_Id),
+ Sm (Related_Instance, Node_Id),
+ Sm (Renamed_Or_Alias, Node_Id),
+ Sm (Scope_Depth_Value, Uint),
+ Sm (SPARK_Aux_Pragma, Node_Id),
+ Sm (SPARK_Aux_Pragma_Inherited, Flag),
+ Sm (SPARK_Pragma, Node_Id),
+ Sm (SPARK_Pragma_Inherited, Flag),
+ Sm (Spec_Entity, Node_Id)));
+
+ Ab (Concurrent_Body_Kind, Entity_Kind,
+ (Sm (Ignore_SPARK_Mode_Pragmas, Flag),
+ Sm (SPARK_Pragma, Node_Id),
+ Sm (SPARK_Pragma_Inherited, Flag)));
+
+ Cc (E_Protected_Body, Concurrent_Body_Kind);
+ -- A protected body. This entity serves almost no function, since all
+ -- semantic analysis uses the protected entity (E_Protected_Type).
+
+ Cc (E_Task_Body, Concurrent_Body_Kind,
+ -- A task body. This entity serves almost no function, since all
+ -- semantic analysis uses the protected entity (E_Task_Type).
+ (Sm (Contract, Node_Id),
+ Sm (First_Entity, Node_Id)));
+
+ Cc (E_Subprogram_Body, Entity_Kind,
+ -- A subprogram body. Used when a subprogram has a separate declaration
+ -- to represent the entity for the body. This entity serves almost no
+ -- function, since all semantic analysis uses the subprogram entity
+ -- for the declaration (E_Function or E_Procedure).
+ (Sm (Anonymous_Masters, Elist_Id),
+ Sm (Contract, Node_Id),
+ Sm (Extra_Formals, Node_Id),
+ Sm (First_Entity, Node_Id),
+ Sm (Ignore_SPARK_Mode_Pragmas, Flag),
+ Sm (Interface_Name, Node_Id),
+ Sm (Last_Entity, Node_Id),
+ Sm (Renamed_Or_Alias, Node_Id),
+ Sm (Scope_Depth_Value, Uint),
+ Sm (SPARK_Pragma, Node_Id),
+ Sm (SPARK_Pragma_Inherited, Flag)));
+
+ -- Union types. These don't fit into the normal parent/child hierarchy
+ -- above.
+
+ Union (Anonymous_Access_Kind,
+ Children =>
+ (E_Anonymous_Access_Protected_Subprogram_Type,
+ E_Anonymous_Access_Subprogram_Type,
+ E_Anonymous_Access_Type));
+
+ Union (Assignable_Kind,
+ Children =>
+ (E_Variable,
+ E_Out_Parameter,
+ E_In_Out_Parameter));
+
+ Union (Digits_Kind,
+ Children =>
+ (Decimal_Fixed_Point_Kind,
+ Float_Kind));
+
+ Union (Discrete_Or_Fixed_Point_Kind,
+ Children =>
+ (Discrete_Kind,
+ Fixed_Point_Kind));
+
+ Union (Entry_Kind,
+ Children =>
+ (E_Entry,
+ E_Entry_Family));
+
+ Union (Named_Access_Kind,
+ Children =>
+ (E_Access_Type,
+ E_Access_Subtype,
+ E_Access_Attribute_Type,
+ E_Allocator_Type,
+ E_General_Access_Type,
+ E_Access_Subprogram_Type,
+ E_Access_Protected_Subprogram_Type));
+
+ Union (Numeric_Kind,
+ Children =>
+ (Integer_Kind,
+ Fixed_Point_Kind,
+ Float_Kind));
+
+ Union (Record_Kind,
+ Children =>
+ (E_Class_Wide_Type,
+ E_Class_Wide_Subtype,
+ E_Record_Type,
+ E_Record_Subtype,
+ E_Record_Type_With_Private,
+ E_Record_Subtype_With_Private));
+
+end Gen_IL.Gen.Gen_Entities;
diff --git a/gcc/ada/gen_il-gen-gen_nodes.adb b/gcc/ada/gen_il-gen-gen_nodes.adb
new file mode 100644
index 0000000..55ba71d
--- /dev/null
+++ b/gcc/ada/gen_il-gen-gen_nodes.adb
@@ -0,0 +1,1652 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- G E N _ I L . G E N . G E N _ N O D E S --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 2020-2021, Free Software Foundation, Inc. --
+-- --
+-- GNAT is 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. --
+-- --
+------------------------------------------------------------------------------
+
+procedure Gen_IL.Gen.Gen_Nodes is
+
+ procedure Ab -- Short for "Abstract"
+ (T : Abstract_Node; Parent : Abstract_Type;
+ Fields : Field_Sequence := No_Fields)
+ renames Create_Abstract_Node_Type;
+ procedure Cc -- Short for "ConCrete"
+ (T : Concrete_Node; Parent : Abstract_Type;
+ Fields : Field_Sequence := No_Fields;
+ Nmake_Assert : String := "")
+ renames Create_Concrete_Node_Type;
+
+ function Sy -- Short for "Syntactic"
+ (Field : Node_Field; Field_Type : Type_Enum;
+ Default_Value : Field_Default_Value := No_Default;
+ Pre, Pre_Get, Pre_Set : String := "") return Field_Desc
+ renames Create_Syntactic_Field;
+ function Sm -- Short for "Semantic"
+ (Field : Field_Enum; Field_Type : Type_Enum;
+ Type_Only : Type_Only_Enum := No_Type_Only;
+ Pre, Pre_Get, Pre_Set : String := "") return Field_Desc
+ renames Create_Semantic_Field;
+
+ procedure Union (T : Abstract_Node; Children : Type_Array)
+ renames Create_Node_Union_Type;
+
+begin -- Gen_IL.Gen.Gen_Nodes
+ pragma Style_Checks ("M200");
+
+ Create_Root_Node_Type (Node_Kind,
+ (Sm (Nkind, Node_Kind_Type),
+ Sm (Sloc, Source_Ptr),
+ Sm (In_List, Flag),
+ Sm (Rewrite_Ins, Flag),
+ Sm (Comes_From_Source, Flag),
+ Sm (Analyzed, Flag),
+ Sm (Error_Posted, Flag),
+ Sm (Small_Paren_Count, Small_Paren_Count_Type),
+ Sm (Check_Actuals, Flag),
+ Sm (Has_Aspects, Flag),
+ Sm (Is_Ignored_Ghost_Node, Flag),
+ Sm (Link, Union_Id)));
+
+ Cc (N_Unused_At_Start, Node_Kind);
+
+ Ab (N_Representation_Clause, Node_Kind);
+
+ Cc (N_At_Clause, N_Representation_Clause,
+ (Sy (Identifier, Node_Id, Default_Empty),
+ Sy (Expression, Node_Id, Default_Empty)));
+
+ Cc (N_Component_Clause, N_Representation_Clause,
+ (Sy (Component_Name, Node_Id),
+ Sy (Position, Node_Id),
+ Sy (First_Bit, Node_Id),
+ Sy (Last_Bit, Node_Id)));
+
+ Cc (N_Enumeration_Representation_Clause, N_Representation_Clause,
+ (Sy (Identifier, Node_Id, Default_Empty),
+ Sy (Array_Aggregate, Node_Id),
+ Sm (Next_Rep_Item, Node_Id)));
+
+ Cc (N_Mod_Clause, N_Representation_Clause,
+ (Sy (Expression, Node_Id, Default_Empty),
+ Sy (Pragmas_Before, List_Id, Default_No_List)));
+
+ Cc (N_Record_Representation_Clause, N_Representation_Clause,
+ (Sy (Identifier, Node_Id, Default_Empty),
+ Sy (Mod_Clause, Node_Id, Default_Empty),
+ Sy (Component_Clauses, List_Id),
+ Sm (Next_Rep_Item, Node_Id)));
+
+ Cc (N_Attribute_Definition_Clause, N_Representation_Clause,
+ (Sy (Name, Node_Id, Default_Empty),
+ Sy (Chars, Name_Id, Default_No_Name),
+ Sy (Expression, Node_Id, Default_Empty),
+ Sm (Address_Warning_Posted, Flag),
+ Sm (Check_Address_Alignment, Flag),
+ Sm (Entity_Or_Associated_Node, Node_Id), -- just Entity
+ Sm (From_Aspect_Specification, Flag),
+ Sm (From_At_Mod, Flag),
+ Sm (Is_Delayed_Aspect, Flag),
+ Sm (Next_Rep_Item, Node_Id)));
+
+ Cc (N_Empty, Node_Kind,
+ (Sy (Chars, Name_Id, Default_No_Name)));
+ -- The following getters and setters are called on Empty,
+ -- and are currently inherited from Node_Kind:
+ --
+ -- Set_Comes_From_Source
+ -- Set_Sloc
+ --
+ -- Comes_From_Source
+ -- Error_Posted
+ -- In_List
+ -- Link
+ -- Rewrite_Ins
+ -- Sloc
+ -- Small_Paren_Count
+
+ Cc (N_Pragma_Argument_Association, Node_Kind,
+ (Sy (Chars, Name_Id, Default_No_Name),
+ Sy (Expression, Node_Id, Default_Empty),
+ Sm (Expression_Copy, Node_Id)));
+
+ Ab (N_Has_Etype, Node_Kind,
+ (Sm (Etype, Node_Id)));
+
+ Cc (N_Error, N_Has_Etype,
+ (Sy (Chars, Name_Id, Default_No_Name)));
+
+ Ab (N_Entity, N_Has_Etype,
+ (Sm (Next_Entity, Node_Id),
+ Sm (Scope, Node_Id)));
+
+ Cc (N_Defining_Character_Literal, N_Entity,
+ (Sy (Chars, Name_Id, Default_No_Name)));
+
+ Cc (N_Defining_Identifier, N_Entity,
+ (Sy (Chars, Name_Id, Default_No_Name)));
+
+ Cc (N_Defining_Operator_Symbol, N_Entity,
+ (Sy (Chars, Name_Id, Default_No_Name)));
+
+ Ab (N_Subexpr, N_Has_Etype,
+ -- Nodes with expression fields
+ (Sm (Assignment_OK, Flag),
+ Sm (Do_Range_Check, Flag),
+ Sm (Has_Dynamic_Length_Check, Flag),
+ Sm (Is_Controlling_Actual, Flag),
+ Sm (Is_Overloaded, Flag),
+ Sm (Is_Static_Expression, Flag),
+ Sm (Must_Not_Freeze, Flag),
+ Sm (Raises_Constraint_Error, Flag)));
+
+ Ab (N_Has_Entity, N_Subexpr,
+ -- Nodes that have Entity fields
+ -- Warning: DOES NOT INCLUDE N_Freeze_Entity, N_Freeze_Generic_Entity,
+ -- N_Aspect_Specification, or N_Attribute_Definition_Clause.
+ (Sm (Entity_Or_Associated_Node, Node_Id))); -- both
+
+ Cc (N_Expanded_Name, N_Has_Entity,
+ (Sy (Chars, Name_Id, Default_No_Name),
+ Sy (Prefix, Node_Id),
+ Sy (Selector_Name, Node_Id, Default_Empty),
+ Sm (Atomic_Sync_Required, Flag),
+ Sm (Has_Private_View, Flag),
+ Sm (Is_Elaboration_Checks_OK_Node, Flag),
+ Sm (Is_Elaboration_Warnings_OK_Node, Flag),
+ Sm (Is_SPARK_Mode_On_Node, Flag),
+ Sm (Redundant_Use, Flag)));
+
+ Ab (N_Direct_Name, N_Has_Entity,
+ (Sm (Has_Private_View, Flag)));
+
+ Cc (N_Identifier, N_Direct_Name,
+ (Sy (Chars, Name_Id, Default_No_Name),
+ Sm (Atomic_Sync_Required, Flag),
+ Sm (Is_Elaboration_Checks_OK_Node, Flag),
+ Sm (Is_Elaboration_Warnings_OK_Node, Flag),
+ Sm (Is_SPARK_Mode_On_Node, Flag),
+ Sm (Original_Discriminant, Node_Id),
+ Sm (Redundant_Use, Flag)));
+
+ Cc (N_Operator_Symbol, N_Direct_Name,
+ (Sy (Chars, Name_Id, Default_No_Name),
+ Sy (Strval, String_Id)));
+
+ Cc (N_Character_Literal, N_Direct_Name,
+ (Sy (Chars, Name_Id, Default_No_Name),
+ Sy (Char_Literal_Value, Unat)));
+
+ Ab (N_Op, N_Has_Entity,
+ (Sm (Do_Overflow_Check, Flag),
+ Sm (Has_Private_View, Flag)));
+
+ Ab (N_Binary_Op, N_Op);
+
+ Cc (N_Op_Add, N_Binary_Op,
+ (Sm (Chars, Name_Id),
+ Sy (Left_Opnd, Node_Id),
+ Sy (Right_Opnd, Node_Id)));
+
+ Cc (N_Op_Concat, N_Binary_Op,
+ (Sm (Chars, Name_Id),
+ Sy (Left_Opnd, Node_Id),
+ Sy (Right_Opnd, Node_Id),
+ Sm (Is_Component_Left_Opnd, Flag),
+ Sm (Is_Component_Right_Opnd, Flag)));
+
+ Cc (N_Op_Expon, N_Binary_Op,
+ (Sm (Chars, Name_Id),
+ Sy (Left_Opnd, Node_Id),
+ Sy (Right_Opnd, Node_Id),
+ Sm (Is_Power_Of_2_For_Shift, Flag)));
+
+ Cc (N_Op_Subtract, N_Binary_Op,
+ (Sm (Chars, Name_Id),
+ Sy (Left_Opnd, Node_Id),
+ Sy (Right_Opnd, Node_Id)));
+
+ Ab (N_Multiplying_Operator, N_Binary_Op);
+
+ Cc (N_Op_Divide, N_Multiplying_Operator,
+ (Sm (Chars, Name_Id),
+ Sy (Left_Opnd, Node_Id),
+ Sy (Right_Opnd, Node_Id),
+ Sm (Do_Division_Check, Flag),
+ Sm (Rounded_Result, Flag)));
+
+ Cc (N_Op_Mod, N_Multiplying_Operator,
+ (Sm (Chars, Name_Id),
+ Sy (Left_Opnd, Node_Id),
+ Sy (Right_Opnd, Node_Id),
+ Sm (Do_Division_Check, Flag)));
+
+ Cc (N_Op_Multiply, N_Multiplying_Operator,
+ (Sm (Chars, Name_Id),
+ Sy (Left_Opnd, Node_Id),
+ Sy (Right_Opnd, Node_Id),
+ Sm (Rounded_Result, Flag)));
+
+ Cc (N_Op_Rem, N_Multiplying_Operator,
+ (Sm (Chars, Name_Id),
+ Sy (Left_Opnd, Node_Id),
+ Sy (Right_Opnd, Node_Id),
+ Sm (Do_Division_Check, Flag)));
+
+ Ab (N_Op_Boolean, N_Binary_Op);
+ -- Binary operators that take operands of a boolean type, and yield a
+ -- result of a boolean type.
+
+ Cc (N_Op_And, N_Op_Boolean,
+ (Sm (Chars, Name_Id),
+ Sy (Left_Opnd, Node_Id),
+ Sy (Right_Opnd, Node_Id),
+ Sm (Do_Length_Check, Flag)));
+
+ Ab (N_Op_Compare, N_Op_Boolean);
+
+ Cc (N_Op_Eq, N_Op_Compare,
+ (Sm (Chars, Name_Id),
+ Sy (Left_Opnd, Node_Id),
+ Sy (Right_Opnd, Node_Id)));
+
+ Cc (N_Op_Ge, N_Op_Compare,
+ (Sm (Chars, Name_Id),
+ Sy (Left_Opnd, Node_Id),
+ Sy (Right_Opnd, Node_Id)));
+
+ Cc (N_Op_Gt, N_Op_Compare,
+ (Sm (Chars, Name_Id),
+ Sy (Left_Opnd, Node_Id),
+ Sy (Right_Opnd, Node_Id)));
+
+ Cc (N_Op_Le, N_Op_Compare,
+ (Sm (Chars, Name_Id),
+ Sy (Left_Opnd, Node_Id),
+ Sy (Right_Opnd, Node_Id)));
+
+ Cc (N_Op_Lt, N_Op_Compare,
+ (Sm (Chars, Name_Id),
+ Sy (Left_Opnd, Node_Id),
+ Sy (Right_Opnd, Node_Id)));
+
+ Cc (N_Op_Ne, N_Op_Compare,
+ (Sm (Chars, Name_Id),
+ Sy (Left_Opnd, Node_Id),
+ Sy (Right_Opnd, Node_Id)));
+
+ Cc (N_Op_Or, N_Op_Boolean,
+ (Sm (Chars, Name_Id),
+ Sy (Left_Opnd, Node_Id),
+ Sy (Right_Opnd, Node_Id),
+ Sm (Do_Length_Check, Flag)));
+
+ Cc (N_Op_Xor, N_Op_Boolean,
+ (Sm (Chars, Name_Id),
+ Sy (Left_Opnd, Node_Id),
+ Sy (Right_Opnd, Node_Id),
+ Sm (Do_Length_Check, Flag)));
+
+ Ab (N_Op_Shift, N_Binary_Op,
+ (Sm (Shift_Count_OK, Flag)));
+
+ Cc (N_Op_Rotate_Left, N_Op_Shift,
+ (Sm (Chars, Name_Id),
+ Sy (Left_Opnd, Node_Id),
+ Sy (Right_Opnd, Node_Id)));
+
+ Cc (N_Op_Rotate_Right, N_Op_Shift,
+ (Sm (Chars, Name_Id),
+ Sy (Left_Opnd, Node_Id),
+ Sy (Right_Opnd, Node_Id)));
+
+ Cc (N_Op_Shift_Left, N_Op_Shift,
+ (Sm (Chars, Name_Id),
+ Sy (Left_Opnd, Node_Id),
+ Sy (Right_Opnd, Node_Id)));
+
+ Cc (N_Op_Shift_Right, N_Op_Shift,
+ (Sm (Chars, Name_Id),
+ Sy (Left_Opnd, Node_Id),
+ Sy (Right_Opnd, Node_Id)));
+
+ Cc (N_Op_Shift_Right_Arithmetic, N_Op_Shift,
+ (Sm (Chars, Name_Id),
+ Sy (Left_Opnd, Node_Id),
+ Sy (Right_Opnd, Node_Id)));
+
+ Ab (N_Unary_Op, N_Op);
+
+ Cc (N_Op_Abs, N_Unary_Op,
+ (Sm (Chars, Name_Id),
+ Sy (Right_Opnd, Node_Id)));
+
+ Cc (N_Op_Minus, N_Unary_Op,
+ (Sm (Chars, Name_Id),
+ Sy (Right_Opnd, Node_Id)));
+
+ Cc (N_Op_Not, N_Unary_Op,
+ (Sm (Chars, Name_Id),
+ Sy (Right_Opnd, Node_Id)));
+
+ Cc (N_Op_Plus, N_Unary_Op,
+ (Sm (Chars, Name_Id),
+ Sy (Right_Opnd, Node_Id)));
+
+ Cc (N_Attribute_Reference, N_Has_Entity,
+ (Sy (Prefix, Node_Id),
+ Sy (Attribute_Name, Name_Id),
+ Sy (Expressions, List_Id, Default_No_List),
+ Sm (Do_Overflow_Check, Flag),
+ Sm (Header_Size_Added, Flag),
+ Sm (Is_Elaboration_Checks_OK_Node, Flag),
+ Sm (Is_Elaboration_Warnings_OK_Node, Flag),
+ Sm (Is_SPARK_Mode_On_Node, Flag),
+ Sm (Must_Be_Byte_Aligned, Flag),
+ Sm (Redundant_Use, Flag)));
+
+ Ab (N_Membership_Test, N_Subexpr);
+
+ Cc (N_In, N_Membership_Test,
+ (Sy (Left_Opnd, Node_Id),
+ Sy (Right_Opnd, Node_Id),
+ Sy (Alternatives, List_Id, Default_No_List),
+ Sy (No_Minimize_Eliminate, Flag)));
+
+ Cc (N_Not_In, N_Membership_Test,
+ (Sy (Left_Opnd, Node_Id),
+ Sy (Right_Opnd, Node_Id),
+ Sy (Alternatives, List_Id, Default_No_List),
+ Sy (No_Minimize_Eliminate, Flag)));
+
+ Ab (N_Short_Circuit, N_Subexpr);
+
+ Cc (N_And_Then, N_Short_Circuit,
+ (Sy (Left_Opnd, Node_Id),
+ Sy (Right_Opnd, Node_Id),
+ Sm (Actions, List_Id)));
+
+ Cc (N_Or_Else, N_Short_Circuit,
+ (Sy (Left_Opnd, Node_Id),
+ Sy (Right_Opnd, Node_Id),
+ Sm (Actions, List_Id)));
+
+ Ab (N_Subprogram_Call, N_Subexpr,
+ (Sm (Controlling_Argument, Node_Id),
+ Sm (First_Named_Actual, Node_Id),
+ Sm (Is_Elaboration_Checks_OK_Node, Flag),
+ Sm (Is_Elaboration_Warnings_OK_Node, Flag),
+ Sm (Is_Known_Guaranteed_ABE, Flag),
+ Sm (Is_SPARK_Mode_On_Node, Flag),
+ Sm (No_Elaboration_Check, Flag)));
+
+ Cc (N_Function_Call, N_Subprogram_Call,
+ (Sy (Name, Node_Id, Default_Empty),
+ Sy (Parameter_Associations, List_Id, Default_No_List),
+ Sm (Is_Expanded_Build_In_Place_Call, Flag),
+ Sm (No_Side_Effect_Removal, Flag)));
+
+ Cc (N_Procedure_Call_Statement, N_Subprogram_Call,
+ (Sy (Name, Node_Id, Default_Empty),
+ Sy (Parameter_Associations, List_Id, Default_No_List)));
+
+ Ab (N_Raise_xxx_Error, N_Subexpr);
+
+ Cc (N_Raise_Constraint_Error, N_Raise_xxx_Error,
+ (Sy (Condition, Node_Id, Default_Empty),
+ Sy (Reason, Unat)));
+
+ Cc (N_Raise_Program_Error, N_Raise_xxx_Error,
+ (Sy (Condition, Node_Id, Default_Empty),
+ Sy (Reason, Unat)));
+
+ Cc (N_Raise_Storage_Error, N_Raise_xxx_Error,
+ (Sy (Condition, Node_Id, Default_Empty),
+ Sy (Reason, Unat)));
+
+ Ab (N_Numeric_Or_String_Literal, N_Subexpr);
+
+ Cc (N_Integer_Literal, N_Numeric_Or_String_Literal,
+ (Sy (Intval, Valid_Uint),
+ Sm (Original_Entity, Node_Id),
+ Sm (Print_In_Hex, Flag)));
+
+ Cc (N_Real_Literal, N_Numeric_Or_String_Literal,
+ (Sy (Realval, Ureal),
+ Sm (Corresponding_Integer_Value, Valid_Uint),
+ Sm (Is_Machine_Number, Flag),
+ Sm (Original_Entity, Node_Id)));
+
+ Cc (N_String_Literal, N_Numeric_Or_String_Literal,
+ (Sy (Strval, String_Id),
+ Sy (Is_Folded_In_Parser, Flag),
+ Sm (Has_Wide_Character, Flag),
+ Sm (Has_Wide_Wide_Character, Flag)));
+
+ Cc (N_Explicit_Dereference, N_Subexpr,
+ (Sy (Prefix, Node_Id),
+ Sm (Actual_Designated_Subtype, Node_Id),
+ Sm (Atomic_Sync_Required, Flag),
+ Sm (Has_Dereference_Action, Flag)));
+
+ Cc (N_Expression_With_Actions, N_Subexpr,
+ (Sy (Actions, List_Id, Default_No_List),
+ Sy (Expression, Node_Id, Default_Empty)));
+
+ Cc (N_If_Expression, N_Subexpr,
+ (Sy (Expressions, List_Id, Default_No_List),
+ Sy (Is_Elsif, Flag),
+ Sm (Do_Overflow_Check, Flag),
+ Sm (Else_Actions, List_Id),
+ Sm (Then_Actions, List_Id)));
+
+ Cc (N_Indexed_Component, N_Subexpr,
+ (Sy (Prefix, Node_Id),
+ Sy (Expressions, List_Id, Default_No_List),
+ Sm (Atomic_Sync_Required, Flag),
+ Sm (Generalized_Indexing, Node_Id)));
+
+ Cc (N_Null, N_Subexpr);
+
+ Cc (N_Qualified_Expression, N_Subexpr,
+ (Sy (Subtype_Mark, Node_Id, Default_Empty),
+ Sy (Expression, Node_Id, Default_Empty),
+ Sm (Is_Qualified_Universal_Literal, Flag)));
+
+ Cc (N_Quantified_Expression, N_Subexpr,
+ (Sy (Iterator_Specification, Node_Id, Default_Empty),
+ Sy (Loop_Parameter_Specification, Node_Id, Default_Empty),
+ Sy (Condition, Node_Id, Default_Empty),
+ Sy (All_Present, Flag)));
+
+ Cc (N_Aggregate, N_Subexpr,
+ (Sy (Expressions, List_Id, Default_No_List),
+ Sy (Component_Associations, List_Id, Default_No_List),
+ Sy (Null_Record_Present, Flag),
+ Sy (Is_Homogeneous_Aggregate, Flag),
+ Sm (Aggregate_Bounds, Node_Id),
+ Sm (Entity_Or_Associated_Node, Node_Id), -- just Associated_Node
+ Sm (Compile_Time_Known_Aggregate, Flag),
+ Sm (Expansion_Delayed, Flag),
+ Sm (Has_Self_Reference, Flag)));
+
+ Cc (N_Allocator, N_Subexpr,
+ (Sy (Expression, Node_Id, Default_Empty),
+ Sy (Subpool_Handle_Name, Node_Id, Default_Empty),
+ Sy (Null_Exclusion_Present, Flag, Default_False),
+ Sm (Alloc_For_BIP_Return, Flag),
+ Sm (Do_Storage_Check, Flag),
+ Sm (Is_Dynamic_Coextension, Flag),
+ Sm (Is_Static_Coextension, Flag),
+ Sm (No_Initialization, Flag),
+ Sm (Procedure_To_Call, Node_Id),
+ Sm (Storage_Pool, Node_Id)));
+
+ Cc (N_Case_Expression, N_Subexpr,
+ (Sy (Expression, Node_Id, Default_Empty),
+ Sy (Alternatives, List_Id, Default_No_List),
+ Sm (Do_Overflow_Check, Flag)));
+
+ Cc (N_Delta_Aggregate, N_Subexpr,
+ (Sy (Expression, Node_Id, Default_Empty),
+ Sy (Component_Associations, List_Id, Default_No_List)));
+
+ Cc (N_Extension_Aggregate, N_Subexpr,
+ (Sy (Ancestor_Part, Node_Id),
+ Sy (Expressions, List_Id, Default_No_List),
+ Sy (Component_Associations, List_Id, Default_No_List),
+ Sy (Null_Record_Present, Flag),
+ Sm (Entity_Or_Associated_Node, Node_Id), -- just Associated_Node
+ Sm (Expansion_Delayed, Flag),
+ Sm (Has_Self_Reference, Flag)));
+
+ Cc (N_Raise_Expression, N_Subexpr,
+ (Sy (Name, Node_Id, Default_Empty),
+ Sy (Expression, Node_Id, Default_Empty),
+ Sm (Convert_To_Return_False, Flag)));
+
+ Cc (N_Range, N_Subexpr,
+ (Sy (Low_Bound, Node_Id),
+ Sy (High_Bound, Node_Id),
+ Sy (Includes_Infinities, Flag)));
+
+ Cc (N_Reference, N_Subexpr,
+ (Sy (Prefix, Node_Id)));
+
+ Cc (N_Selected_Component, N_Subexpr,
+ (Sy (Prefix, Node_Id),
+ Sy (Selector_Name, Node_Id, Default_Empty),
+ Sm (Atomic_Sync_Required, Flag),
+ Sm (Entity_Or_Associated_Node, Node_Id), -- just Associated_Node
+ Sm (Do_Discriminant_Check, Flag),
+ Sm (Is_In_Discriminant_Check, Flag),
+ Sm (Is_Prefixed_Call, Flag)));
+
+ Cc (N_Slice, N_Subexpr,
+ (Sy (Prefix, Node_Id),
+ Sy (Discrete_Range, Node_Id)));
+
+ Cc (N_Target_Name, N_Subexpr);
+
+ Cc (N_Type_Conversion, N_Subexpr,
+ (Sy (Subtype_Mark, Node_Id, Default_Empty),
+ Sy (Expression, Node_Id, Default_Empty),
+ Sm (Conversion_OK, Flag),
+ Sm (Do_Discriminant_Check, Flag),
+ Sm (Do_Length_Check, Flag),
+ Sm (Do_Overflow_Check, Flag),
+ Sm (Float_Truncate, Flag),
+ Sm (Rounded_Result, Flag)));
+
+ Cc (N_Unchecked_Expression, N_Subexpr,
+ (Sy (Expression, Node_Id, Default_Empty)));
+
+ Cc (N_Unchecked_Type_Conversion, N_Subexpr,
+ (Sy (Subtype_Mark, Node_Id, Default_Empty),
+ Sy (Expression, Node_Id, Default_Empty),
+ Sm (Kill_Range_Check, Flag),
+ Sm (No_Truncation, Flag)),
+ Nmake_Assert => "True or else Nkind (Expression) /= N_Unchecked_Type_Conversion");
+-- Nmake_Assert => "Nkind (Expression) /= N_Unchecked_Type_Conversion");
+ -- Assert that we don't have unchecked conversions of unchecked
+ -- conversions; if Expression might be an unchecked conversion,
+ -- then Tbuild.Unchecked_Convert_To should be used.
+
+ Cc (N_Subtype_Indication, N_Has_Etype,
+ (Sy (Subtype_Mark, Node_Id, Default_Empty),
+ Sy (Constraint, Node_Id),
+ Sm (Must_Not_Freeze, Flag)));
+
+ Ab (N_Declaration, Node_Kind);
+ -- Note: this includes all constructs normally thought of as declarations
+ -- except those that are separately grouped in N_Later_Decl_Item.
+
+ Cc (N_Component_Declaration, N_Declaration,
+ (Sy (Defining_Identifier, Node_Id),
+ Sy (Component_Definition, Node_Id),
+ Sy (Expression, Node_Id, Default_Empty),
+ Sm (More_Ids, Flag),
+ Sm (Prev_Ids, Flag)));
+
+ Cc (N_Entry_Declaration, N_Declaration,
+ (Sy (Defining_Identifier, Node_Id),
+ Sy (Discrete_Subtype_Definition, Node_Id, Default_Empty),
+ Sy (Parameter_Specifications, List_Id, Default_No_List),
+ Sy (Must_Override, Flag),
+ Sy (Must_Not_Override, Flag),
+ Sm (Corresponding_Body, Node_Id)));
+
+ Cc (N_Expression_Function, N_Declaration,
+ (Sy (Specification, Node_Id),
+ Sy (Expression, Node_Id, Default_Empty),
+ Sm (Corresponding_Spec, Node_Id)));
+
+ Cc (N_Formal_Object_Declaration, N_Declaration,
+ (Sy (Defining_Identifier, Node_Id),
+ Sy (In_Present, Flag),
+ Sy (Out_Present, Flag),
+ Sy (Null_Exclusion_Present, Flag, Default_False),
+ Sy (Subtype_Mark, Node_Id, Default_Empty),
+ Sy (Access_Definition, Node_Id, Default_Empty),
+ Sy (Default_Expression, Node_Id, Default_Empty),
+ Sm (More_Ids, Flag),
+ Sm (Prev_Ids, Flag)));
+
+ Cc (N_Formal_Type_Declaration, N_Declaration,
+ (Sy (Defining_Identifier, Node_Id),
+ Sy (Formal_Type_Definition, Node_Id),
+ Sy (Discriminant_Specifications, List_Id, Default_No_List),
+ Sy (Unknown_Discriminants_Present, Flag),
+ Sy (Default_Subtype_Mark, Node_Id)));
+
+ Cc (N_Full_Type_Declaration, N_Declaration,
+ (Sy (Defining_Identifier, Node_Id),
+ Sy (Discriminant_Specifications, List_Id, Default_No_List),
+ Sy (Type_Definition, Node_Id),
+ Sm (Discr_Check_Funcs_Built, Flag),
+ Sm (Incomplete_View, Node_Id)));
+
+ Cc (N_Incomplete_Type_Declaration, N_Declaration,
+ (Sy (Defining_Identifier, Node_Id),
+ Sy (Discriminant_Specifications, List_Id, Default_No_List),
+ Sy (Unknown_Discriminants_Present, Flag),
+ Sy (Tagged_Present, Flag),
+ Sm (Premature_Use, Node_Id)));
+
+ Cc (N_Iterator_Specification, N_Declaration,
+ (Sy (Defining_Identifier, Node_Id),
+ Sy (Name, Node_Id, Default_Empty),
+ Sy (Reverse_Present, Flag),
+ Sy (Of_Present, Flag),
+ Sy (Iterator_Filter, Node_Id, Default_Empty),
+ Sy (Subtype_Indication, Node_Id, Default_Empty)));
+
+ Cc (N_Loop_Parameter_Specification, N_Declaration,
+ (Sy (Defining_Identifier, Node_Id),
+ Sy (Reverse_Present, Flag),
+ Sy (Iterator_Filter, Node_Id, Default_Empty),
+ Sy (Discrete_Subtype_Definition, Node_Id, Default_Empty)));
+
+ Cc (N_Object_Declaration, N_Declaration,
+ (Sy (Defining_Identifier, Node_Id),
+ Sy (Aliased_Present, Flag),
+ Sy (Constant_Present, Flag),
+ Sy (Null_Exclusion_Present, Flag, Default_False),
+ Sy (Object_Definition, Node_Id),
+ Sy (Expression, Node_Id, Default_Empty),
+ Sy (Has_Init_Expression, Flag),
+ Sm (Assignment_OK, Flag),
+ Sm (Corresponding_Generic_Association, Node_Id),
+ Sm (Exception_Junk, Flag),
+ Sm (Handler_List_Entry, Node_Id),
+ Sm (Is_Subprogram_Descriptor, Flag),
+ Sm (More_Ids, Flag),
+ Sm (No_Initialization, Flag),
+ Sm (Prev_Ids, Flag),
+ Sm (Suppress_Assignment_Checks, Flag)));
+
+ Cc (N_Protected_Type_Declaration, N_Declaration,
+ (Sy (Defining_Identifier, Node_Id),
+ Sy (Discriminant_Specifications, List_Id, Default_No_List),
+ Sy (Interface_List, List_Id, Default_No_List),
+ Sy (Protected_Definition, Node_Id),
+ Sm (Corresponding_Body, Node_Id)));
+
+ Cc (N_Private_Extension_Declaration, N_Declaration,
+ (Sy (Defining_Identifier, Node_Id),
+ Sy (Discriminant_Specifications, List_Id, Default_No_List),
+ Sy (Unknown_Discriminants_Present, Flag),
+ Sy (Abstract_Present, Flag),
+ Sy (Limited_Present, Flag),
+ Sy (Synchronized_Present, Flag),
+ Sy (Subtype_Indication, Node_Id, Default_Empty),
+ Sy (Interface_List, List_Id, Default_No_List),
+ Sm (Uninitialized_Variable, Node_Id)));
+
+ Cc (N_Private_Type_Declaration, N_Declaration,
+ (Sy (Defining_Identifier, Node_Id),
+ Sy (Discriminant_Specifications, List_Id, Default_No_List),
+ Sy (Unknown_Discriminants_Present, Flag),
+ Sy (Abstract_Present, Flag),
+ Sy (Tagged_Present, Flag),
+ Sy (Limited_Present, Flag)));
+
+ Cc (N_Subtype_Declaration, N_Declaration,
+ (Sy (Defining_Identifier, Node_Id),
+ Sy (Null_Exclusion_Present, Flag, Default_False),
+ Sy (Subtype_Indication, Node_Id, Default_Empty),
+ Sm (Exception_Junk, Flag),
+ Sm (Generic_Parent_Type, Node_Id)));
+
+ Ab (N_Subprogram_Specification, N_Declaration,
+ (Sm (Generic_Parent, Node_Id)));
+
+ Cc (N_Function_Specification, N_Subprogram_Specification,
+ (Sy (Defining_Unit_Name, Node_Id),
+ Sy (Parameter_Specifications, List_Id, Default_No_List),
+ Sy (Null_Exclusion_Present, Flag, Default_False),
+ Sy (Result_Definition, Node_Id),
+ Sy (Must_Override, Flag),
+ Sy (Must_Not_Override, Flag)));
+
+ Cc (N_Procedure_Specification, N_Subprogram_Specification,
+ (Sy (Defining_Unit_Name, Node_Id),
+ Sy (Parameter_Specifications, List_Id, Default_No_List),
+ Sy (Null_Present, Flag),
+ Sy (Must_Override, Flag),
+ Sy (Must_Not_Override, Flag),
+ Sm (Null_Statement, Node_Id)));
+
+ Ab (N_Access_To_Subprogram_Definition, Node_Kind);
+
+ Cc (N_Access_Function_Definition, N_Access_To_Subprogram_Definition,
+ (Sy (Null_Exclusion_Present, Flag, Default_False),
+ Sy (Null_Exclusion_In_Return_Present, Flag),
+ Sy (Protected_Present, Flag),
+ Sy (Parameter_Specifications, List_Id, Default_No_List),
+ Sy (Result_Definition, Node_Id)));
+
+ Cc (N_Access_Procedure_Definition, N_Access_To_Subprogram_Definition,
+ (Sy (Null_Exclusion_Present, Flag, Default_False),
+ Sy (Protected_Present, Flag),
+ Sy (Parameter_Specifications, List_Id, Default_No_List)));
+
+ Ab (N_Later_Decl_Item, Node_Kind);
+ -- Note: this is Ada 83 relevant only (see Ada 83 RM 3.9 (2)) and includes
+ -- only those items which can appear as later declarative items. This also
+ -- includes N_Implicit_Label_Declaration which is not specifically in the
+ -- grammar but may appear as a valid later declarative items. It does NOT
+ -- include N_Pragma which can also appear among later declarative items.
+ -- It does however include N_Protected_Body, which is a bit peculiar, but
+ -- harmless since this cannot appear in Ada 83 mode anyway.
+
+ Cc (N_Task_Type_Declaration, N_Later_Decl_Item,
+ (Sy (Defining_Identifier, Node_Id),
+ Sy (Discriminant_Specifications, List_Id, Default_No_List),
+ Sy (Interface_List, List_Id, Default_No_List),
+ Sy (Task_Definition, Node_Id, Default_Empty),
+ Sm (Corresponding_Body, Node_Id)));
+
+ Ab (N_Body_Stub, N_Later_Decl_Item,
+ (Sm (Corresponding_Body, Node_Id),
+ Sm (Corresponding_Spec_Of_Stub, Node_Id),
+ Sm (Library_Unit, Node_Id)));
+
+ Cc (N_Package_Body_Stub, N_Body_Stub,
+ (Sy (Defining_Identifier, Node_Id)));
+
+ Cc (N_Protected_Body_Stub, N_Body_Stub,
+ (Sy (Defining_Identifier, Node_Id)));
+
+ Cc (N_Subprogram_Body_Stub, N_Body_Stub,
+ (Sy (Specification, Node_Id)));
+
+ Cc (N_Task_Body_Stub, N_Body_Stub,
+ (Sy (Defining_Identifier, Node_Id)));
+
+ Ab (N_Generic_Instantiation, N_Later_Decl_Item,
+ (Sm (Instance_Spec, Node_Id),
+ Sm (Is_Declaration_Level_Node, Flag),
+ Sm (Is_Elaboration_Checks_OK_Node, Flag),
+ Sm (Is_Elaboration_Warnings_OK_Node, Flag),
+ Sm (Is_Known_Guaranteed_ABE, Flag),
+ Sm (Is_SPARK_Mode_On_Node, Flag),
+ Sm (Parent_Spec, Node_Id)));
+
+ Ab (N_Subprogram_Instantiation, N_Generic_Instantiation);
+
+ Cc (N_Function_Instantiation, N_Subprogram_Instantiation,
+ (Sy (Defining_Unit_Name, Node_Id),
+ Sy (Name, Node_Id, Default_Empty),
+ Sy (Generic_Associations, List_Id, Default_No_List),
+ Sy (Must_Override, Flag),
+ Sy (Must_Not_Override, Flag)));
+
+ Cc (N_Procedure_Instantiation, N_Subprogram_Instantiation,
+ (Sy (Defining_Unit_Name, Node_Id),
+ Sy (Name, Node_Id, Default_Empty),
+ Sy (Generic_Associations, List_Id, Default_No_List),
+ Sy (Must_Override, Flag),
+ Sy (Must_Not_Override, Flag)));
+
+ Cc (N_Package_Instantiation, N_Generic_Instantiation,
+ (Sy (Defining_Unit_Name, Node_Id),
+ Sy (Name, Node_Id, Default_Empty),
+ Sy (Generic_Associations, List_Id, Default_No_List)));
+
+ Ab (N_Proper_Body, N_Later_Decl_Item,
+ (Sm (Corresponding_Spec, Node_Id),
+ Sm (Was_Originally_Stub, Flag)));
+
+ Ab (N_Unit_Body, N_Proper_Body);
+
+ Cc (N_Package_Body, N_Unit_Body,
+ (Sy (Defining_Unit_Name, Node_Id),
+ Sy (Declarations, List_Id, Default_No_List),
+ Sy (Handled_Statement_Sequence, Node_Id, Default_Empty)));
+
+ Cc (N_Subprogram_Body, N_Unit_Body,
+ (Sy (Specification, Node_Id),
+ Sy (Declarations, List_Id, Default_No_List),
+ Sy (Handled_Statement_Sequence, Node_Id, Default_Empty),
+ Sy (Bad_Is_Detected, Flag),
+ Sm (Activation_Chain_Entity, Node_Id),
+ Sm (Acts_As_Spec, Flag),
+ Sm (Corresponding_Entry_Body, Node_Id),
+ Sm (Do_Storage_Check, Flag),
+ Sm (Has_Relative_Deadline_Pragma, Flag),
+ Sm (Is_Entry_Barrier_Function, Flag),
+ Sm (Is_Protected_Subprogram_Body, Flag),
+ Sm (Is_Task_Body_Procedure, Flag),
+ Sm (Is_Task_Master, Flag),
+ Sm (Was_Attribute_Reference, Flag),
+ Sm (Was_Expression_Function, Flag)));
+
+ Cc (N_Protected_Body, N_Proper_Body,
+ (Sy (Defining_Identifier, Node_Id),
+ Sy (Declarations, List_Id, Default_No_List),
+ Sy (End_Label, Node_Id, Default_Empty)));
+
+ Cc (N_Task_Body, N_Proper_Body,
+ (Sy (Defining_Identifier, Node_Id),
+ Sy (Declarations, List_Id, Default_No_List),
+ Sy (Handled_Statement_Sequence, Node_Id, Default_Empty),
+ Sm (Activation_Chain_Entity, Node_Id),
+ Sm (Is_Task_Master, Flag)));
+
+ Cc (N_Implicit_Label_Declaration, N_Later_Decl_Item,
+ (Sy (Defining_Identifier, Node_Id),
+ Sm (Label_Construct, Node_Id)));
+
+ Cc (N_Package_Declaration, N_Later_Decl_Item,
+ (Sy (Specification, Node_Id),
+ Sm (Activation_Chain_Entity, Node_Id),
+ Sm (Corresponding_Body, Node_Id),
+ Sm (Parent_Spec, Node_Id)));
+
+ Cc (N_Single_Task_Declaration, N_Later_Decl_Item,
+ (Sy (Defining_Identifier, Node_Id),
+ Sy (Interface_List, List_Id, Default_No_List),
+ Sy (Task_Definition, Node_Id, Default_Empty)));
+
+ Cc (N_Subprogram_Declaration, N_Later_Decl_Item,
+ (Sy (Specification, Node_Id),
+ Sm (Body_To_Inline, Node_Id),
+ Sm (Corresponding_Body, Node_Id),
+ Sm (Is_Entry_Barrier_Function, Flag),
+ Sm (Is_Task_Body_Procedure, Flag),
+ Sm (Parent_Spec, Node_Id)));
+
+ Cc (N_Use_Package_Clause, N_Later_Decl_Item,
+ (Sy (Name, Node_Id, Default_Empty),
+ Sy (Is_Effective_Use_Clause, Flag),
+ Sm (Entity_Or_Associated_Node, Node_Id), -- just Associated_Node
+ Sm (Hidden_By_Use_Clause, Elist_Id),
+ Sm (More_Ids, Flag),
+ Sm (Next_Use_Clause, Node_Id),
+ Sm (Prev_Ids, Flag),
+ Sm (Prev_Use_Clause, Node_Id)));
+
+ Ab (N_Generic_Declaration, N_Later_Decl_Item,
+ (Sm (Corresponding_Body, Node_Id),
+ Sm (Parent_Spec, Node_Id)));
+
+ Cc (N_Generic_Package_Declaration, N_Generic_Declaration,
+ (Sy (Specification, Node_Id),
+ Sy (Generic_Formal_Declarations, List_Id),
+ Sm (Activation_Chain_Entity, Node_Id)));
+
+ Cc (N_Generic_Subprogram_Declaration, N_Generic_Declaration,
+ (Sy (Specification, Node_Id),
+ Sy (Generic_Formal_Declarations, List_Id)));
+
+ Ab (N_Array_Type_Definition, Node_Kind);
+
+ Cc (N_Constrained_Array_Definition, N_Array_Type_Definition,
+ (Sy (Discrete_Subtype_Definitions, List_Id),
+ Sy (Component_Definition, Node_Id)));
+
+ Cc (N_Unconstrained_Array_Definition, N_Array_Type_Definition,
+ (Sy (Subtype_Marks, List_Id),
+ Sy (Component_Definition, Node_Id)));
+
+ Ab (N_Renaming_Declaration, Node_Kind);
+
+ Cc (N_Exception_Renaming_Declaration, N_Renaming_Declaration,
+ (Sy (Defining_Identifier, Node_Id),
+ Sy (Name, Node_Id, Default_Empty)));
+
+ Cc (N_Object_Renaming_Declaration, N_Renaming_Declaration,
+ (Sy (Defining_Identifier, Node_Id),
+ Sy (Null_Exclusion_Present, Flag, Default_False),
+ Sy (Subtype_Mark, Node_Id, Default_Empty),
+ Sy (Access_Definition, Node_Id, Default_Empty),
+ Sy (Name, Node_Id, Default_Empty),
+ Sm (Corresponding_Generic_Association, Node_Id)));
+
+ Cc (N_Package_Renaming_Declaration, N_Renaming_Declaration,
+ (Sy (Defining_Unit_Name, Node_Id),
+ Sy (Name, Node_Id, Default_Empty),
+ Sm (Parent_Spec, Node_Id)));
+
+ Cc (N_Subprogram_Renaming_Declaration, N_Renaming_Declaration,
+ (Sy (Specification, Node_Id),
+ Sy (Name, Node_Id, Default_Empty),
+ Sm (Corresponding_Formal_Spec, Node_Id),
+ Sm (Corresponding_Spec, Node_Id),
+ Sm (From_Default, Flag),
+ Sm (Parent_Spec, Node_Id)));
+
+ Ab (N_Generic_Renaming_Declaration, N_Renaming_Declaration,
+ (Sm (Parent_Spec, Node_Id)));
+
+ Cc (N_Generic_Function_Renaming_Declaration, N_Generic_Renaming_Declaration,
+ (Sy (Defining_Unit_Name, Node_Id),
+ Sy (Name, Node_Id, Default_Empty)));
+
+ Cc (N_Generic_Package_Renaming_Declaration, N_Generic_Renaming_Declaration,
+ (Sy (Defining_Unit_Name, Node_Id),
+ Sy (Name, Node_Id, Default_Empty)));
+
+ Cc (N_Generic_Procedure_Renaming_Declaration, N_Generic_Renaming_Declaration,
+ (Sy (Defining_Unit_Name, Node_Id),
+ Sy (Name, Node_Id, Default_Empty)));
+
+ Ab (N_Statement_Other_Than_Procedure_Call, Node_Kind);
+ -- Note that this includes all statement types except for the cases of the
+ -- N_Procedure_Call_Statement which is considered to be a subexpression
+ -- (since overloading is possible, so it needs to go through the normal
+ -- overloading resolution for expressions).
+
+ Cc (N_Abort_Statement, N_Statement_Other_Than_Procedure_Call,
+ (Sy (Names, List_Id)));
+
+ Cc (N_Accept_Statement, N_Statement_Other_Than_Procedure_Call,
+ (Sy (Entry_Direct_Name, Node_Id),
+ Sy (Entry_Index, Node_Id, Default_Empty),
+ Sy (Parameter_Specifications, List_Id, Default_No_List),
+ Sy (Handled_Statement_Sequence, Node_Id, Default_Empty),
+ Sy (Declarations, List_Id, Default_No_List)));
+
+ Cc (N_Assignment_Statement, N_Statement_Other_Than_Procedure_Call,
+ (Sy (Name, Node_Id, Default_Empty),
+ Sy (Expression, Node_Id, Default_Empty),
+ Sm (Backwards_OK, Flag),
+ Sm (Componentwise_Assignment, Flag),
+ Sm (Do_Discriminant_Check, Flag),
+ Sm (Do_Length_Check, Flag),
+ Sm (Forwards_OK, Flag),
+ Sm (Has_Target_Names, Flag),
+ Sm (Is_Elaboration_Checks_OK_Node, Flag),
+ Sm (Is_Elaboration_Code, Flag),
+ Sm (Is_SPARK_Mode_On_Node, Flag),
+ Sm (No_Ctrl_Actions, Flag),
+ Sm (Suppress_Assignment_Checks, Flag)));
+
+ Cc (N_Asynchronous_Select, N_Statement_Other_Than_Procedure_Call,
+ (Sy (Triggering_Alternative, Node_Id),
+ Sy (Abortable_Part, Node_Id)));
+
+ Cc (N_Block_Statement, N_Statement_Other_Than_Procedure_Call,
+ (Sy (Identifier, Node_Id, Default_Empty),
+ Sy (Declarations, List_Id, Default_No_List),
+ Sy (Handled_Statement_Sequence, Node_Id, Default_Empty),
+ Sy (Has_Created_Identifier, Flag),
+ Sy (Is_Asynchronous_Call_Block, Flag),
+ Sy (Is_Task_Allocation_Block, Flag),
+ Sm (Activation_Chain_Entity, Node_Id),
+ Sm (Cleanup_Actions, List_Id),
+ Sm (Exception_Junk, Flag),
+ Sm (Is_Abort_Block, Flag),
+ Sm (Is_Finalization_Wrapper, Flag),
+ Sm (Is_Initialization_Block, Flag),
+ Sm (Is_Task_Master, Flag)));
+
+ Cc (N_Case_Statement, N_Statement_Other_Than_Procedure_Call,
+ (Sy (Expression, Node_Id, Default_Empty),
+ Sy (Alternatives, List_Id, Default_No_List),
+ Sy (End_Span, Uint, Default_Uint_0),
+ Sm (From_Conditional_Expression, Flag)));
+
+ Cc (N_Code_Statement, N_Statement_Other_Than_Procedure_Call,
+ (Sy (Expression, Node_Id, Default_Empty)));
+
+ Cc (N_Compound_Statement, N_Statement_Other_Than_Procedure_Call,
+ (Sy (Actions, List_Id, Default_No_List)));
+
+ Cc (N_Conditional_Entry_Call, N_Statement_Other_Than_Procedure_Call,
+ (Sy (Entry_Call_Alternative, Node_Id),
+ Sy (Else_Statements, List_Id, Default_No_List)));
+
+ Ab (N_Delay_Statement, N_Statement_Other_Than_Procedure_Call);
+
+ Cc (N_Delay_Relative_Statement, N_Delay_Statement,
+ (Sy (Expression, Node_Id, Default_Empty)));
+
+ Cc (N_Delay_Until_Statement, N_Delay_Statement,
+ (Sy (Expression, Node_Id, Default_Empty)));
+
+ Cc (N_Entry_Call_Statement, N_Statement_Other_Than_Procedure_Call,
+ (Sy (Name, Node_Id, Default_Empty),
+ Sy (Parameter_Associations, List_Id, Default_No_List),
+ Sm (First_Named_Actual, Node_Id),
+ Sm (Is_Elaboration_Checks_OK_Node, Flag),
+ Sm (Is_Elaboration_Warnings_OK_Node, Flag),
+ Sm (Is_SPARK_Mode_On_Node, Flag)));
+
+ Cc (N_Free_Statement, N_Statement_Other_Than_Procedure_Call,
+ (Sy (Expression, Node_Id, Default_Empty),
+ Sm (Actual_Designated_Subtype, Node_Id),
+ Sm (Procedure_To_Call, Node_Id),
+ Sm (Storage_Pool, Node_Id)));
+
+ Cc (N_Goto_Statement, N_Statement_Other_Than_Procedure_Call,
+ (Sy (Name, Node_Id, Default_Empty),
+ Sm (Exception_Junk, Flag)));
+
+ Cc (N_Goto_When_Statement, N_Statement_Other_Than_Procedure_Call,
+ (Sy (Name, Node_Id, Default_Empty),
+ Sy (Condition, Node_Id, Default_Empty)));
+
+ Cc (N_Loop_Statement, N_Statement_Other_Than_Procedure_Call,
+ (Sy (Identifier, Node_Id, Default_Empty),
+ Sy (Iteration_Scheme, Node_Id, Default_Empty),
+ Sy (Statements, List_Id, Default_Empty_List),
+ Sy (End_Label, Node_Id, Default_Empty),
+ Sy (Has_Created_Identifier, Flag),
+ Sy (Is_Null_Loop, Flag),
+ Sy (Suppress_Loop_Warnings, Flag)));
+
+ Cc (N_Null_Statement, N_Statement_Other_Than_Procedure_Call,
+ (Sm (Next_Rep_Item, Node_Id)));
+
+ Cc (N_Raise_Statement, N_Statement_Other_Than_Procedure_Call,
+ (Sy (Name, Node_Id, Default_Empty),
+ Sy (Expression, Node_Id, Default_Empty),
+ Sm (From_At_End, Flag)));
+
+ Cc (N_Raise_When_Statement, N_Statement_Other_Than_Procedure_Call,
+ (Sy (Name, Node_Id, Default_Empty),
+ Sy (Expression, Node_Id, Default_Empty),
+ Sy (Condition, Node_Id, Default_Empty)));
+
+ Cc (N_Requeue_Statement, N_Statement_Other_Than_Procedure_Call,
+ (Sy (Name, Node_Id, Default_Empty),
+ Sy (Abort_Present, Flag),
+ Sm (Is_Elaboration_Checks_OK_Node, Flag),
+ Sm (Is_Elaboration_Warnings_OK_Node, Flag),
+ Sm (Is_SPARK_Mode_On_Node, Flag)));
+
+ Cc (N_Simple_Return_Statement, N_Statement_Other_Than_Procedure_Call,
+ (Sy (Expression, Node_Id, Default_Empty),
+ Sm (By_Ref, Flag),
+ Sm (Comes_From_Extended_Return_Statement, Flag),
+ Sm (Procedure_To_Call, Node_Id),
+ Sm (Return_Statement_Entity, Node_Id),
+ Sm (Storage_Pool, Node_Id)));
+
+ Cc (N_Extended_Return_Statement, N_Statement_Other_Than_Procedure_Call,
+ (Sy (Return_Object_Declarations, List_Id),
+ Sy (Handled_Statement_Sequence, Node_Id, Default_Empty),
+ Sm (By_Ref, Flag),
+ Sm (Procedure_To_Call, Node_Id),
+ Sm (Return_Statement_Entity, Node_Id),
+ Sm (Storage_Pool, Node_Id)));
+
+ Cc (N_Return_When_Statement, N_Statement_Other_Than_Procedure_Call,
+ (Sy (Expression, Node_Id, Default_Empty),
+ Sy (Condition, Node_Id, Default_Empty)));
+
+ Cc (N_Selective_Accept, N_Statement_Other_Than_Procedure_Call,
+ (Sy (Select_Alternatives, List_Id),
+ Sy (Else_Statements, List_Id, Default_No_List)));
+
+ Cc (N_Timed_Entry_Call, N_Statement_Other_Than_Procedure_Call,
+ (Sy (Entry_Call_Alternative, Node_Id),
+ Sy (Delay_Alternative, Node_Id)));
+
+ Cc (N_Exit_Statement, N_Statement_Other_Than_Procedure_Call,
+ (Sy (Name, Node_Id, Default_Empty),
+ Sy (Condition, Node_Id, Default_Empty),
+ Sm (Next_Exit_Statement, Node_Id)));
+
+ Cc (N_If_Statement, N_Statement_Other_Than_Procedure_Call,
+ (Sy (Condition, Node_Id, Default_Empty),
+ Sy (Then_Statements, List_Id),
+ Sy (Elsif_Parts, List_Id, Default_No_List),
+ Sy (Else_Statements, List_Id, Default_No_List),
+ Sy (End_Span, Uint, Default_Uint_0),
+ Sm (From_Conditional_Expression, Flag)));
+
+ Cc (N_Accept_Alternative, Node_Kind,
+ (Sy (Accept_Statement, Node_Id),
+ Sy (Condition, Node_Id, Default_Empty),
+ Sy (Statements, List_Id, Default_Empty_List),
+ Sy (Pragmas_Before, List_Id, Default_No_List),
+ Sm (Accept_Handler_Records, List_Id)));
+
+ Cc (N_Delay_Alternative, Node_Kind,
+ (Sy (Delay_Statement, Node_Id),
+ Sy (Condition, Node_Id, Default_Empty),
+ Sy (Statements, List_Id, Default_Empty_List),
+ Sy (Pragmas_Before, List_Id, Default_No_List)));
+
+ Cc (N_Elsif_Part, Node_Kind,
+ (Sy (Condition, Node_Id, Default_Empty),
+ Sy (Then_Statements, List_Id),
+ Sm (Condition_Actions, List_Id)));
+
+ Cc (N_Entry_Body_Formal_Part, Node_Kind,
+ (Sy (Entry_Index_Specification, Node_Id, Default_Empty),
+ Sy (Parameter_Specifications, List_Id, Default_No_List),
+ Sy (Condition, Node_Id, Default_Empty)));
+
+ Cc (N_Iteration_Scheme, Node_Kind,
+ (Sy (Condition, Node_Id, Default_Empty),
+ Sy (Iterator_Specification, Node_Id, Default_Empty),
+ Sy (Loop_Parameter_Specification, Node_Id, Default_Empty),
+ Sm (Condition_Actions, List_Id)));
+
+ Cc (N_Terminate_Alternative, Node_Kind,
+ (Sy (Condition, Node_Id, Default_Empty),
+ Sy (Pragmas_Before, List_Id, Default_No_List),
+ Sy (Pragmas_After, List_Id, Default_No_List)));
+
+ Ab (N_Formal_Subprogram_Declaration, Node_Kind);
+
+ Cc (N_Formal_Abstract_Subprogram_Declaration, N_Formal_Subprogram_Declaration,
+ (Sy (Specification, Node_Id),
+ Sy (Default_Name, Node_Id, Default_Empty),
+ Sy (Box_Present, Flag)));
+
+ Cc (N_Formal_Concrete_Subprogram_Declaration, N_Formal_Subprogram_Declaration,
+ (Sy (Specification, Node_Id),
+ Sy (Default_Name, Node_Id, Default_Empty),
+ Sy (Box_Present, Flag)));
+
+ Ab (N_Push_Pop_xxx_Label, Node_Kind);
+
+ Ab (N_Push_xxx_Label, N_Push_Pop_xxx_Label,
+ (Sm (Exception_Label, Node_Id)));
+
+ Cc (N_Push_Constraint_Error_Label, N_Push_xxx_Label);
+
+ Cc (N_Push_Program_Error_Label, N_Push_xxx_Label);
+
+ Cc (N_Push_Storage_Error_Label, N_Push_xxx_Label);
+
+ Ab (N_Pop_xxx_Label, N_Push_Pop_xxx_Label);
+
+ Cc (N_Pop_Constraint_Error_Label, N_Pop_xxx_Label);
+
+ Cc (N_Pop_Program_Error_Label, N_Pop_xxx_Label);
+
+ Cc (N_Pop_Storage_Error_Label, N_Pop_xxx_Label);
+
+ Ab (N_SCIL_Node, Node_Kind,
+ (Sm (SCIL_Entity, Node_Id)));
+
+ Cc (N_SCIL_Dispatch_Table_Tag_Init, N_SCIL_Node);
+
+ Cc (N_SCIL_Dispatching_Call, N_SCIL_Node,
+ (Sm (SCIL_Controlling_Tag, Node_Id),
+ Sm (SCIL_Target_Prim, Node_Id)));
+
+ Cc (N_SCIL_Membership_Test, N_SCIL_Node,
+ (Sm (SCIL_Tag_Value, Node_Id)));
+
+ Cc (N_Abortable_Part, Node_Kind,
+ (Sy (Statements, List_Id, Default_Empty_List)));
+
+ Cc (N_Abstract_Subprogram_Declaration, Node_Kind,
+ (Sy (Specification, Node_Id)));
+
+ Cc (N_Access_Definition, Node_Kind,
+ (Sy (Null_Exclusion_Present, Flag, Default_False),
+ Sy (All_Present, Flag),
+ Sy (Constant_Present, Flag),
+ Sy (Subtype_Mark, Node_Id, Default_Empty),
+ Sy (Access_To_Subprogram_Definition, Node_Id, Default_Empty)));
+
+ Cc (N_Access_To_Object_Definition, Node_Kind,
+ (Sy (All_Present, Flag),
+ Sy (Null_Exclusion_Present, Flag, Default_False),
+ Sy (Null_Excluding_Subtype, Flag),
+ Sy (Subtype_Indication, Node_Id, Default_Empty),
+ Sy (Constant_Present, Flag)));
+
+ Cc (N_Aspect_Specification, Node_Kind,
+ (Sy (Identifier, Node_Id, Default_Empty),
+ Sy (Expression, Node_Id, Default_Empty),
+ Sy (Class_Present, Flag),
+ Sy (Split_PPC, Flag),
+ Sm (Aspect_On_Partial_View, Flag),
+ Sm (Aspect_Rep_Item, Node_Id),
+ Sm (Entity_Or_Associated_Node, Node_Id), -- just Entity
+ Sm (Is_Boolean_Aspect, Flag),
+ Sm (Is_Checked, Flag),
+ Sm (Is_Delayed_Aspect, Flag),
+ Sm (Is_Disabled, Flag),
+ Sm (Is_Ignored, Flag),
+ Sm (Next_Rep_Item, Node_Id)));
+
+ Cc (N_Call_Marker, Node_Kind,
+ (Sm (Is_Declaration_Level_Node, Flag),
+ Sm (Is_Dispatching_Call, Flag),
+ Sm (Is_Elaboration_Checks_OK_Node, Flag),
+ Sm (Is_Elaboration_Warnings_OK_Node, Flag),
+ Sm (Is_Known_Guaranteed_ABE, Flag),
+ Sm (Is_Preelaborable_Call, Flag),
+ Sm (Is_Source_Call, Flag),
+ Sm (Is_SPARK_Mode_On_Node, Flag),
+ Sm (Target, Node_Id)));
+
+ Cc (N_Case_Expression_Alternative, Node_Kind,
+ (Sm (Actions, List_Id),
+ Sy (Discrete_Choices, List_Id),
+ Sy (Expression, Node_Id, Default_Empty),
+ Sm (Has_SP_Choice, Flag)));
+
+ Cc (N_Case_Statement_Alternative, Node_Kind,
+ (Sy (Discrete_Choices, List_Id),
+ Sy (Statements, List_Id, Default_Empty_List),
+ Sm (Has_SP_Choice, Flag),
+ Sm (Multidefined_Bindings, Flag)));
+
+ Cc (N_Compilation_Unit, Node_Kind,
+ (Sy (Context_Items, List_Id),
+ Sy (Private_Present, Flag),
+ Sy (Unit, Node_Id),
+ Sy (Aux_Decls_Node, Node_Id),
+ Sm (Acts_As_Spec, Flag),
+ Sm (Body_Required, Flag),
+ Sm (Context_Pending, Flag),
+ Sm (First_Inlined_Subprogram, Node_Id),
+ Sm (Has_No_Elaboration_Code, Flag),
+ Sm (Has_Pragma_Suppress_All, Flag),
+ Sm (Library_Unit, Node_Id),
+ Sm (Save_Invocation_Graph_Of_Body, Flag)));
+
+ Cc (N_Compilation_Unit_Aux, Node_Kind,
+ (Sy (Declarations, List_Id, Default_No_List),
+ Sy (Actions, List_Id, Default_No_List),
+ Sy (Pragmas_After, List_Id, Default_No_List),
+ Sy (Config_Pragmas, List_Id, Default_Empty_List),
+ Sm (Default_Storage_Pool, Node_Id)));
+
+ Cc (N_Component_Association, Node_Kind,
+ (Sy (Choices, List_Id),
+ Sy (Expression, Node_Id, Default_Empty),
+ Sy (Box_Present, Flag),
+ Sy (Inherited_Discriminant, Flag),
+ Sy (Binding_Chars, Name_Id, Default_No_Name),
+ Sm (Loop_Actions, List_Id),
+ Sm (Was_Default_Init_Box_Association, Flag)));
+
+ Cc (N_Component_Definition, Node_Kind,
+ (Sy (Aliased_Present, Flag),
+ Sy (Null_Exclusion_Present, Flag, Default_False),
+ Sy (Subtype_Indication, Node_Id, Default_Empty),
+ Sy (Access_Definition, Node_Id, Default_Empty)));
+
+ Cc (N_Component_List, Node_Kind,
+ (Sy (Component_Items, List_Id),
+ Sy (Variant_Part, Node_Id, Default_Empty),
+ Sy (Null_Present, Flag)));
+
+ Cc (N_Contract, Node_Kind,
+ (Sm (Classifications, Node_Id),
+ Sm (Contract_Test_Cases, Node_Id),
+ Sm (Is_Expanded_Contract, Flag),
+ Sm (Pre_Post_Conditions, Node_Id)));
+
+ Cc (N_Derived_Type_Definition, Node_Kind,
+ (Sy (Abstract_Present, Flag),
+ Sy (Null_Exclusion_Present, Flag, Default_False),
+ Sy (Subtype_Indication, Node_Id, Default_Empty),
+ Sy (Record_Extension_Part, Node_Id, Default_Empty),
+ Sy (Limited_Present, Flag),
+ Sy (Task_Present, Flag),
+ Sy (Protected_Present, Flag),
+ Sy (Synchronized_Present, Flag),
+ Sy (Interface_List, List_Id, Default_No_List),
+ Sy (Interface_Present, Flag)));
+
+ Cc (N_Decimal_Fixed_Point_Definition, Node_Kind,
+ (Sy (Delta_Expression, Node_Id),
+ Sy (Digits_Expression, Node_Id),
+ Sy (Real_Range_Specification, Node_Id, Default_Empty)));
+
+ Cc (N_Defining_Program_Unit_Name, Node_Kind,
+ (Sy (Name, Node_Id, Default_Empty),
+ Sy (Defining_Identifier, Node_Id)));
+
+ Cc (N_Delta_Constraint, Node_Kind,
+ (Sy (Delta_Expression, Node_Id),
+ Sy (Range_Constraint, Node_Id, Default_Empty)));
+
+ Cc (N_Designator, Node_Kind,
+ (Sy (Name, Node_Id, Default_Empty),
+ Sy (Identifier, Node_Id, Default_Empty)));
+
+ Cc (N_Digits_Constraint, Node_Kind,
+ (Sy (Digits_Expression, Node_Id),
+ Sy (Range_Constraint, Node_Id, Default_Empty)));
+
+ Cc (N_Discriminant_Association, Node_Kind,
+ (Sy (Selector_Names, List_Id),
+ Sy (Expression, Node_Id, Default_Empty)));
+
+ Cc (N_Discriminant_Specification, Node_Kind,
+ (Sy (Defining_Identifier, Node_Id),
+ Sy (Null_Exclusion_Present, Flag, Default_False),
+ Sy (Discriminant_Type, Node_Id),
+ Sy (Expression, Node_Id, Default_Empty),
+ Sm (More_Ids, Flag),
+ Sm (Prev_Ids, Flag)));
+
+ Cc (N_Enumeration_Type_Definition, Node_Kind,
+ (Sy (Literals, List_Id),
+ Sy (End_Label, Node_Id, Default_Empty)));
+
+ Cc (N_Entry_Body, Node_Kind,
+ (Sy (Defining_Identifier, Node_Id),
+ Sy (Entry_Body_Formal_Part, Node_Id),
+ Sy (Declarations, List_Id, Default_No_List),
+ Sy (Handled_Statement_Sequence, Node_Id, Default_Empty),
+ Sm (Activation_Chain_Entity, Node_Id)));
+
+ Cc (N_Entry_Call_Alternative, Node_Kind,
+ (Sy (Entry_Call_Statement, Node_Id),
+ Sy (Statements, List_Id, Default_Empty_List),
+ Sy (Pragmas_Before, List_Id, Default_No_List)));
+
+ Cc (N_Entry_Index_Specification, Node_Kind,
+ (Sy (Defining_Identifier, Node_Id),
+ Sy (Discrete_Subtype_Definition, Node_Id, Default_Empty)));
+
+ Cc (N_Exception_Declaration, N_Declaration,
+ (Sy (Defining_Identifier, Node_Id),
+ Sm (Expression, Node_Id),
+ Sm (More_Ids, Flag),
+ Sm (Prev_Ids, Flag),
+ Sm (Renaming_Exception, Node_Id)));
+
+ Cc (N_Exception_Handler, Node_Kind,
+ (Sy (Choice_Parameter, Node_Id, Default_Empty),
+ Sy (Exception_Choices, List_Id),
+ Sy (Statements, List_Id, Default_Empty_List),
+ Sm (Exception_Label, Node_Id),
+ Sm (Has_Local_Raise, Flag),
+ Sm (Local_Raise_Not_OK, Flag),
+ Sm (Local_Raise_Statements, Elist_Id)));
+
+ Cc (N_Floating_Point_Definition, Node_Kind,
+ (Sy (Digits_Expression, Node_Id),
+ Sy (Real_Range_Specification, Node_Id, Default_Empty)));
+
+ Cc (N_Formal_Decimal_Fixed_Point_Definition, Node_Kind);
+
+ Cc (N_Formal_Derived_Type_Definition, Node_Kind,
+ (Sy (Subtype_Mark, Node_Id, Default_Empty),
+ Sy (Private_Present, Flag),
+ Sy (Abstract_Present, Flag),
+ Sy (Limited_Present, Flag),
+ Sy (Synchronized_Present, Flag),
+ Sy (Interface_List, List_Id, Default_No_List)));
+
+ Cc (N_Formal_Discrete_Type_Definition, Node_Kind);
+
+ Cc (N_Formal_Floating_Point_Definition, Node_Kind);
+
+ Cc (N_Formal_Modular_Type_Definition, Node_Kind);
+
+ Cc (N_Formal_Ordinary_Fixed_Point_Definition, Node_Kind);
+
+ Cc (N_Formal_Package_Declaration, Node_Kind,
+ (Sy (Defining_Identifier, Node_Id),
+ Sy (Name, Node_Id, Default_Empty),
+ Sy (Generic_Associations, List_Id, Default_No_List),
+ Sy (Box_Present, Flag),
+ Sm (Instance_Spec, Node_Id),
+ Sm (Is_Known_Guaranteed_ABE, Flag)));
+
+ Cc (N_Formal_Private_Type_Definition, Node_Kind,
+ (Sy (Abstract_Present, Flag),
+ Sy (Tagged_Present, Flag),
+ Sy (Limited_Present, Flag),
+ Sm (Uninitialized_Variable, Node_Id)));
+
+ Cc (N_Formal_Incomplete_Type_Definition, Node_Kind,
+ (Sy (Tagged_Present, Flag)));
+
+ Cc (N_Formal_Signed_Integer_Type_Definition, Node_Kind);
+
+ Cc (N_Freeze_Entity, Node_Kind,
+ (Sy (Actions, List_Id, Default_No_List),
+ Sm (Access_Types_To_Process, Elist_Id),
+ Sm (Entity_Or_Associated_Node, Node_Id), -- just Entity
+ Sm (First_Subtype_Link, Node_Id),
+ Sm (TSS_Elist, Elist_Id)));
+
+ Cc (N_Freeze_Generic_Entity, Node_Kind,
+ Sm (Entity_Or_Associated_Node, Node_Id)); -- just Entity
+
+ Cc (N_Generic_Association, Node_Kind,
+ (Sy (Selector_Name, Node_Id, Default_Empty),
+ Sy (Explicit_Generic_Actual_Parameter, Node_Id),
+ Sy (Box_Present, Flag)));
+
+ Cc (N_Handled_Sequence_Of_Statements, Node_Kind,
+ (Sy (Statements, List_Id, Default_Empty_List),
+ Sy (End_Label, Node_Id, Default_Empty),
+ Sy (Exception_Handlers, List_Id, Default_No_List),
+ Sy (At_End_Proc, Node_Id, Default_Empty),
+ Sm (First_Real_Statement, Node_Id)));
+
+ Cc (N_Index_Or_Discriminant_Constraint, Node_Kind,
+ (Sy (Constraints, List_Id)));
+
+ Cc (N_Iterated_Component_Association, Node_Kind,
+ (Sy (Defining_Identifier, Node_Id),
+ Sy (Iterator_Specification, Node_Id, Default_Empty),
+ Sy (Expression, Node_Id, Default_Empty),
+ Sy (Discrete_Choices, List_Id),
+ Sy (Box_Present, Flag),
+ Sm (Loop_Actions, List_Id)));
+
+ Cc (N_Iterated_Element_Association, Node_Kind,
+ (Sy (Key_Expression, Node_Id),
+ Sy (Iterator_Specification, Node_Id, Default_Empty),
+ Sy (Expression, Node_Id, Default_Empty),
+ Sy (Loop_Parameter_Specification, Node_Id, Default_Empty),
+ Sy (Box_Present, Flag),
+ Sm (Loop_Actions, List_Id)));
+
+ Cc (N_Itype_Reference, Node_Kind,
+ (Sm (Itype, Node_Id)));
+
+ Cc (N_Label, Node_Kind,
+ (Sy (Identifier, Node_Id, Default_Empty),
+ Sm (Exception_Junk, Flag)));
+
+ Cc (N_Modular_Type_Definition, Node_Kind,
+ (Sy (Expression, Node_Id, Default_Empty)));
+
+ Cc (N_Number_Declaration, Node_Kind,
+ (Sy (Defining_Identifier, Node_Id),
+ Sy (Expression, Node_Id, Default_Empty),
+ Sm (More_Ids, Flag),
+ Sm (Prev_Ids, Flag)));
+
+ Cc (N_Ordinary_Fixed_Point_Definition, Node_Kind,
+ (Sy (Delta_Expression, Node_Id),
+ Sy (Real_Range_Specification, Node_Id, Default_Empty)));
+
+ Cc (N_Others_Choice, Node_Kind,
+ (Sm (All_Others, Flag),
+ Sm (Others_Discrete_Choices, List_Id)));
+
+ Cc (N_Package_Specification, Node_Kind,
+ (Sy (Defining_Unit_Name, Node_Id),
+ Sy (Visible_Declarations, List_Id),
+ Sy (Private_Declarations, List_Id, Default_No_List),
+ Sy (End_Label, Node_Id, Default_Empty),
+ Sm (Generic_Parent, Node_Id),
+ Sm (Limited_View_Installed, Flag)));
+
+ Cc (N_Parameter_Association, Node_Kind,
+ (Sy (Selector_Name, Node_Id, Default_Empty),
+ Sy (Explicit_Actual_Parameter, Node_Id),
+ Sm (Is_Accessibility_Actual, Flag),
+ Sm (Next_Named_Actual, Node_Id)));
+
+ Cc (N_Parameter_Specification, Node_Kind,
+ (Sy (Defining_Identifier, Node_Id),
+ Sy (Aliased_Present, Flag),
+ Sy (In_Present, Flag),
+ Sy (Out_Present, Flag),
+ Sy (Null_Exclusion_Present, Flag, Default_False),
+ Sy (Parameter_Type, Node_Id),
+ Sy (Expression, Node_Id, Default_Empty),
+ Sm (Default_Expression, Node_Id),
+ Sm (More_Ids, Flag),
+ Sm (Prev_Ids, Flag)));
+
+ Cc (N_Pragma, Node_Kind,
+ (Sy (Pragma_Argument_Associations, List_Id, Default_No_List),
+ Sy (Pragma_Identifier, Node_Id),
+ Sy (Class_Present, Flag),
+ Sy (Split_PPC, Flag),
+ Sm (Corresponding_Aspect, Node_Id),
+ Sm (From_Aspect_Specification, Flag),
+ Sm (Import_Interface_Present, Flag),
+ Sm (Is_Analyzed_Pragma, Flag),
+ Sm (Is_Checked, Flag),
+ Sm (Is_Checked_Ghost_Pragma, Flag),
+ Sm (Is_Delayed_Aspect, Flag),
+ Sm (Is_Disabled, Flag),
+ Sm (Is_Generic_Contract_Pragma, Flag),
+ Sm (Is_Ignored, Flag),
+ Sm (Is_Ignored_Ghost_Pragma, Flag),
+ Sm (Is_Inherited_Pragma, Flag),
+ Sm (Next_Pragma, Node_Id),
+ Sm (Next_Rep_Item, Node_Id),
+ Sm (Uneval_Old_Accept, Flag),
+ Sm (Uneval_Old_Warn, Flag)));
+
+ Cc (N_Protected_Definition, Node_Kind,
+ (Sy (Visible_Declarations, List_Id),
+ Sy (Private_Declarations, List_Id, Default_No_List),
+ Sy (End_Label, Node_Id, Default_Empty)));
+
+ Cc (N_Range_Constraint, Node_Kind,
+ (Sy (Range_Expression, Node_Id)));
+
+ Cc (N_Real_Range_Specification, Node_Kind,
+ (Sy (Low_Bound, Node_Id),
+ Sy (High_Bound, Node_Id)));
+
+ Cc (N_Record_Definition, Node_Kind,
+ (Sy (End_Label, Node_Id, Default_Empty),
+ Sy (Abstract_Present, Flag),
+ Sy (Tagged_Present, Flag),
+ Sy (Limited_Present, Flag),
+ Sy (Component_List, Node_Id),
+ Sy (Null_Present, Flag),
+ Sy (Task_Present, Flag),
+ Sy (Protected_Present, Flag),
+ Sy (Synchronized_Present, Flag),
+ Sy (Interface_Present, Flag),
+ Sy (Interface_List, List_Id, Default_No_List)));
+
+ Cc (N_Signed_Integer_Type_Definition, Node_Kind,
+ (Sy (Low_Bound, Node_Id),
+ Sy (High_Bound, Node_Id)));
+
+ Cc (N_Single_Protected_Declaration, Node_Kind,
+ (Sy (Defining_Identifier, Node_Id),
+ Sy (Interface_List, List_Id, Default_No_List),
+ Sy (Protected_Definition, Node_Id)));
+
+ Cc (N_Subunit, Node_Kind,
+ (Sy (Name, Node_Id, Default_Empty),
+ Sy (Proper_Body, Node_Id),
+ Sm (Corresponding_Stub, Node_Id)));
+
+ Cc (N_Task_Definition, Node_Kind,
+ (Sy (Visible_Declarations, List_Id),
+ Sy (Private_Declarations, List_Id, Default_No_List),
+ Sy (End_Label, Node_Id, Default_Empty),
+ Sm (Has_Relative_Deadline_Pragma, Flag),
+ Sm (Has_Storage_Size_Pragma, Flag)));
+
+ Cc (N_Triggering_Alternative, Node_Kind,
+ (Sy (Triggering_Statement, Node_Id),
+ Sy (Statements, List_Id, Default_Empty_List),
+ Sy (Pragmas_Before, List_Id, Default_No_List)));
+
+ Cc (N_Use_Type_Clause, Node_Kind,
+ (Sy (Subtype_Mark, Node_Id, Default_Empty),
+ Sy (Is_Effective_Use_Clause, Flag),
+ Sy (All_Present, Flag),
+ Sm (Hidden_By_Use_Clause, Elist_Id),
+ Sm (More_Ids, Flag),
+ Sm (Next_Use_Clause, Node_Id),
+ Sm (Prev_Ids, Flag),
+ Sm (Prev_Use_Clause, Node_Id),
+ Sm (Used_Operations, Elist_Id)));
+
+ Cc (N_Validate_Unchecked_Conversion, Node_Kind,
+ (Sm (Source_Type, Node_Id),
+ Sm (Target_Type, Node_Id)));
+
+ Cc (N_Variable_Reference_Marker, Node_Kind,
+ (Sm (Is_Elaboration_Checks_OK_Node, Flag),
+ Sm (Is_Elaboration_Warnings_OK_Node, Flag),
+ Sm (Is_Read, Flag),
+ Sm (Is_SPARK_Mode_On_Node, Flag),
+ Sm (Is_Write, Flag),
+ Sm (Target, Node_Id)));
+
+ Cc (N_Variant, Node_Kind,
+ (Sy (Discrete_Choices, List_Id),
+ Sy (Component_List, Node_Id),
+ Sm (Dcheck_Function, Node_Id),
+ Sm (Enclosing_Variant, Node_Id),
+ Sm (Has_SP_Choice, Flag),
+ Sm (Present_Expr, Uint)));
+
+ Cc (N_Variant_Part, Node_Kind,
+ (Sy (Name, Node_Id, Default_Empty),
+ Sy (Variants, List_Id)));
+
+ Cc (N_With_Clause, Node_Kind,
+ (Sy (Name, Node_Id, Default_Empty),
+ Sy (Private_Present, Flag),
+ Sy (Limited_Present, Flag),
+ Sy (First_Name, Flag, Default_True),
+ Sy (Last_Name, Flag, Default_True),
+ Sm (Context_Installed, Flag),
+ Sm (Corresponding_Spec, Node_Id),
+ Sm (Elaborate_All_Desirable, Flag),
+ Sm (Elaborate_All_Present, Flag),
+ Sm (Elaborate_Desirable, Flag),
+ Sm (Elaborate_Present, Flag),
+ Sm (Implicit_With, Flag),
+ Sm (Library_Unit, Node_Id),
+ Sm (Limited_View_Installed, Flag),
+ Sm (Next_Implicit_With, Node_Id),
+ Sm (No_Entities_Ref_In_Spec, Flag),
+ Sm (Parent_With, Flag),
+ Sm (Unreferenced_In_Spec, Flag)));
+
+ Cc (N_Unused_At_End, Node_Kind);
+
+ -- Union types. These don't fit into the normal parent/child hierarchy
+ -- above.
+
+ Union (N_Has_Chars,
+ Children =>
+ (N_Attribute_Definition_Clause,
+ N_Empty,
+ N_Pragma_Argument_Association,
+ N_Error,
+ N_Entity,
+ N_Expanded_Name,
+ N_Identifier,
+ N_Operator_Symbol,
+ N_Character_Literal,
+ N_Op));
+
+ Union (N_Has_Condition,
+ Children =>
+ (N_Exit_Statement,
+ N_If_Statement,
+ N_Accept_Alternative,
+ N_Delay_Alternative,
+ N_Elsif_Part,
+ N_Entry_Body_Formal_Part,
+ N_Iteration_Scheme,
+ N_Terminate_Alternative));
+ -- Nodes with condition fields (does not include N_Raise_xxx_Error)
+
+end Gen_IL.Gen.Gen_Nodes;
diff --git a/gcc/ada/gen_il-gen.adb b/gcc/ada/gen_il-gen.adb
new file mode 100644
index 0000000..a9c7bd7
--- /dev/null
+++ b/gcc/ada/gen_il-gen.adb
@@ -0,0 +1,3278 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- G E N _ I L . G E N --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 2020-2021, Free Software Foundation, Inc. --
+-- --
+-- GNAT is 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 Ada.Containers; use type Ada.Containers.Count_Type;
+with Ada.Text_IO;
+
+package body Gen_IL.Gen is
+
+ Enable_Assertions : constant Boolean := True;
+ -- True to enable predicates on the _Id types, and preconditions on getters
+ -- and setters.
+
+ Overlay_Fields : constant Boolean := True;
+ -- False to allocate every field so it doesn't overlay any other fields,
+ -- which results in enormous nodes. For experimenting and debugging.
+ -- Should be True in normal operation, for efficiency.
+
+ Inline : constant String := "Inline";
+ -- For experimenting with Inline_Always
+
+ Syntactic : Fields_Per_Node_Type :=
+ (others => (others => False));
+
+ Nodes_And_Entities : constant Type_Vector := Node_Kind & Entity_Kind;
+ All_Entities : constant Type_Vector := To_Vector (Entity_Kind, Length => 1);
+
+ procedure Create_Type
+ (T : Node_Or_Entity_Type;
+ Parent : Opt_Abstract_Type;
+ Fields : Field_Sequence;
+ Nmake_Assert : String);
+ -- Called by the Create_..._Type procedures exported by this package to
+ -- create an entry in the Types_Table.
+
+ procedure Create_Union_Type
+ (Root : Root_Type; T : Abstract_Type; Children : Type_Array);
+ -- Called by Create_Node_Union_Type and Create_Entity_Union_Type to create
+ -- a union type.
+
+ function Create_Field
+ (Field : Field_Enum;
+ Field_Type : Type_Enum;
+ Default_Value : Field_Default_Value;
+ Type_Only : Type_Only_Enum;
+ Pre, Pre_Get, Pre_Set : String;
+ Is_Syntactic : Boolean) return Field_Desc;
+ -- Called by the Create_..._Field functions exported by this package to
+ -- create an entry in the Field_Table. See Create_Syntactic_Field and
+ -- Create_Semantic_Field for additional doc.
+
+ procedure Check_Type (T : Node_Or_Entity_Type);
+ -- Check some "legality" rules for types in the Gen_IL little language
+
+ ----------------
+ -- Check_Type --
+ ----------------
+
+ procedure Check_Type (T : Node_Or_Entity_Type) is
+ Im : constant String := Node_Or_Entity_Type'Image (T);
+ begin
+ if Type_Table (T) /= null then
+ raise Illegal with "duplicate creation of type " & Image (T);
+ end if;
+
+ if T not in Root_Type then
+ case T is
+ when Node_Type =>
+ if Im'Length < 2 or else Im (1 .. 2) /= "N_" then
+ raise Illegal with "Node type names must start with ""N_""";
+ end if;
+
+ when Concrete_Entity =>
+ if Im'Length < 2 or else Im (1 .. 2) /= "E_" then
+ raise Illegal with
+ "Concrete entity type names must start with ""E_""";
+ end if;
+
+ when others => null;
+ -- No special prefix for abstract entities
+ end case;
+ end if;
+ end Check_Type;
+
+ -----------------
+ -- Create_Type --
+ -----------------
+
+ procedure Create_Type
+ (T : Node_Or_Entity_Type;
+ Parent : Opt_Abstract_Type;
+ Fields : Field_Sequence;
+ Nmake_Assert : String)
+ is
+ begin
+ Check_Type (T);
+
+ if T not in Root_Type then
+ if Type_Table (Parent) = null then
+ raise Illegal with
+ "undefined parent type for " &
+ Image (T) & " (parent is " & Image (Parent) & ")";
+ end if;
+
+ if Type_Table (Parent).Is_Union then
+ raise Illegal with
+ "parent type for " &
+ Image (T) & " must not be union (" & Image (Parent) & ")";
+ end if;
+ end if;
+
+ Type_Table (T) :=
+ new Type_Info'
+ (Is_Union => False, Parent => Parent,
+ Children | Concrete_Descendants => Type_Vectors.Empty_Vector,
+ First | Last | Fields => <>, -- filled in later
+ Nmake_Assert => new String'(Nmake_Assert));
+
+ if Parent /= No_Type then
+ Append (Type_Table (Parent).Children, T);
+ end if;
+
+ -- Check that syntactic fields precede semantic fields. Note that this
+ -- check is happening before we compute inherited fields.
+ -- Exempt Chars and Actions from this rule, for now.
+
+ declare
+ Semantic_Seen : Boolean := False;
+ begin
+ for J in Fields'Range loop
+ if Fields (J).Is_Syntactic then
+ if Semantic_Seen then
+ raise Illegal with
+ "syntactic fields must precede semantic ones " & Image (T);
+ end if;
+
+ else
+ if Fields (J).F not in Chars | Actions then
+ Semantic_Seen := True;
+ end if;
+ end if;
+ end loop;
+ end;
+
+ -- Check that node fields are in nodes, and entity fields are in
+ -- entities.
+
+ for J in Fields'Range loop
+ declare
+ Field : constant Field_Enum := Fields (J).F;
+ Error_Prefix : constant String :=
+ "Field " & Image (T) & "." & Image (Field) & " not in ";
+ begin
+ case T is
+ when Node_Type =>
+ if Field not in Node_Field then
+ raise Illegal with Error_Prefix & "Node_Field";
+ end if;
+
+ when Entity_Type =>
+ if Field not in Entity_Field then
+ raise Illegal with Error_Prefix & "Entity_Field";
+ end if;
+
+ when Type_Boundaries =>
+ raise Program_Error; -- dummy types shouldn't have fields
+ end case;
+ end;
+ end loop;
+
+ -- Compute the Have_This_Field component of fields, the Fields component
+ -- of the current type, and Syntactic table.
+
+ for J in Fields'Range loop
+ declare
+ Field : constant Field_Enum := Fields (J).F;
+ Is_Syntactic : constant Boolean := Fields (J).Is_Syntactic;
+
+ begin
+ Append (Field_Table (Field).Have_This_Field, T);
+ Append (Type_Table (T).Fields, Field);
+
+ pragma Assert (not Syntactic (T) (Field));
+ Syntactic (T) (Field) := Is_Syntactic;
+ end;
+ end loop;
+ end Create_Type;
+
+ -- Other than constraint checks on T at the call site, and the lack of a
+ -- parent for root types, the following six all do the same thing.
+
+ ---------------------------
+ -- Create_Root_Node_Type --
+ ---------------------------
+
+ procedure Create_Root_Node_Type
+ (T : Abstract_Node;
+ Fields : Field_Sequence := No_Fields) is
+ begin
+ Create_Type (T, Parent => No_Type, Fields => Fields, Nmake_Assert => "");
+ end Create_Root_Node_Type;
+
+ -------------------------------
+ -- Create_Abstract_Node_Type --
+ -------------------------------
+
+ procedure Create_Abstract_Node_Type
+ (T : Abstract_Node; Parent : Abstract_Type;
+ Fields : Field_Sequence := No_Fields)
+ is
+ begin
+ Create_Type (T, Parent, Fields, Nmake_Assert => "");
+ end Create_Abstract_Node_Type;
+
+ -------------------------------
+ -- Create_Concrete_Node_Type --
+ -------------------------------
+
+ procedure Create_Concrete_Node_Type
+ (T : Concrete_Node; Parent : Abstract_Type;
+ Fields : Field_Sequence := No_Fields;
+ Nmake_Assert : String := "")
+ is
+ begin
+ Create_Type (T, Parent, Fields, Nmake_Assert);
+ end Create_Concrete_Node_Type;
+
+ -----------------------------
+ -- Create_Root_Entity_Type --
+ -----------------------------
+
+ procedure Create_Root_Entity_Type
+ (T : Abstract_Entity;
+ Fields : Field_Sequence := No_Fields) is
+ begin
+ Create_Type (T, Parent => No_Type, Fields => Fields, Nmake_Assert => "");
+ end Create_Root_Entity_Type;
+
+ ---------------------------------
+ -- Create_Abstract_Entity_Type --
+ ---------------------------------
+
+ procedure Create_Abstract_Entity_Type
+ (T : Abstract_Entity; Parent : Abstract_Type;
+ Fields : Field_Sequence := No_Fields)
+ is
+ begin
+ Create_Type (T, Parent, Fields, Nmake_Assert => "");
+ end Create_Abstract_Entity_Type;
+
+ ---------------------------------
+ -- Create_Concrete_Entity_Type --
+ ---------------------------------
+
+ procedure Create_Concrete_Entity_Type
+ (T : Concrete_Entity; Parent : Abstract_Type;
+ Fields : Field_Sequence := No_Fields)
+ is
+ begin
+ Create_Type (T, Parent, Fields, Nmake_Assert => "");
+ end Create_Concrete_Entity_Type;
+
+ ------------------
+ -- Create_Field --
+ ------------------
+
+ function Create_Field
+ (Field : Field_Enum;
+ Field_Type : Type_Enum;
+ Default_Value : Field_Default_Value;
+ Type_Only : Type_Only_Enum;
+ Pre, Pre_Get, Pre_Set : String;
+ Is_Syntactic : Boolean) return Field_Desc
+ is
+ begin
+ -- Note that this function has the side effect of update the
+ -- Field_Table.
+
+ pragma Assert (if Default_Value /= No_Default then Is_Syntactic);
+ pragma Assert (if Type_Only /= No_Type_Only then not Is_Syntactic);
+
+ -- First time this field has been seen; create an entry in the
+ -- Field_Table.
+
+ if Field_Table (Field) = null then
+ Field_Table (Field) := new Field_Info'
+ (Type_Vectors.Empty_Vector, Field_Type, Default_Value, Type_Only,
+ Pre => new String'(Pre),
+ Pre_Get => new String'(Pre_Get),
+ Pre_Set => new String'(Pre_Set),
+ Offset => <>); -- filled in later
+
+ -- The Field_Table entry has already been created by the 'then' part
+ -- above. Now we're seeing the same field being "created" again in a
+ -- different type. Here we check consistency of this new Create_Field
+ -- call with the old one.
+
+ else
+ if Field_Type /= Field_Table (Field).Field_Type then
+ raise Illegal with
+ "mismatched field types for " & Image (Field);
+ end if;
+
+ -- Check that default values for syntactic fields match. This check
+ -- could be stricter; it currently allows a field to have No_Default
+ -- in one type, but something else in another type. In that case, we
+ -- use the "something else" for all types.
+ --
+ -- Note that the order of calls does not matter; a default value
+ -- always overrides a No_Default value.
+
+ if Is_Syntactic then
+ if Default_Value /= Field_Table (Field).Default_Value then
+ if Field_Table (Field).Default_Value = No_Default then
+ Field_Table (Field).Default_Value := Default_Value;
+ else
+ raise Illegal with
+ "mismatched default values for " & Image (Field);
+ end if;
+ end if;
+ end if;
+
+ if Type_Only /= Field_Table (Field).Type_Only then
+ raise Illegal with "mismatched Type_Only for " & Image (Field);
+ end if;
+
+ if Pre /= Field_Table (Field).Pre.all then
+ raise Illegal with
+ "mismatched extra preconditions for " & Image (Field);
+ end if;
+
+ if Pre_Get /= Field_Table (Field).Pre_Get.all then
+ raise Illegal with
+ "mismatched extra getter-only preconditions for " &
+ Image (Field);
+ end if;
+
+ if Pre_Set /= Field_Table (Field).Pre_Set.all then
+ raise Illegal with
+ "mismatched extra setter-only preconditions for " &
+ Image (Field);
+ end if;
+ end if;
+
+ return (Field, Is_Syntactic);
+ end Create_Field;
+
+ ----------------------------
+ -- Create_Syntactic_Field --
+ ----------------------------
+
+ function Create_Syntactic_Field
+ (Field : Node_Field;
+ Field_Type : Type_Enum;
+ Default_Value : Field_Default_Value := No_Default;
+ Pre, Pre_Get, Pre_Set : String := "") return Field_Desc
+ is
+ begin
+ return Create_Field
+ (Field, Field_Type, Default_Value, No_Type_Only,
+ Pre, Pre_Get, Pre_Set,
+ Is_Syntactic => True);
+ end Create_Syntactic_Field;
+
+ ---------------------------
+ -- Create_Semantic_Field --
+ ---------------------------
+
+ function Create_Semantic_Field
+ (Field : Field_Enum;
+ Field_Type : Type_Enum;
+ Type_Only : Type_Only_Enum := No_Type_Only;
+ Pre, Pre_Get, Pre_Set : String := "") return Field_Desc
+ is
+ begin
+ return Create_Field
+ (Field, Field_Type, No_Default, Type_Only,
+ Pre, Pre_Get, Pre_Set,
+ Is_Syntactic => False);
+ end Create_Semantic_Field;
+
+ -----------------------
+ -- Create_Union_Type --
+ -----------------------
+
+ procedure Create_Union_Type
+ (Root : Root_Type; T : Abstract_Type; Children : Type_Array)
+ is
+ Children_Seen : Type_Set := (others => False);
+
+ begin
+ Check_Type (T);
+
+ if Children'Length <= 1 then
+ raise Illegal with Image (T) & " must have two or more children";
+ end if;
+
+ for Child of Children loop
+ if Children_Seen (Child) then
+ raise Illegal with
+ Image (T) & " has duplicate child " & Image (Child);
+ end if;
+
+ Children_Seen (Child) := True;
+
+ if Type_Table (Child) = null then
+ raise Illegal with
+ "undefined child type for " &
+ Image (T) & " (child is " & Image (Child) & ")";
+ end if;
+ end loop;
+
+ Type_Table (T) :=
+ new Type_Info'
+ (Is_Union => True, Parent => Root,
+ Children | Concrete_Descendants => Type_Vectors.Empty_Vector);
+
+ for Child of Children loop
+ Append (Type_Table (T).Children, Child);
+ end loop;
+ end Create_Union_Type;
+
+ ----------------------------
+ -- Create_Node_Union_Type --
+ ----------------------------
+
+ procedure Create_Node_Union_Type
+ (T : Abstract_Node; Children : Type_Array) is
+ begin
+ Create_Union_Type (Node_Kind, T, Children);
+ end Create_Node_Union_Type;
+
+ ------------------------------
+ -- Create_Entity_Union_Type --
+ ------------------------------
+
+ procedure Create_Entity_Union_Type
+ (T : Abstract_Entity; Children : Type_Array) is
+ begin
+ Create_Union_Type (Entity_Kind, T, Children);
+ end Create_Entity_Union_Type;
+
+ -------------
+ -- Compile --
+ -------------
+
+ procedure Compile is
+ Fields_Per_Node : Fields_Per_Node_Type := (others => (others => False));
+
+ Type_Bit_Size : array (Concrete_Type) of Bit_Offset := (others => 0);
+ Min_Node_Bit_Size : Bit_Offset := Bit_Offset'Last;
+ Max_Node_Bit_Size : Bit_Offset := 0;
+ Min_Entity_Bit_Size : Bit_Offset := Bit_Offset'Last;
+ Max_Entity_Bit_Size : Bit_Offset := 0;
+ -- Above are in units of bits; following are in units of slots:
+ Min_Node_Size : Field_Offset := Field_Offset'Last;
+ Max_Node_Size : Field_Offset := 0;
+ Min_Entity_Size : Field_Offset := Field_Offset'Last;
+ Max_Entity_Size : Field_Offset := 0;
+
+ Average_Node_Size_In_Slots : Long_Float;
+
+ Node_Field_Types_Used, Entity_Field_Types_Used : Type_Set;
+
+ Setter_Needs_Parent : Field_Set :=
+ (Actions | Expression | Then_Actions | Else_Actions => True,
+ others => False);
+ -- Set of fields where the setter should set the Parent. True for
+ -- syntactic fields of type Node_Id and List_Id, but with some
+ -- exceptions. Expression is syntactic AND semantic, and the Parent
+ -- is needed. Default_Expression is also both, but the Parent is not
+ -- needed. Then_Actions and Else_Actions are not syntactic, but the
+ -- Parent is needed.
+
+ procedure Check_Completeness;
+ -- Check that every type and field has been declared
+
+ procedure Compute_Ranges (Root : Root_Type);
+ -- Compute the range of Node_Kind/Entity_Kind values for all the types
+ -- rooted at Root. The result is stored in the First and Last components
+ -- in the Type_Table.
+
+ procedure Compute_Fields_Per_Node;
+ -- Compute which fields are in which nodes. Implements inheritance of
+ -- fields. Set the Fields component of each Type_Info to include
+ -- inherited ones. Set the Is_Syntactic component in the Type_Table to
+ -- the set of fields that are syntactic in that node kind. Set the
+ -- Fields_Per_Node table.
+
+ procedure Compute_Field_Offsets;
+ -- Compute the offsets of each field. The results are stored in the
+ -- Offset components in the Field_Table.
+
+ procedure Compute_Type_Sizes;
+ -- Compute the size of each node and entity type, which is one more than
+ -- the maximum bit offset of all fields of the type. Results are
+ -- returned in the above Type_Bit_Size and Min_.../Max_... variables.
+
+ procedure Check_For_Syntactic_Field_Mismatch;
+ -- Check that fields are either all syntactic or all semantic in all
+ -- nodes in which they exist, except for some fields that already
+ -- violate this rule.
+ --
+ -- Also sets Setter_Needs_Parent.
+
+ function Field_Types_Used (First, Last : Field_Enum) return Type_Set;
+ -- Returns the union of the types of all the fields in the range First
+ -- .. Last. Only Special_Type; if the declared type of a field is a
+ -- descendant of Node_Kind or Entity_Kind, then the low-level getter for
+ -- Node_Id can be used.
+
+ procedure Put_Seinfo;
+ -- Print out the Seinfo package, which is with'ed by both Sinfo.Nodes
+ -- and Einfo.Entities.
+
+ procedure Put_Nodes;
+ -- Print out the Sinfo.Nodes package spec and body
+
+ procedure Put_Entities;
+ -- Print out the Einfo.Entities package spec and body
+
+ procedure Put_Type_And_Subtypes
+ (S : in out Sink; Root : Root_Type);
+ -- Called by Put_Nodes and Put_Entities to print out the main type
+ -- and subtype declarations in Sinfo.Nodes and Einfo.Entities.
+
+ procedure Put_Subp_Decls (S : in out Sink; Root : Root_Type);
+ -- Called by Put_Nodes and Put_Entities to print out the subprogram
+ -- declarations in Sinfo.Nodes and Einfo.Entities.
+
+ procedure Put_Subp_Bodies (S : in out Sink; Root : Root_Type);
+ -- Called by Put_Nodes and Put_Entities to print out the subprogram
+ -- bodies in Sinfo.Nodes and Einfo.Entities.
+
+ function Node_To_Fetch_From (F : Field_Enum) return String;
+ -- Name of the Node from which a getter should fetch the value.
+ -- Normally, we fetch from the node or entity passed in (i.e. formal
+ -- parameter N). But if Type_Only was specified, we need to fetch the
+ -- corresponding base (etc) type.
+
+ procedure Put_Getter_Spec (S : in out Sink; F : Field_Enum);
+ procedure Put_Setter_Spec (S : in out Sink; F : Field_Enum);
+ procedure Put_Getter_Decl (S : in out Sink; F : Field_Enum);
+ procedure Put_Setter_Decl (S : in out Sink; F : Field_Enum);
+ procedure Put_Getter_Body (S : in out Sink; F : Field_Enum);
+ procedure Put_Setter_Body (S : in out Sink; F : Field_Enum);
+ -- Print out the specification, declaration, or body of a getter or
+ -- setter for the given field.
+
+ procedure Put_Precondition
+ (S : in out Sink; F : Field_Enum);
+ -- Print out the precondition, if any, for a getter or setter for the
+ -- given field.
+
+ procedure Put_Low_Level_Accessor_Instantiations
+ (S : in out Sink; T : Type_Enum);
+ -- Print out the low-level getter and setter for a given type
+
+ procedure Put_Traversed_Fields (S : in out Sink);
+ -- Called by Put_Nodes to print out the Traversed_Fields table in
+ -- Sinfo.Nodes.
+
+ procedure Put_Tables (S : in out Sink; Root : Root_Type);
+ -- Called by Put_Nodes and Put_Entities to print out the various tables
+ -- in Sinfo.Nodes and Einfo.Entities.
+
+ procedure Put_Nmake;
+ -- Print out the Nmake package spec and body, containing
+ -- Make_... functions for each concrete node type.
+
+ procedure Put_Make_Decls (S : in out Sink; Root : Root_Type);
+ -- Called by Put_Nmake to print out the Make_... function declarations
+
+ procedure Put_Make_Bodies (S : in out Sink; Root : Root_Type);
+ -- Called by Put_Nmake to print out the Make_... function bodies
+
+ procedure Put_Make_Spec
+ (S : in out Sink; Root : Root_Type; T : Concrete_Type);
+ -- Called by Put_Make_Decls and Put_Make_Bodies to print out the spec of
+ -- a single Make_... function.
+
+ procedure Put_Seinfo_Tables;
+ -- This puts information about both sinfo and einfo.
+ -- Not actually needed by the compiler.
+
+ procedure Put_Sinfo_Dot_H;
+ -- Print out the sinfo.h file
+
+ procedure Put_Einfo_Dot_H;
+ -- Print out the einfo.h file
+
+ procedure Put_C_Type_And_Subtypes
+ (S : in out Sink; Root : Root_Type);
+ -- Used by Put_Sinfo_Dot_H and Put_Einfo_Dot_H to print out the C code
+ -- corresponding to the Ada Node_Kind, Entity_Kind, and subtypes
+ -- thereof.
+
+ procedure Put_Low_Level_C_Getter
+ (S : in out Sink; T : Type_Enum);
+ -- Used by Put_Sinfo_Dot_H and Put_Einfo_Dot_H to print out low-level
+ -- getters.
+
+ procedure Put_High_Level_C_Getters
+ (S : in out Sink; Root : Root_Type);
+ -- Used by Put_Sinfo_Dot_H and Put_Einfo_Dot_H to print out high-level
+ -- getters.
+
+ procedure Put_High_Level_C_Getter
+ (S : in out Sink; F : Field_Enum);
+ -- Used by Put_High_Level_C_Getters to print out one high-level getter.
+
+ procedure Put_Union_Membership
+ (S : in out Sink; Root : Root_Type);
+ -- Used by Put_Sinfo_Dot_H and Put_Einfo_Dot_H to print out functions to
+ -- test membership in a union type.
+
+ ------------------------
+ -- Check_Completeness --
+ ------------------------
+
+ procedure Check_Completeness is
+ begin
+ for T in Node_Or_Entity_Type loop
+ if Type_Table (T) = null and then T not in Type_Boundaries then
+ raise Illegal with "Missing type declaration for " & Image (T);
+ end if;
+ end loop;
+
+ for F in Field_Enum loop
+ if Field_Table (F) = null
+ and then F /= Between_Node_And_Entity_Fields
+ then
+ raise Illegal with "Missing field declaration for " & Image (F);
+ end if;
+ end loop;
+ end Check_Completeness;
+
+ --------------------
+ -- Compute_Ranges --
+ --------------------
+
+ procedure Compute_Ranges (Root : Root_Type) is
+
+ procedure Do_One_Type (T : Node_Or_Entity_Type);
+ -- Compute the range for one type. Passed to Iterate_Types to process
+ -- all of them.
+
+ procedure Add_Concrete_Descendant_To_Ancestors
+ (Ancestor : Abstract_Type; Descendant : Concrete_Type);
+ -- Add Descendant to the Concrete_Descendants of each of its
+ -- ancestors.
+
+ procedure Add_Concrete_Descendant_To_Ancestors
+ (Ancestor : Abstract_Type; Descendant : Concrete_Type) is
+ begin
+ if Ancestor not in Root_Type then
+ Add_Concrete_Descendant_To_Ancestors
+ (Type_Table (Ancestor).Parent, Descendant);
+ end if;
+
+ Append (Type_Table (Ancestor).Concrete_Descendants, Descendant);
+ end Add_Concrete_Descendant_To_Ancestors;
+
+ procedure Do_One_Type (T : Node_Or_Entity_Type) is
+ begin
+ case T is
+ when Concrete_Type =>
+ pragma Annotate (Codepeer, Modified, Type_Table);
+ Type_Table (T).First := T;
+ Type_Table (T).Last := T;
+ Add_Concrete_Descendant_To_Ancestors
+ (Type_Table (T).Parent, T);
+
+ when Abstract_Type =>
+ declare
+ Children : Type_Vector renames Type_Table (T).Children;
+ begin
+ -- Ensure that an abstract type is not a leaf in the type
+ -- hierarchy.
+
+ if Is_Empty (Children) then
+ raise Illegal with Image (T) & " has no children";
+ end if;
+
+ -- We could support abstract types with only one child,
+ -- but what's the point of having such a type?
+
+ if Last_Index (Children) = 1 then
+ raise Illegal with Image (T) & " has only one child";
+ end if;
+
+ Type_Table (T).First := Type_Table (Children (1)).First;
+ Type_Table (T).Last :=
+ Type_Table (Children (Last_Index (Children))).Last;
+ end;
+
+ when Between_Abstract_Entity_And_Concrete_Node_Types =>
+ raise Program_Error;
+ end case;
+ end Do_One_Type;
+ begin
+ Iterate_Types (Root, Post => Do_One_Type'Access);
+ end Compute_Ranges;
+
+ -----------------------------
+ -- Compute_Fields_Per_Node --
+ -----------------------------
+
+ procedure Compute_Fields_Per_Node is
+
+ Duplicate_Fields_Found : Boolean := False;
+
+ function Get_Fields (T : Node_Or_Entity_Type) return Field_Vector;
+ -- Compute the fields of a given type. This is the fields inherited
+ -- from ancestors, plus the fields declared for the type itself.
+
+ function Get_Syntactic_Fields
+ (T : Node_Or_Entity_Type) return Field_Set;
+ -- Compute the set of fields that are syntactic for a given type.
+ -- Note that a field can be syntactic in some node types, but
+ -- semantic in others.
+
+ procedure Do_Concrete_Type (CT : Concrete_Type);
+ -- Do the Compute_Fields_Per_Node work for a concrete type
+
+ function Get_Fields (T : Node_Or_Entity_Type) return Field_Vector is
+ Parent_Fields : constant Field_Vector :=
+ (if T in Root_Type then Field_Vectors.Empty_Vector
+ else Get_Fields (Type_Table (T).Parent));
+ begin
+ return Parent_Fields & Type_Table (T).Fields;
+ end Get_Fields;
+
+ function Get_Syntactic_Fields
+ (T : Node_Or_Entity_Type) return Field_Set
+ is
+ Parent_Is_Syntactic : constant Field_Set :=
+ (if T in Root_Type then (Field_Enum => False)
+ else Get_Syntactic_Fields (Type_Table (T).Parent));
+ begin
+ return Parent_Is_Syntactic or Syntactic (T);
+ end Get_Syntactic_Fields;
+
+ procedure Do_Concrete_Type (CT : Concrete_Type) is
+ begin
+ Type_Table (CT).Fields := Get_Fields (CT);
+ Syntactic (CT) := Get_Syntactic_Fields (CT);
+
+ for F of Type_Table (CT).Fields loop
+ if Fields_Per_Node (CT) (F) then
+ Ada.Text_IO.Put_Line
+ ("duplicate field" & Image (CT) & Image (F));
+ Duplicate_Fields_Found := True;
+ end if;
+
+ Fields_Per_Node (CT) (F) := True;
+ end loop;
+ end Do_Concrete_Type;
+
+ begin -- Compute_Fields_Per_Node
+ for CT in Concrete_Node loop
+ Do_Concrete_Type (CT);
+ end loop;
+
+ -- The node fields defined for all three N_Entity kinds should be the
+ -- same:
+
+ if Type_Table (N_Defining_Character_Literal).Fields /=
+ Type_Table (N_Defining_Identifier).Fields
+ then
+ raise Illegal with
+ "fields for N_Defining_Identifier and " &
+ "N_Defining_Character_Literal must match";
+ end if;
+
+ if Type_Table (N_Defining_Operator_Symbol).Fields /=
+ Type_Table (N_Defining_Identifier).Fields
+ then
+ raise Illegal with
+ "fields for N_Defining_Identifier and " &
+ "N_Defining_Operator_Symbol must match";
+ end if;
+
+ if Fields_Per_Node (N_Defining_Character_Literal) /=
+ Fields_Per_Node (N_Defining_Identifier)
+ then
+ raise Illegal with
+ "Fields of N_Defining_Character_Literal must match " &
+ "N_Defining_Identifier";
+ end if;
+
+ if Fields_Per_Node (N_Defining_Operator_Symbol) /=
+ Fields_Per_Node (N_Defining_Identifier)
+ then
+ raise Illegal with
+ "Fields of N_Defining_Operator_Symbol must match " &
+ "N_Defining_Identifier";
+ end if;
+
+ -- Copy node fields from N_Entity nodes to entities, so they have
+ -- slots allocated (but the getters and setters are only in
+ -- Sinfo.Nodes).
+
+ Type_Table (Entity_Kind).Fields :=
+ Type_Table (N_Defining_Identifier).Fields &
+ Type_Table (Entity_Kind).Fields;
+
+ for CT in Concrete_Entity loop
+ Do_Concrete_Type (CT);
+ end loop;
+
+ if Duplicate_Fields_Found then
+ raise Illegal with "duplicate fields found";
+ end if;
+ end Compute_Fields_Per_Node;
+
+ function Field_Size (T : Type_Enum) return Bit_Offset is
+ (case T is
+ when Flag => 1,
+
+ when Small_Paren_Count_Type | Component_Alignment_Kind => 2,
+
+ when Node_Kind_Type | Entity_Kind_Type | Convention_Id => 8,
+
+ when Mechanism_Type
+ | List_Id
+ | Elist_Id
+ | Name_Id
+ | String_Id
+ | Uint
+ | Uint_Subtype
+ | Ureal
+ | Source_Ptr
+ | Union_Id
+ | Node_Id
+ | Node_Or_Entity_Type => 32,
+
+ when Between_Special_And_Abstract_Node_Types => -- can't happen
+ Bit_Offset'Last);
+ -- Size in bits of a a field of type T. It must be a power of 2, and
+ -- must match the size of the type in GNAT, which sometimes requires
+ -- a Size clause in GNAT.
+ --
+ -- Note that this is not the same as Type_Bit_Size of the field's
+ -- type. For one thing, Type_Bit_Size only covers concrete node and
+ -- entity types, which does not include most of the above. For
+ -- another thing, Type_Bit_Size includes the full size of all the
+ -- fields, whereas a field of a node or entity type is just a 32-bit
+ -- Node_Id or Entity_Id; i.e. it is indirect.
+
+ function Field_Size (F : Field_Enum) return Bit_Offset is
+ (Field_Size (Field_Table (F).Field_Type));
+
+ function To_Bit_Offset (F : Field_Enum; Offset : Field_Offset'Base)
+ return Bit_Offset'Base is
+ (Bit_Offset'Base (Offset) * Field_Size (F));
+ function First_Bit (F : Field_Enum; Offset : Field_Offset)
+ return Bit_Offset is
+ (To_Bit_Offset (F, Offset));
+ function Last_Bit (F : Field_Enum; Offset : Field_Offset)
+ return Bit_Offset is
+ (To_Bit_Offset (F, Offset + 1) - 1);
+
+ function To_Size_In_Slots (Size_In_Bits : Bit_Offset)
+ return Field_Offset is
+ ((Field_Offset (Size_In_Bits) + 31) / 32);
+
+ function Type_Size_In_Slots (T : Concrete_Type) return Field_Offset is
+ (To_Size_In_Slots (Type_Bit_Size (T))); -- rounded up to slot boundary
+
+ function Type_Bit_Size_Aligned (T : Concrete_Type) return Bit_Offset is
+ (Bit_Offset (Type_Size_In_Slots (T)) * 32); -- multiple of slot size
+
+ ---------------------------
+ -- Compute_Field_Offsets --
+ ---------------------------
+
+ procedure Compute_Field_Offsets is
+ type Offset_Set_Unconstrained is array (Bit_Offset range <>)
+ of Boolean with Pack;
+ subtype Offset_Set is Offset_Set_Unconstrained (Bit_Offset);
+ Offset_Sets : array (Concrete_Type) of Offset_Set :=
+ (others => (others => False));
+
+ function All_False
+ (F : Field_Enum; Offset : Field_Offset)
+ return Offset_Set_Unconstrained is
+ (First_Bit (F, Offset) .. Last_Bit (F, Offset) => False);
+
+ function All_True
+ (F : Field_Enum; Offset : Field_Offset)
+ return Offset_Set_Unconstrained is
+ (First_Bit (F, Offset) .. Last_Bit (F, Offset) => True);
+
+ function Offset_OK
+ (F : Field_Enum; Offset : Field_Offset) return Boolean;
+ -- True if it is OK to choose this offset; that is, if this offset is
+ -- not in use for any type that has the field. If Overlay_Fields is
+ -- False, then "any type that has the field" --> "any type, whether
+ -- or not it has the field".
+
+ procedure Set_Offset_In_Use
+ (F : Field_Enum; Offset : Field_Offset);
+ -- Mark the offset as "in use"
+
+ function Choose_Offset
+ (F : Field_Enum) return Field_Offset;
+ -- Choose an offset for this field
+
+ function Offset_OK
+ (F : Field_Enum; Offset : Field_Offset) return Boolean is
+ begin
+ for T in Concrete_Type loop
+ if Fields_Per_Node (T) (F) or else not Overlay_Fields then
+ declare
+ Bits : Offset_Set_Unconstrained renames
+ Offset_Sets (T)
+ (First_Bit (F, Offset) .. Last_Bit (F, Offset));
+ begin
+ if Bits /= All_False (F, Offset) then
+ return False;
+ end if;
+ end;
+ end if;
+ end loop;
+
+ return True;
+ end Offset_OK;
+
+ procedure Set_Offset_In_Use
+ (F : Field_Enum; Offset : Field_Offset) is
+ begin
+ for T in Concrete_Type loop
+ if Fields_Per_Node (T) (F) then
+ declare
+ Bits : Offset_Set_Unconstrained renames
+ Offset_Sets (T)
+ (First_Bit (F, Offset) .. Last_Bit (F, Offset));
+ begin
+ pragma Assert (Bits = All_False (F, Offset));
+ Bits := All_True (F, Offset);
+ end;
+ end if;
+ end loop;
+ end Set_Offset_In_Use;
+
+ function Choose_Offset
+ (F : Field_Enum) return Field_Offset is
+ begin
+ for Offset in Field_Offset loop
+ if Offset_OK (F, Offset) then
+ Set_Offset_In_Use (F, Offset);
+
+ return Offset;
+ end if;
+ end loop;
+
+ raise Illegal with "No available field offset for " & Image (F) &
+ "; need to increase Gen_IL.Internals.Bit_Offset'Last (" &
+ Image (Gen_IL.Internals.Bit_Offset'Last) & " is too small)";
+ end Choose_Offset;
+
+ Num_Concrete_Have_Field : array (Field_Enum) of Type_Count :=
+ (others => 0);
+ -- Number of concrete types that have each field
+
+ function More_Types_Have_Field (F1, F2 : Field_Enum) return Boolean is
+ (Num_Concrete_Have_Field (F1) > Num_Concrete_Have_Field (F2));
+ -- True if F1 appears in more concrete types than F2
+
+ function Sort_Less (F1, F2 : Field_Enum) return Boolean is
+ (if Num_Concrete_Have_Field (F1) = Num_Concrete_Have_Field (F2) then
+ F1 < F2
+ else More_Types_Have_Field (F1, F2));
+
+ package Sorting is new Field_Vectors.Generic_Sorting
+ ("<" => Sort_Less);
+
+ All_Fields : Field_Vector;
+
+ begin
+
+ -- Compute the number of types that have each field
+
+ for T in Concrete_Type loop
+ for F in Field_Enum loop
+ if Fields_Per_Node (T) (F) then
+ Num_Concrete_Have_Field (F) :=
+ Num_Concrete_Have_Field (F) + 1;
+ end if;
+ end loop;
+ end loop;
+
+ -- Collect all the fields in All_Fields
+
+ for F in Node_Field loop
+ Append (All_Fields, F);
+ end loop;
+
+ for F in Entity_Field loop
+ Append (All_Fields, F);
+ end loop;
+
+ -- Sort All_Fields based on how many concrete types have the field.
+ -- This is for efficiency; we want to choose the offsets of the most
+ -- common fields first, so they get low numbers.
+
+ Sorting.Sort (All_Fields);
+
+ -- Go through all the fields, and choose the lowest offset that is
+ -- free in all types that have the field. This is basically a
+ -- graph-coloring algorithm on the interference graph. The
+ -- interference graph is an undirected graph with the fields being
+ -- nodes (not nodes in the compiler!) in the graph, and an edge
+ -- between a pair of fields if they appear in the same node in the
+ -- compiler. The "colors" are fields offsets, except that a
+ -- complication compared to standard graph coloring is that fields
+ -- are different sizes.
+
+ for F of All_Fields loop
+ Field_Table (F).Offset := Choose_Offset (F);
+ end loop;
+
+ end Compute_Field_Offsets;
+
+ ------------------------
+ -- Compute_Type_Sizes --
+ ------------------------
+
+ procedure Compute_Type_Sizes is
+ -- Node_Counts is the number of nodes of each kind created during
+ -- compilation of a large example. This is used purely to compute an
+ -- estimate of the average node size. New node types can default to
+ -- "others => 0". At some point we can instrument Atree to print out
+ -- accurate size statistics, and remove this code.
+
+ Node_Counts : constant array (Concrete_Node) of Natural :=
+ (N_Identifier => 429298,
+ N_Defining_Identifier => 231636,
+ N_Integer_Literal => 90892,
+ N_Parameter_Specification => 62811,
+ N_Attribute_Reference => 47150,
+ N_Expanded_Name => 37375,
+ N_Selected_Component => 30699,
+ N_Subprogram_Declaration => 20744,
+ N_Freeze_Entity => 20314,
+ N_Procedure_Specification => 18901,
+ N_Object_Declaration => 18023,
+ N_Function_Specification => 16570,
+ N_Range => 16216,
+ N_Explicit_Dereference => 12198,
+ N_Component_Association => 11188,
+ N_Unchecked_Type_Conversion => 11165,
+ N_Subtype_Indication => 10727,
+ N_Procedure_Call_Statement => 10056,
+ N_Subtype_Declaration => 8141,
+ N_Handled_Sequence_Of_Statements => 8078,
+ N_Null => 7288,
+ N_Aggregate => 7222,
+ N_String_Literal => 7152,
+ N_Function_Call => 6958,
+ N_Simple_Return_Statement => 6911,
+ N_And_Then => 6867,
+ N_Op_Eq => 6845,
+ N_Call_Marker => 6683,
+ N_Pragma_Argument_Association => 6525,
+ N_Component_Definition => 6487,
+ N_Assignment_Statement => 6483,
+ N_With_Clause => 6480,
+ N_Null_Statement => 5917,
+ N_Index_Or_Discriminant_Constraint => 5877,
+ N_Generic_Association => 5667,
+ N_Full_Type_Declaration => 5573,
+ N_If_Statement => 5553,
+ N_Subprogram_Body => 5455,
+ N_Op_Add => 5443,
+ N_Type_Conversion => 5260,
+ N_Component_Declaration => 5059,
+ N_Raise_Constraint_Error => 4840,
+ N_Formal_Concrete_Subprogram_Declaration => 4602,
+ N_Expression_With_Actions => 4598,
+ N_Op_Ne => 3854,
+ N_Indexed_Component => 3834,
+ N_Op_Subtract => 3777,
+ N_Package_Specification => 3490,
+ N_Subprogram_Renaming_Declaration => 3445,
+ N_Pragma => 3427,
+ N_Case_Statement_Alternative => 3272,
+ N_Block_Statement => 3239,
+ N_Parameter_Association => 3213,
+ N_Op_Lt => 3020,
+ N_Op_Not => 2926,
+ N_Character_Literal => 2914,
+ N_Others_Choice => 2769,
+ N_Or_Else => 2576,
+ N_Itype_Reference => 2511,
+ N_Defining_Operator_Symbol => 2487,
+ N_Component_List => 2470,
+ N_Formal_Object_Declaration => 2262,
+ N_Generic_Subprogram_Declaration => 2227,
+ N_Real_Literal => 2156,
+ N_Op_Gt => 2156,
+ N_Access_To_Object_Definition => 1984,
+ N_Op_Le => 1975,
+ N_Op_Ge => 1942,
+ N_Package_Renaming_Declaration => 1811,
+ N_Formal_Type_Declaration => 1756,
+ N_Qualified_Expression => 1746,
+ N_Package_Declaration => 1729,
+ N_Record_Definition => 1651,
+ N_Allocator => 1521,
+ N_Op_Concat => 1377,
+ N_Access_Definition => 1358,
+ N_Case_Statement => 1322,
+ N_Number_Declaration => 1316,
+ N_Generic_Package_Declaration => 1311,
+ N_Slice => 1078,
+ N_Constrained_Array_Definition => 1068,
+ N_Exception_Renaming_Declaration => 1011,
+ N_Implicit_Label_Declaration => 978,
+ N_Exception_Handler => 966,
+ N_Private_Type_Declaration => 898,
+ N_Operator_Symbol => 872,
+ N_Formal_Private_Type_Definition => 867,
+ N_Range_Constraint => 849,
+ N_Aspect_Specification => 837,
+ N_Variant => 834,
+ N_Discriminant_Specification => 746,
+ N_Loop_Statement => 744,
+ N_Derived_Type_Definition => 731,
+ N_Freeze_Generic_Entity => 702,
+ N_Iteration_Scheme => 686,
+ N_Package_Instantiation => 658,
+ N_Loop_Parameter_Specification => 632,
+ N_Attribute_Definition_Clause => 608,
+ N_Compilation_Unit_Aux => 599,
+ N_Compilation_Unit => 599,
+ N_Label => 572,
+ N_Goto_Statement => 572,
+ N_In => 564,
+ N_Enumeration_Type_Definition => 523,
+ N_Object_Renaming_Declaration => 482,
+ N_If_Expression => 476,
+ N_Exception_Declaration => 472,
+ N_Reference => 455,
+ N_Incomplete_Type_Declaration => 438,
+ N_Use_Package_Clause => 401,
+ N_Unconstrained_Array_Definition => 360,
+ N_Variant_Part => 340,
+ N_Defining_Program_Unit_Name => 336,
+ N_Op_And => 334,
+ N_Raise_Program_Error => 329,
+ N_Formal_Discrete_Type_Definition => 319,
+ N_Contract => 311,
+ N_Not_In => 305,
+ N_Designator => 285,
+ N_Component_Clause => 247,
+ N_Formal_Signed_Integer_Type_Definition => 244,
+ N_Raise_Statement => 214,
+ N_Op_Expon => 205,
+ N_Op_Minus => 202,
+ N_Op_Multiply => 158,
+ N_Exit_Statement => 130,
+ N_Function_Instantiation => 129,
+ N_Discriminant_Association => 123,
+ N_Private_Extension_Declaration => 119,
+ N_Extended_Return_Statement => 117,
+ N_Op_Divide => 107,
+ N_Op_Or => 103,
+ N_Signed_Integer_Type_Definition => 101,
+ N_Record_Representation_Clause => 76,
+ N_Unchecked_Expression => 70,
+ N_Op_Abs => 63,
+ N_Elsif_Part => 62,
+ N_Formal_Floating_Point_Definition => 59,
+ N_Formal_Package_Declaration => 58,
+ N_Modular_Type_Definition => 55,
+ N_Abstract_Subprogram_Declaration => 52,
+ N_Validate_Unchecked_Conversion => 49,
+ N_Defining_Character_Literal => 36,
+ N_Raise_Storage_Error => 33,
+ N_Compound_Statement => 29,
+ N_Procedure_Instantiation => 28,
+ N_Access_Procedure_Definition => 25,
+ N_Floating_Point_Definition => 20,
+ N_Use_Type_Clause => 19,
+ N_Op_Plus => 14,
+ N_Package_Body => 13,
+ N_Op_Rem => 13,
+ N_Enumeration_Representation_Clause => 13,
+ N_Access_Function_Definition => 11,
+ N_Extension_Aggregate => 11,
+ N_Formal_Ordinary_Fixed_Point_Definition => 10,
+ N_Op_Mod => 10,
+ N_Expression_Function => 9,
+ N_Delay_Relative_Statement => 9,
+ N_Quantified_Expression => 7,
+ N_Formal_Derived_Type_Definition => 7,
+ N_Free_Statement => 7,
+ N_Iterator_Specification => 5,
+ N_Op_Shift_Left => 5,
+ N_Formal_Modular_Type_Definition => 4,
+ N_Generic_Package_Renaming_Declaration => 1,
+ N_Empty => 1,
+ N_Real_Range_Specification => 1,
+ N_Ordinary_Fixed_Point_Definition => 1,
+ N_Op_Shift_Right => 1,
+ N_Error => 1,
+ N_Mod_Clause => 1,
+ others => 0);
+
+ Total_Node_Count : constant Long_Float := 1370676.0;
+
+ type Node_Frequency_Table is array (Concrete_Node) of Long_Float;
+
+ function Init_Node_Frequency return Node_Frequency_Table;
+ -- Compute the value of the Node_Frequency table
+
+ function Average_Type_Size_In_Slots return Long_Float;
+ -- Compute the average over all concrete node types of the size,
+ -- weighted by the frequency of that node type.
+
+ function Init_Node_Frequency return Node_Frequency_Table is
+ Result : Node_Frequency_Table := (others => 0.0);
+
+ begin
+ for T in Concrete_Node loop
+ Result (T) := Long_Float (Node_Counts (T)) / Total_Node_Count;
+ end loop;
+
+ return Result;
+ end Init_Node_Frequency;
+
+ Node_Frequency : constant Node_Frequency_Table := Init_Node_Frequency;
+ -- Table mapping concrete node types to the relative frequency of
+ -- that node, in our large example. The sum of these values should
+ -- add up to approximately 1.0. For example, if Node_Frequency(K) =
+ -- 0.02, then that means that approximately 2% of all nodes are K
+ -- nodes.
+
+ function Average_Type_Size_In_Slots return Long_Float is
+ -- We don't have data on entities, so we leave those out
+
+ Result : Long_Float := 0.0;
+ begin
+ for T in Concrete_Node loop
+ Result := Result +
+ Node_Frequency (T) * Long_Float (Type_Size_In_Slots (T));
+ end loop;
+
+ return Result;
+ end Average_Type_Size_In_Slots;
+
+ -- Start of processing for Compute_Type_Sizes
+
+ begin
+ for T in Concrete_Type loop
+ declare
+ Max_Offset : Bit_Offset := 0;
+
+ begin
+ for F in Field_Enum loop
+ if Fields_Per_Node (T) (F) then
+ Max_Offset :=
+ Bit_Offset'Max
+ (Max_Offset,
+ To_Bit_Offset (F, Field_Table (F).Offset));
+ end if;
+ end loop;
+
+ Type_Bit_Size (T) := Max_Offset + 1;
+ end;
+ end loop;
+
+ for T in Concrete_Node loop
+ Min_Node_Bit_Size :=
+ Bit_Offset'Min (Min_Node_Bit_Size, Type_Bit_Size (T));
+ Max_Node_Bit_Size :=
+ Bit_Offset'Max (Max_Node_Bit_Size, Type_Bit_Size (T));
+ end loop;
+
+ for T in Concrete_Entity loop
+ Min_Entity_Bit_Size :=
+ Bit_Offset'Min (Min_Entity_Bit_Size, Type_Bit_Size (T));
+ Max_Entity_Bit_Size :=
+ Bit_Offset'Max (Max_Entity_Bit_Size, Type_Bit_Size (T));
+ end loop;
+
+ Min_Node_Size := To_Size_In_Slots (Min_Node_Bit_Size);
+ Max_Node_Size := To_Size_In_Slots (Max_Node_Bit_Size);
+ Min_Entity_Size := To_Size_In_Slots (Min_Entity_Bit_Size);
+ Max_Entity_Size := To_Size_In_Slots (Max_Entity_Bit_Size);
+
+ Average_Node_Size_In_Slots := Average_Type_Size_In_Slots;
+ end Compute_Type_Sizes;
+
+ ----------------------------------------
+ -- Check_For_Syntactic_Field_Mismatch --
+ ----------------------------------------
+
+ procedure Check_For_Syntactic_Field_Mismatch is
+ begin
+ for F in Field_Enum loop
+ if F /= Between_Node_And_Entity_Fields then
+ declare
+ Syntactic_Seen, Semantic_Seen : Boolean := False;
+ Have_Field : Type_Vector renames
+ Field_Table (F).Have_This_Field;
+
+ begin
+ for J in 1 .. Last_Index (Have_Field) loop
+ if Syntactic (Have_Field (J)) (F) then
+ Syntactic_Seen := True;
+ else
+ Semantic_Seen := True;
+ end if;
+ end loop;
+
+ -- The following fields violate this rule. We might want to
+ -- simplify by getting rid of these cases, but we allow them
+ -- for now. At least, we don't want to add any new cases of
+ -- syntactic/semantic mismatch.
+
+ if F in Chars | Actions | Expression | Default_Expression
+ then
+ pragma Assert (Syntactic_Seen and Semantic_Seen);
+
+ else
+ if Syntactic_Seen and Semantic_Seen then
+ raise Illegal with
+ "syntactic/semantic mismatch for " & Image (F);
+ end if;
+
+ if Field_Table (F).Field_Type in Traversed_Field_Type
+ and then Syntactic_Seen
+ then
+ Setter_Needs_Parent (F) := True;
+ end if;
+ end if;
+ end;
+ end if;
+ end loop;
+ end Check_For_Syntactic_Field_Mismatch;
+
+ ----------------------
+ -- Field_Types_Used --
+ ----------------------
+
+ function Field_Types_Used (First, Last : Field_Enum) return Type_Set is
+ Result : Type_Set := (others => False);
+ begin
+ for F in First .. Last loop
+ if Field_Table (F).Field_Type in Node_Or_Entity_Type then
+ Result (Node_Id) := True;
+ else
+ Result (Field_Table (F).Field_Type) := True;
+ end if;
+ end loop;
+
+ return Result;
+ end Field_Types_Used;
+
+ pragma Style_Checks ("M120");
+ -- Lines of the form Put (S, "..."); are more readable if we relax the
+ -- line length. We really just want the "..." to be short enough.
+
+ ---------------------------
+ -- Put_Type_And_Subtypes --
+ ---------------------------
+
+ procedure Put_Type_And_Subtypes
+ (S : in out Sink; Root : Root_Type)
+ is
+
+ procedure Put_Enum_Type;
+ -- Print out the enumeration type declaration for a root type
+ -- (Node_Kind or Entity_Kind).
+
+ procedure Put_Kind_Subtype (T : Node_Or_Entity_Type);
+ -- Print out a subrange (of type Node_Kind or Entity_Kind) for a
+ -- given nonroot abstract type.
+
+ procedure Put_Id_Subtype (T : Node_Or_Entity_Type);
+ -- Print out a subtype (of type Node_Id or Entity_Id) for a given
+ -- nonroot abstract type.
+
+ procedure Put_Enum_Type is
+ procedure Put_Enum_Lit (T : Node_Or_Entity_Type);
+ -- Print out one enumeration literal in the declaration of
+ -- Node_Kind or Entity_Kind.
+
+ First_Time : Boolean := True;
+
+ procedure Put_Enum_Lit (T : Node_Or_Entity_Type) is
+ begin
+ if T in Concrete_Type then
+ if First_Time then
+ First_Time := False;
+ else
+ Put (S, "," & LF);
+ end if;
+
+ Put (S, Image (T));
+ end if;
+ end Put_Enum_Lit;
+
+ type Dummy is array
+ (First_Concrete (Root) .. Last_Concrete (Root)) of Boolean;
+ Num_Types : constant Root_Int := Dummy'Length;
+
+ begin
+ Put (S, "type " & Image (Root) & " is -- " &
+ Image (Num_Types) & " " & Image (Root) & "s" & LF);
+ Increase_Indent (S, 2);
+ Put (S, "(");
+ Increase_Indent (S, 1);
+ Iterate_Types (Root, Pre => Put_Enum_Lit'Access);
+ Decrease_Indent (S, 1);
+ Put (S, LF & ") with Size => 8; -- " & Image (Root) & LF & LF);
+ Decrease_Indent (S, 2);
+ end Put_Enum_Type;
+
+ procedure Put_Kind_Subtype (T : Node_Or_Entity_Type) is
+ begin
+ if T in Abstract_Type then
+ if Type_Table (T).Is_Union then
+ pragma Assert (Type_Table (T).Parent = Root);
+
+ Put (S, "subtype " & Image (T) & " is" & LF);
+ Increase_Indent (S, 2);
+ Put (S, Image (Root) & " with Predicate =>" & LF);
+ Increase_Indent (S, 2);
+ Put (S, Image (T) & " in" & LF);
+ Put_Types_With_Bars (S, Type_Table (T).Children);
+ Decrease_Indent (S, 2);
+ Put (S, ";" & LF);
+ Decrease_Indent (S, 2);
+
+ elsif Type_Table (T).Parent /= No_Type then
+ Put (S, "subtype " & Image (T) & " is " &
+ Image (Type_Table (T).Parent) & " range" & LF);
+ Increase_Indent (S, 2);
+ Put (S, Image (Type_Table (T).First) & " .. " &
+ Image (Type_Table (T).Last) & ";" & LF);
+ Decrease_Indent (S, 2);
+
+ Increase_Indent (S, 3);
+
+ for J in 1 .. Type_Table (T).Concrete_Descendants.Last_Index loop
+ Put (S, "-- " &
+ Image (Type_Table (T).Concrete_Descendants (J)) & LF);
+ end loop;
+
+ Decrease_Indent (S, 3);
+ end if;
+ end if;
+ end Put_Kind_Subtype;
+
+ procedure Put_Id_Subtype (T : Node_Or_Entity_Type) is
+ begin
+ if Type_Table (T).Parent /= No_Type then
+ Put (S, "subtype " & Id_Image (T) & " is" & LF);
+ Increase_Indent (S, 2);
+ Put (S, Id_Image (Type_Table (T).Parent));
+
+ if Enable_Assertions then
+ Put (S, " with Predicate =>" & LF);
+ Increase_Indent (S, 2);
+ Put (S, "K (" & Id_Image (T) & ") in " & Image (T));
+ Decrease_Indent (S, 2);
+ end if;
+
+ Put (S, ";" & LF);
+ Decrease_Indent (S, 2);
+ end if;
+ end Put_Id_Subtype;
+
+ begin -- Put_Type_And_Subtypes
+ Put_Enum_Type;
+
+ -- Put the getter for Nkind and Ekind here, earlier than the other
+ -- getters, because it is needed in predicates of the following
+ -- subtypes.
+
+ case Root is
+ when Node_Kind =>
+ Put_Getter_Decl (S, Nkind);
+ Put (S, "function K (N : Node_Id) return Node_Kind renames Nkind;" & LF);
+ Put (S, "-- Shorthand for use in predicates and preconditions below" & LF);
+ Put (S, "-- There is no procedure Set_Nkind." & LF);
+ Put (S, "-- See Init_Nkind and Mutate_Nkind in Atree." & LF & LF);
+
+ when Entity_Kind =>
+ Put_Getter_Decl (S, Ekind);
+ Put (S, "function K (N : Entity_Id) return Entity_Kind renames Ekind;" & LF);
+ Put (S, "-- Shorthand for use in predicates and preconditions below" & LF);
+ Put (S, "-- There is no procedure Set_Ekind here." & LF);
+ Put (S, "-- See Mutate_Ekind in Atree." & LF & LF);
+
+ when others => raise Program_Error;
+ end case;
+
+ Put (S, "-- Subtypes of " & Image (Root) & " for each abstract type:" & LF & LF);
+
+ Put (S, "pragma Style_Checks (""M200"");" & LF);
+ Iterate_Types (Root, Pre => Put_Kind_Subtype'Access);
+
+ Put (S, LF & "-- Subtypes of " & Id_Image (Root) &
+ " with specified " & Image (Root) & "." & LF);
+ Put (S, "-- These may be used in place of " & Id_Image (Root) &
+ " for better documentation," & LF);
+ Put (S, "-- and if assertions are enabled, for run-time checking." & LF & LF);
+
+ Iterate_Types (Root, Pre => Put_Id_Subtype'Access);
+
+ Put (S, LF & "-- Union types (nonhierarchical subtypes of " &
+ Id_Image (Root) & ")" & LF & LF);
+
+ for T in First_Abstract (Root) .. Last_Abstract (Root) loop
+ if Type_Table (T) /= null and then Type_Table (T).Is_Union then
+ Put_Kind_Subtype (T);
+ Put_Id_Subtype (T);
+ end if;
+ end loop;
+
+ Put (S, "subtype Flag is Boolean;" & LF & LF);
+ end Put_Type_And_Subtypes;
+
+ function Low_Level_Getter_Name (T : Type_Enum) return String is
+ ("Get_" & Image (T));
+ function Low_Level_Setter_Name (T : Type_Enum) return String is
+ ("Set_" & Image (T));
+ function Low_Level_Setter_Name (F : Field_Enum) return String is
+ (Low_Level_Setter_Name (Field_Table (F).Field_Type) &
+ (if Setter_Needs_Parent (F) then "_With_Parent" else ""));
+
+ -------------------------------------------
+ -- Put_Low_Level_Accessor_Instantiations --
+ -------------------------------------------
+
+ procedure Put_Low_Level_Accessor_Instantiations
+ (S : in out Sink; T : Type_Enum)
+ is
+ begin
+ -- Special case for subtypes of Uint that have predicates. Use
+ -- Get_Valid_32_Bit_Field in that case.
+
+ if T in Uint_Subtype then
+ pragma Assert (Field_Size (T) = 32);
+ Put (S, LF & "function " & Low_Level_Getter_Name (T) &
+ " is new Get_Valid_32_Bit_Field (" &
+ Get_Set_Id_Image (T) &
+ ") with " & Inline & ";" & LF);
+
+ -- Special case for types that have special defaults; instantiate
+ -- Get_32_Bit_Field_With_Default and pass in the Default_Val.
+
+ elsif Field_Has_Special_Default (T) then
+ pragma Assert (Field_Size (T) = 32);
+ Put (S, LF & "function " & Low_Level_Getter_Name (T) &
+ " is new Get_32_Bit_Field_With_Default (" &
+ Get_Set_Id_Image (T) & ", " & Special_Default (T) &
+ ") with " & Inline & ";" & LF);
+
+ -- Otherwise, instantiate the normal getter for the right size in
+ -- bits.
+
+ else
+ Put (S, LF & "function " & Low_Level_Getter_Name (T) &
+ " is new Get_" & Image (Field_Size (T)) & "_Bit_Field (" &
+ Get_Set_Id_Image (T) & ") with " & Inline & ";" & LF);
+ end if;
+
+ if T in Node_Kind_Type | Entity_Kind_Type then
+ Put (S, "pragma Warnings (Off);" & LF);
+ -- Set_Node_Kind_Type and Set_Entity_Kind_Type might not be called
+ end if;
+
+ -- No special cases for the setter
+
+ Put (S, "procedure " & Low_Level_Setter_Name (T) & " is new Set_" &
+ Image (Field_Size (T)) & "_Bit_Field (" & Get_Set_Id_Image (T) &
+ ") with " & Inline & ";" & LF);
+
+ if T in Node_Kind_Type | Entity_Kind_Type then
+ Put (S, "pragma Warnings (On);" & LF);
+ end if;
+ end Put_Low_Level_Accessor_Instantiations;
+
+ ----------------------
+ -- Put_Precondition --
+ ----------------------
+
+ procedure Put_Precondition
+ (S : in out Sink; F : Field_Enum)
+ is
+ -- If the field is present in all entities, we want to assert that
+ -- N in N_Entity_Id. If the field is present in only some entities,
+ -- we don't need that, because we are fetching Ekind in that case,
+ -- which will assert N in N_Entity_Id.
+
+ Is_Entity : constant String :=
+ (if Field_Table (F).Have_This_Field = All_Entities then
+ "N in N_Entity_Id"
+ else "");
+ begin
+ -- If this is an entity field, then we should assert that N is an
+ -- entity. We need "N in A | B | ..." unless this is embodied in a
+ -- subtype predicate.
+ --
+ -- We can't put the extra "Pre => ..." specified on the call to
+ -- Create_..._Field as part of the precondition, because some of
+ -- them call things that are not visible here.
+
+ if Enable_Assertions then
+ if Length (Field_Table (F).Have_This_Field) = 1
+ or else Field_Table (F).Have_This_Field = Nodes_And_Entities
+ then
+ if Is_Entity /= "" then
+ Increase_Indent (S, 1);
+ Put (S, ", Pre =>" & LF);
+ Put (S, Is_Entity);
+ Decrease_Indent (S, 1);
+ end if;
+
+ else
+ Put (S, ", Pre =>" & LF);
+ Increase_Indent (S, 1);
+ Put (S, "N in ");
+ Put_Type_Ids_With_Bars (S, Field_Table (F).Have_This_Field);
+
+ pragma Assert (Is_Entity = "");
+
+ Decrease_Indent (S, 1);
+ end if;
+ end if;
+ end Put_Precondition;
+
+ function Root_Type_For_Field (F : Field_Enum) return Root_Type is
+ (case F is
+ when Node_Field => Node_Kind,
+ when Entity_Field => Entity_Kind,
+ when Between_Node_And_Entity_Fields => Node_Kind); -- can't happen
+
+ function N_Type (F : Field_Enum) return String is
+ (if Length (Field_Table (F).Have_This_Field) = 1 then
+ Id_Image (Field_Table (F).Have_This_Field (1))
+ else Id_Image (Root_Type_For_Field (F)));
+ -- Name of the parameter type of the N parameter of the getter and
+ -- setter for field F. If there's only one Have_This_Field, use that;
+ -- the predicate will check for the right Kind. Otherwise, we use
+ -- Node_Id or Entity_Id, and the getter and setter will have
+ -- preconditions.
+
+ ------------------------
+ -- Node_To_Fetch_From --
+ ------------------------
+
+ function Node_To_Fetch_From (F : Field_Enum) return String is
+ begin
+ return
+ (case Field_Table (F).Type_Only is
+ when No_Type_Only => "N",
+ when Base_Type_Only => "Base_Type (N)",
+ when Impl_Base_Type_Only => "Implementation_Base_Type (N)",
+ when Root_Type_Only => "Root_Type (N)");
+ end Node_To_Fetch_From;
+
+ ---------------------
+ -- Put_Getter_Spec --
+ ---------------------
+
+ procedure Put_Getter_Spec (S : in out Sink; F : Field_Enum) is
+ begin
+ Put (S, "function " & Image (F));
+ Put (S, " (N : " & N_Type (F) & ") return " &
+ Get_Set_Id_Image (Field_Table (F).Field_Type));
+ end Put_Getter_Spec;
+
+ ---------------------
+ -- Put_Getter_Decl --
+ ---------------------
+
+ procedure Put_Getter_Decl (S : in out Sink; F : Field_Enum) is
+ begin
+ Put_Getter_Spec (S, F);
+ Put (S, " with " & Inline);
+ Increase_Indent (S, 2);
+ Put_Precondition (S, F);
+
+ Decrease_Indent (S, 2);
+ Put (S, ";" & LF);
+ end Put_Getter_Decl;
+
+ ---------------------
+ -- Put_Getter_Body --
+ ---------------------
+
+ procedure Put_Getter_Body (S : in out Sink; F : Field_Enum) is
+ Rec : Field_Info renames Field_Table (F).all;
+ begin
+ -- Note that we store the result in a local constant below, so that
+ -- the "Pre => ..." can refer to it. The constant is called Val so
+ -- that it has the same name as the formal of the setter, so the
+ -- "Pre => ..." can refer to it by the same name in both getter
+ -- and setter.
+
+ Put_Getter_Spec (S, F);
+ Put (S, " is" & LF);
+ Increase_Indent (S, 3);
+ Put (S, "Val : constant " & Get_Set_Id_Image (Rec.Field_Type) &
+ " := " & Low_Level_Getter_Name (Rec.Field_Type) &
+ " (" & Node_To_Fetch_From (F) & ", " &
+ Image (Rec.Offset) & ");" & LF);
+ Decrease_Indent (S, 3);
+ Put (S, "begin" & LF);
+ Increase_Indent (S, 3);
+
+ if Rec.Pre.all /= "" then
+ Put (S, "pragma Assert (" & Rec.Pre.all & ");" & LF);
+ end if;
+
+ if Rec.Pre_Get.all /= "" then
+ Put (S, "pragma Assert (" & Rec.Pre_Get.all & ");" & LF);
+ end if;
+
+ Put (S, "return Val;" & LF);
+ Decrease_Indent (S, 3);
+ Put (S, "end " & Image (F) & ";" & LF & LF);
+ end Put_Getter_Body;
+
+ ---------------------
+ -- Put_Setter_Spec --
+ ---------------------
+
+ procedure Put_Setter_Spec (S : in out Sink; F : Field_Enum) is
+ Rec : Field_Info renames Field_Table (F).all;
+ Default : constant String :=
+ (if Rec.Field_Type = Flag then " := True" else "");
+ begin
+ Put (S, "procedure Set_" & Image (F));
+ Put (S, " (N : " & N_Type (F) & "; Val : " &
+ Get_Set_Id_Image (Rec.Field_Type) & Default & ")");
+ end Put_Setter_Spec;
+
+ ---------------------
+ -- Put_Setter_Decl --
+ ---------------------
+
+ procedure Put_Setter_Decl (S : in out Sink; F : Field_Enum) is
+ begin
+ Put_Setter_Spec (S, F);
+ Put (S, " with " & Inline);
+ Increase_Indent (S, 2);
+ Put_Precondition (S, F);
+ Decrease_Indent (S, 2);
+ Put (S, ";" & LF);
+ end Put_Setter_Decl;
+
+ ---------------------
+ -- Put_Setter_Body --
+ ---------------------
+
+ procedure Put_Setter_Body (S : in out Sink; F : Field_Enum) is
+ Rec : Field_Info renames Field_Table (F).all;
+
+ -- If Type_Only was specified in the call to Create_Semantic_Field,
+ -- then we assert that the node is a base type. We cannot assert that
+ -- it is an implementation base type or a root type.
+
+ Type_Only_Assertion : constant String :=
+ (case Rec.Type_Only is
+ when No_Type_Only => "",
+ when Base_Type_Only | Impl_Base_Type_Only | Root_Type_Only =>
+ "Is_Base_Type (N)");
+ begin
+ Put_Setter_Spec (S, F);
+ Put (S, " is" & LF);
+ Put (S, "begin" & LF);
+ Increase_Indent (S, 3);
+
+ if Rec.Pre.all /= "" then
+ Put (S, "pragma Assert (" & Rec.Pre.all & ");" & LF);
+ end if;
+
+ if Rec.Pre_Set.all /= "" then
+ Put (S, "pragma Assert (" & Rec.Pre_Set.all & ");" & LF);
+ end if;
+
+ if Type_Only_Assertion /= "" then
+ Put (S, "pragma Assert (" & Type_Only_Assertion & ");" & LF);
+ end if;
+
+ Put (S, Low_Level_Setter_Name (F) & " (N, " & Image (Rec.Offset)
+ & ", Val);" & LF);
+ Decrease_Indent (S, 3);
+ Put (S, "end Set_" & Image (F) & ";" & LF & LF);
+ end Put_Setter_Body;
+
+ --------------------
+ -- Put_Subp_Decls --
+ --------------------
+
+ procedure Put_Subp_Decls (S : in out Sink; Root : Root_Type) is
+ -- Note that there are several fields that are defined for both nodes
+ -- and entities, such as Nkind. These are allocated slots in both,
+ -- but here we only put out getters and setters in Sinfo.Nodes, not
+ -- Einfo.Entities.
+
+ begin
+ Put (S, "-- Getters and setters for fields" & LF);
+
+ for F in First_Field (Root) .. Last_Field (Root) loop
+ -- Nkind/Ekind getter is already done (see Put_Type_And_Subtypes),
+ -- and there is no setter for these.
+
+ if F = Nkind then
+ Put (S, LF & "-- Nkind getter is above" & LF);
+
+ elsif F = Ekind then
+ Put (S, LF & "-- Ekind getter is above" & LF);
+
+ else
+ Put_Getter_Decl (S, F);
+ Put_Setter_Decl (S, F);
+ end if;
+
+ Put (S, LF);
+ end loop;
+ end Put_Subp_Decls;
+
+ ---------------------
+ -- Put_Subp_Bodies --
+ ---------------------
+
+ procedure Put_Subp_Bodies (S : in out Sink; Root : Root_Type) is
+ begin
+ Put (S, LF & "-- Getters and setters for fields" & LF & LF);
+
+ for F in First_Field (Root) .. Last_Field (Root) loop
+ Put_Getter_Body (S, F);
+
+ if F not in Nkind | Ekind then
+ Put_Setter_Body (S, F);
+ end if;
+ end loop;
+ end Put_Subp_Bodies;
+
+ --------------------------
+ -- Put_Traversed_Fields --
+ --------------------------
+
+ procedure Put_Traversed_Fields (S : in out Sink) is
+
+ function Is_Traversed_Field
+ (T : Concrete_Node; F : Field_Enum) return Boolean;
+ -- True if F is a field that should be traversed by Traverse_Func. In
+ -- particular, True if F is a syntactic field of T, and is of a
+ -- Node_Id or List_Id type.
+
+ function Init_Max_Traversed_Fields return Field_Offset;
+ -- Compute the maximum number of syntactic fields that are of type
+ -- Node_Id or List_Id over all node types.
+
+ procedure Put_Aggregate (T : Node_Or_Entity_Type);
+ -- Print out the subaggregate for one type
+
+ function Is_Traversed_Field
+ (T : Concrete_Node; F : Field_Enum) return Boolean is
+ begin
+ return Syntactic (T) (F)
+ and then Field_Table (F).Field_Type in Traversed_Field_Type;
+ end Is_Traversed_Field;
+
+ First_Time : Boolean := True;
+
+ procedure Put_Aggregate (T : Node_Or_Entity_Type) is
+ Left_Opnd_Skipped : Boolean := False;
+ begin
+ if T in Concrete_Node then
+ if First_Time then
+ First_Time := False;
+ else
+ Put (S, "," & LF);
+ end if;
+
+ Put (S, Image (T) & " => (");
+ Increase_Indent (S, 2);
+
+ for FI in 1 .. Last_Index (Type_Table (T).Fields) loop
+ declare
+ F : constant Field_Enum := Type_Table (T).Fields (FI);
+
+ begin
+ if Is_Traversed_Field (T, F) then
+ if F = Left_Opnd then
+ Left_Opnd_Skipped := True; -- see comment below
+
+ else
+ Put (S, Image (Field_Table (F).Offset) & ", ");
+ end if;
+ end if;
+ end;
+ end loop;
+
+ -- We always put the Left_Opnd field of N_Op_Concat last. See
+ -- comments in Atree.Traverse_Func for the reason. We might as
+ -- well do that for all Left_Opnd fields; the old version did
+ -- that.
+
+ if Left_Opnd_Skipped then
+ Put (S, Image (Field_Table (Left_Opnd).Offset) & ", ");
+ end if;
+
+ Put (S, "others => No_Field_Offset");
+
+ Decrease_Indent (S, 2);
+ Put (S, ")");
+ end if;
+ end Put_Aggregate;
+
+ function Init_Max_Traversed_Fields return Field_Offset is
+ Result : Field_Offset := 0;
+ begin
+ for T in Concrete_Node loop
+ declare
+ Num_Traversed_Fields : Field_Offset := 0; -- in type T
+
+ begin
+ for FI in 1 .. Last_Index (Type_Table (T).Fields) loop
+ declare
+ F : constant Field_Enum := Type_Table (T).Fields (FI);
+
+ begin
+ if Is_Traversed_Field (T, F) then
+ Num_Traversed_Fields := Num_Traversed_Fields + 1;
+ end if;
+ end;
+ end loop;
+
+ if Num_Traversed_Fields > Result then
+ Result := Num_Traversed_Fields;
+ end if;
+ end;
+ end loop;
+
+ return Result;
+ end Init_Max_Traversed_Fields;
+
+ Max_Traversed_Fields : constant Field_Offset :=
+ Init_Max_Traversed_Fields;
+
+ begin
+ Put (S, "-- Table of fields that should be traversed by Traverse subprograms." & LF);
+ Put (S, "-- Each entry is an array of offsets in slots of fields to be" & LF);
+ Put (S, "-- traversed, terminated by a sentinel equal to No_Field_Offset." & LF & LF);
+
+ Put (S, "subtype Traversed_Offset_Array is Offset_Array (0 .. " &
+ Image (Max_Traversed_Fields - 1) & " + 1);" & LF);
+ Put (S, "Traversed_Fields : constant array (Node_Kind) of Traversed_Offset_Array :=" & LF);
+ -- One extra for the sentinel
+
+ Increase_Indent (S, 2);
+ Put (S, "(");
+ Increase_Indent (S, 1);
+ Iterate_Types (Node_Kind, Pre => Put_Aggregate'Access);
+ Decrease_Indent (S, 1);
+ Put (S, ");" & LF & LF);
+ Decrease_Indent (S, 2);
+ end Put_Traversed_Fields;
+
+ ----------------
+ -- Put_Tables --
+ ----------------
+
+ procedure Put_Tables (S : in out Sink; Root : Root_Type) is
+
+ First_Time : Boolean := True;
+
+ procedure Put_Size (T : Node_Or_Entity_Type);
+ procedure Put_Size (T : Node_Or_Entity_Type) is
+ begin
+ if T in Concrete_Type then
+ if First_Time then
+ First_Time := False;
+ else
+ Put (S, "," & LF);
+ end if;
+
+ Put (S, Image (T) & " => " & Image (Type_Size_In_Slots (T)));
+ end if;
+ end Put_Size;
+
+ procedure Put_Field_Array (T : Concrete_Type);
+
+ procedure Put_Field_Array (T : Concrete_Type) is
+ First_Time : Boolean := True;
+ begin
+ for F in First_Field (Root) .. Last_Field (Root) loop
+ if Fields_Per_Node (T) (F) then
+ if First_Time then
+ First_Time := False;
+ else
+ Put (S, "," & LF);
+ end if;
+
+ Put (S, F_Image (F));
+ end if;
+ end loop;
+ end Put_Field_Array;
+
+ Field_Enum_Type_Name : constant String :=
+ (case Root is
+ when Node_Kind => "Node_Field",
+ when others => "Entity_Field"); -- Entity_Kind
+
+ begin
+ Put (S, "-- Table of sizes in 32-bit slots for given " &
+ Image (Root) & ", for use by Atree:" & LF);
+
+ case Root is
+ when Node_Kind =>
+ Put (S, LF & "Min_Node_Size : constant Field_Offset := " &
+ Image (Min_Node_Size) & ";" & LF);
+ Put (S, "Max_Node_Size : constant Field_Offset := " &
+ Image (Max_Node_Size) & ";" & LF & LF);
+ Put (S, "Average_Node_Size_In_Slots : constant := " &
+ Average_Node_Size_In_Slots'Img & ";" & LF & LF);
+ when Entity_Kind =>
+ Put (S, LF & "Min_Entity_Size : constant Field_Offset := " &
+ Image (Min_Entity_Size) & ";" & LF);
+ Put (S, "Max_Entity_Size : constant Field_Offset := " &
+ Image (Max_Entity_Size) & ";" & LF & LF);
+ when others => raise Program_Error;
+ end case;
+
+ Put (S, "Size : constant array (" & Image (Root) &
+ ") of Field_Offset :=" & LF);
+ Increase_Indent (S, 2);
+ Put (S, "(");
+ Increase_Indent (S, 1);
+
+ Iterate_Types (Root, Pre => Put_Size'Access);
+
+ Decrease_Indent (S, 1);
+ Put (S, "); -- Size" & LF);
+ Decrease_Indent (S, 2);
+
+ declare
+ type Dummy is array
+ (First_Field (Root) .. Last_Field (Root)) of Boolean;
+ Num_Fields : constant Root_Int := Dummy'Length;
+ First_Time : Boolean := True;
+ begin
+ Put (S, LF & "-- Enumeration of all " & Image (Num_Fields)
+ & " fields:" & LF & LF);
+
+ Put (S, "type " & Field_Enum_Type_Name & " is" & LF);
+ Increase_Indent (S, 2);
+ Put (S, "(");
+ Increase_Indent (S, 1);
+
+ for F in First_Field (Root) .. Last_Field (Root) loop
+ if First_Time then
+ First_Time := False;
+ else
+ Put (S, "," & LF);
+ end if;
+
+ Put (S, F_Image (F));
+ end loop;
+
+ Decrease_Indent (S, 1);
+ Put (S, "); -- " & Field_Enum_Type_Name & LF);
+ Decrease_Indent (S, 2);
+ end;
+
+ Put (S, LF & "type " & Field_Enum_Type_Name & "_Index is new Pos;" & LF);
+ Put (S, "type " & Field_Enum_Type_Name & "_Array is array (" &
+ Field_Enum_Type_Name & "_Index range <>) of " &
+ Field_Enum_Type_Name & ";" & LF);
+ Put (S, "type " & Field_Enum_Type_Name &
+ "_Array_Ref is access constant " & Field_Enum_Type_Name &
+ "_Array;" & LF);
+ Put (S, "subtype A is " & Field_Enum_Type_Name & "_Array;" & LF);
+ -- Short name to make allocators below more readable
+
+ declare
+ First_Time : Boolean := True;
+
+ procedure Do_One_Type (T : Node_Or_Entity_Type);
+ procedure Do_One_Type (T : Node_Or_Entity_Type) is
+ begin
+ if T in Concrete_Type then
+ if First_Time then
+ First_Time := False;
+ else
+ Put (S, "," & LF);
+ end if;
+
+ Put (S, Image (T) & " =>" & LF);
+ Increase_Indent (S, 2);
+ Put (S, "new A'(");
+ Increase_Indent (S, 6);
+ Increase_Indent (S, 1);
+
+ Put_Field_Array (T);
+
+ Decrease_Indent (S, 1);
+ Put (S, ")");
+ Decrease_Indent (S, 6);
+ Decrease_Indent (S, 2);
+ end if;
+ end Do_One_Type;
+ begin
+ Put (S, LF & "-- Table mapping " & Image (Root) &
+ "s to the sequence of fields that exist in that " &
+ Image (Root) & ":" & LF & LF);
+
+ Put (S, Field_Enum_Type_Name & "_Table : constant array (" &
+ Image (Root) & ") of " & Field_Enum_Type_Name &
+ "_Array_Ref :=" & LF);
+
+ Increase_Indent (S, 2);
+ Put (S, "(");
+ Increase_Indent (S, 1);
+
+ Iterate_Types (Root, Pre => Do_One_Type'Access);
+
+ Decrease_Indent (S, 1);
+ Put (S, "); -- " & Field_Enum_Type_Name & "_Table" & LF);
+ Decrease_Indent (S, 2);
+ end;
+
+ declare
+ First_Time : Boolean := True;
+ begin
+ Put (S, LF & "-- Table mapping fields to kind and offset:" & LF & LF);
+
+ Put (S, Field_Enum_Type_Name & "_Descriptors : constant array (" &
+ Field_Enum_Type_Name & ") of Field_Descriptor :=" & LF);
+
+ Increase_Indent (S, 2);
+ Put (S, "(");
+ Increase_Indent (S, 1);
+
+ for F in First_Field (Root) .. Last_Field (Root) loop
+ if First_Time then
+ First_Time := False;
+ else
+ Put (S, "," & LF);
+ end if;
+
+ Put (S, F_Image (F) & " => (" &
+ Image (Field_Table (F).Field_Type) & "_Field, " &
+ Image (Field_Table (F).Offset) & ")");
+ end loop;
+
+ Decrease_Indent (S, 1);
+ Put (S, "); -- Field_Descriptors" & LF);
+ Decrease_Indent (S, 2);
+ end;
+
+ end Put_Tables;
+
+ ----------------
+ -- Put_Seinfo --
+ ----------------
+
+ procedure Put_Seinfo is
+ S : Sink;
+ begin
+ Create_File (S, "seinfo.ads");
+ Put (S, "with Types; use Types;" & LF);
+ Put (S, LF & "package Seinfo is" & LF & LF);
+ Increase_Indent (S, 3);
+
+ Put (S, "-- This package is automatically generated." & LF & LF);
+
+ Put (S, "-- Common declarations visible in both Sinfo.Nodes and Einfo.Entities." & LF);
+
+ Put (S, LF & "type Field_Kind is" & LF);
+ Increase_Indent (S, 2);
+ Put (S, "(");
+ Increase_Indent (S, 1);
+
+ declare
+ First_Time : Boolean := True;
+ begin
+ for T in Special_Type loop
+ if First_Time then
+ First_Time := False;
+ else
+ Put (S, "," & LF);
+ end if;
+
+ Put (S, Image (T) & "_Field");
+ end loop;
+ end;
+
+ Decrease_Indent (S, 1);
+ Decrease_Indent (S, 2);
+ Put (S, ");" & LF);
+
+ Put (S, LF & "Field_Size : constant array (Field_Kind) of Field_Size_In_Bits :=" & LF);
+ Increase_Indent (S, 2);
+ Put (S, "(");
+ Increase_Indent (S, 1);
+
+ declare
+ First_Time : Boolean := True;
+ begin
+ for T in Special_Type loop
+ if First_Time then
+ First_Time := False;
+ else
+ Put (S, "," & LF);
+ end if;
+
+ Put (S, Image (T) & "_Field => " & Image (Field_Size (T)));
+ end loop;
+ end;
+
+ Decrease_Indent (S, 1);
+ Decrease_Indent (S, 2);
+ Put (S, ");" & LF & LF);
+
+ Put (S, "type Field_Descriptor is record" & LF);
+ Increase_Indent (S, 3);
+ Put (S, "Kind : Field_Kind;" & LF);
+ Put (S, "Offset : Field_Offset;" & LF);
+ Decrease_Indent (S, 3);
+ Put (S, "end record;" & LF);
+
+ Decrease_Indent (S, 3);
+ Put (S, LF & "end Seinfo;" & LF);
+ end Put_Seinfo;
+
+ ---------------
+ -- Put_Nodes --
+ ---------------
+
+ procedure Put_Nodes is
+ S : Sink;
+ B : Sink;
+
+ procedure Put_Setter_With_Parent (Kind : String);
+ -- Put the low-level ..._With_Parent setter. Kind is either "Node" or
+ -- "List".
+
+ procedure Put_Setter_With_Parent (Kind : String) is
+ Error : constant String := (if Kind = "Node" then "" else "_" & Kind);
+ begin
+ Put (B, LF & "procedure Set_" & Kind & "_Id_With_Parent" & LF);
+ Increase_Indent (B, 2);
+ Put (B, "(N : Node_Id; Offset : Field_Offset; Val : " & Kind & "_Id);" & LF & LF);
+ Decrease_Indent (B, 2);
+
+ Put (B, "procedure Set_" & Kind & "_Id_With_Parent" & LF);
+ Increase_Indent (B, 2);
+ Put (B, "(N : Node_Id; Offset : Field_Offset; Val : " & Kind & "_Id) is" & LF);
+ Decrease_Indent (B, 2);
+ Put (B, "begin" & LF);
+ Increase_Indent (B, 3);
+ Put (B, "if Present (Val) and then Val /= Error" & Error & " then" & LF);
+ Increase_Indent (B, 3);
+ Put (B, "pragma Warnings (Off, ""actuals for this call may be in wrong order"");" & LF);
+ Put (B, "Set_Parent (Val, N);" & LF);
+ Put (B, "pragma Warnings (On, ""actuals for this call may be in wrong order"");" & LF);
+ Decrease_Indent (B, 3);
+ Put (B, "end if;" & LF & LF);
+
+ Put (B, "Set_" & Kind & "_Id (N, Offset, Val);" & LF);
+ Decrease_Indent (B, 3);
+ Put (B, "end Set_" & Kind & "_Id_With_Parent;" & LF);
+ end Put_Setter_With_Parent;
+
+ -- Start of processing for Put_Nodes
+
+ begin
+ Create_File (S, "sinfo-nodes.ads");
+ Create_File (B, "sinfo-nodes.adb");
+ Put (S, "with Seinfo; use Seinfo;" & LF);
+ Put (S, "pragma Warnings (Off);" & LF);
+ -- With's included in case they are needed; so we don't have to keep
+ -- switching back and forth.
+ Put (S, "with Output; use Output;" & LF);
+ Put (S, "pragma Warnings (On);" & LF);
+
+ Put (S, LF & "package Sinfo.Nodes is" & LF & LF);
+ Increase_Indent (S, 3);
+
+ Put (S, "-- This package is automatically generated." & LF & LF);
+
+ Put_Type_Hierarchy (S, Node_Kind);
+
+ Put_Type_And_Subtypes (S, Node_Kind);
+
+ Put (S, "pragma Assert (Node_Kind'Pos (N_Unused_At_Start) = 0);" & LF & LF);
+ Put (S, "pragma Assert (Node_Kind'Last = N_Unused_At_End);" & LF & LF);
+
+ Put_Subp_Decls (S, Node_Kind);
+
+ Put_Traversed_Fields (S);
+
+ Put_Tables (S, Node_Kind);
+
+ Decrease_Indent (S, 3);
+ Put (S, LF & "end Sinfo.Nodes;" & LF);
+
+ Put (B, "with Atree; use Atree; use Atree.Atree_Private_Part;" & LF);
+ Put (B, "with Nlists; use Nlists;" & LF);
+ Put (B, "pragma Warnings (Off);" & LF);
+ Put (B, "with Einfo.Utils; use Einfo.Utils;" & LF);
+ Put (B, "with Sinfo.Utils; use Sinfo.Utils;" & LF);
+ Put (B, "pragma Warnings (On);" & LF);
+
+ Put (B, LF & "package body Sinfo.Nodes is" & LF & LF);
+ Increase_Indent (B, 3);
+
+ Put (B, "-- This package is automatically generated." & LF & LF);
+
+ Put (B, "-- Instantiations of low-level getters and setters that take offsets" & LF);
+ Put (B, "-- in units of the size of the field." & LF);
+
+ Put (B, "pragma Style_Checks (""M200"");" & LF);
+ for T in Special_Type loop
+ if Node_Field_Types_Used (T) then
+ Put_Low_Level_Accessor_Instantiations (B, T);
+ end if;
+ end loop;
+
+ Put_Setter_With_Parent ("Node");
+ Put_Setter_With_Parent ("List");
+
+ Put_Subp_Bodies (B, Node_Kind);
+
+ Decrease_Indent (B, 3);
+ Put (B, "end Sinfo.Nodes;" & LF);
+
+ end Put_Nodes;
+
+ ------------------
+ -- Put_Entities --
+ ------------------
+
+ procedure Put_Entities is
+ S : Sink;
+ B : Sink;
+ begin
+ Create_File (S, "einfo-entities.ads");
+ Create_File (B, "einfo-entities.adb");
+ Put (S, "with Seinfo; use Seinfo;" & LF);
+ Put (S, "with Sinfo.Nodes; use Sinfo.Nodes;" & LF);
+
+ Put (S, LF & "package Einfo.Entities is" & LF & LF);
+ Increase_Indent (S, 3);
+
+ Put (S, "-- This package is automatically generated." & LF & LF);
+
+ Put_Type_Hierarchy (S, Entity_Kind);
+
+ Put_Type_And_Subtypes (S, Entity_Kind);
+
+ Put_Subp_Decls (S, Entity_Kind);
+
+ Put_Tables (S, Entity_Kind);
+
+ Decrease_Indent (S, 3);
+ Put (S, LF & "end Einfo.Entities;" & LF);
+
+ Put (B, "with Atree; use Atree; use Atree.Atree_Private_Part;" & LF);
+ Put (B, "with Einfo.Utils; use Einfo.Utils;" & LF);
+ -- This forms a cycle between packages (via bodies, which is OK)
+
+ Put (B, LF & "package body Einfo.Entities is" & LF & LF);
+ Increase_Indent (B, 3);
+
+ Put (B, "-- This package is automatically generated." & LF & LF);
+
+ Put (B, "-- Instantiations of low-level getters and setters that take offsets" & LF);
+ Put (B, "-- in units of the size of the field." & LF);
+
+ Put (B, "pragma Style_Checks (""M200"");" & LF);
+ for T in Special_Type loop
+ if Entity_Field_Types_Used (T) then
+ Put_Low_Level_Accessor_Instantiations (B, T);
+ end if;
+ end loop;
+
+ Put_Subp_Bodies (B, Entity_Kind);
+
+ Decrease_Indent (B, 3);
+ Put (B, "end Einfo.Entities;" & LF);
+
+ end Put_Entities;
+
+ -------------------
+ -- Put_Make_Spec --
+ -------------------
+
+ procedure Put_Make_Spec
+ (S : in out Sink; Root : Root_Type; T : Concrete_Type)
+ is
+ begin
+ Put (S, "function Make_" & Image_Sans_N (T) & "" & LF);
+ Increase_Indent (S, 2);
+ Put (S, "(Sloc : Source_Ptr");
+ Increase_Indent (S, 1);
+
+ for F of Type_Table (T).Fields loop
+ pragma Assert (Fields_Per_Node (T) (F));
+
+ if Syntactic (T) (F) then
+ declare
+ Typ : constant String :=
+ (if Field_Table (F).Field_Type = Flag then "Boolean"
+ else Image (Field_Table (F).Field_Type));
+
+ -- All Flag fields have a default, which is False by
+ -- default.
+
+ Default : constant String :=
+ (if Field_Table (F).Default_Value = No_Default then
+ (if Field_Table (F).Field_Type = Flag then " := False" else "")
+ else " := " & Value_Image (Field_Table (F).Default_Value));
+
+ begin
+ Put (S, ";" & LF);
+ Put (S, Image (F));
+ Put (S, " : " & Typ & Default);
+ end;
+ end if;
+ end loop;
+
+ Put (S, ")" & LF & "return " & Node_Or_Entity (Root) & "_Id");
+ Decrease_Indent (S, 2);
+ Decrease_Indent (S, 1);
+ end Put_Make_Spec;
+
+ --------------------
+ -- Put_Make_Decls --
+ --------------------
+
+ procedure Put_Make_Decls (S : in out Sink; Root : Root_Type) is
+ begin
+ for T in First_Concrete (Root) .. Last_Concrete (Root) loop
+ if T not in N_Unused_At_Start | N_Unused_At_End then
+ Put_Make_Spec (S, Root, T);
+ Put (S, ";" & LF & "pragma " & Inline & " (Make_" &
+ Image_Sans_N (T) & ");" & LF & LF);
+ end if;
+ end loop;
+ end Put_Make_Decls;
+
+ ---------------------
+ -- Put_Make_Bodies --
+ ---------------------
+
+ procedure Put_Make_Bodies (S : in out Sink; Root : Root_Type) is
+ begin
+ for T in First_Concrete (Root) .. Last_Concrete (Root) loop
+ if T not in N_Unused_At_Start | N_Unused_At_End then
+ Put_Make_Spec (S, Root, T);
+ Put (S, LF & "is" & LF);
+
+ Increase_Indent (S, 3);
+ Put (S, "N : constant Node_Id :=" & LF);
+
+ if T in Entity_Node then
+ Put (S, " New_Entity (" & Image (T) & ", Sloc);" & LF);
+
+ else
+ Put (S, " New_Node (" & Image (T) & ", Sloc);" & LF);
+ end if;
+
+ Decrease_Indent (S, 3);
+
+ Put (S, "begin" & LF);
+
+ Increase_Indent (S, 3);
+ for F of Type_Table (T).Fields loop
+ pragma Assert (Fields_Per_Node (T) (F));
+
+ if Syntactic (T) (F) then
+ declare
+ NWidth : constant := 28;
+ -- This constant comes from the old Xnmake, which wraps
+ -- the Set_... call if the field name is that long or
+ -- longer.
+
+ F_Name : constant String := Image (F);
+
+ begin
+ if F_Name'Length < NWidth then
+ Put (S, "Set_" & F_Name & " (N, " & F_Name & ");" & LF);
+
+ -- Wrap the line
+
+ else
+ Put (S, "Set_" & F_Name & "" & LF);
+ Increase_Indent (S, 2);
+ Put (S, "(N, " & F_Name & ");" & LF);
+ Decrease_Indent (S, 2);
+ end if;
+ end;
+ end if;
+ end loop;
+
+ if Is_Descendant (N_Op, T) then
+ -- Special cases for N_Op nodes: fill in the Chars and Entity
+ -- fields even though they were not passed in.
+
+ declare
+ Op : constant String := Image_Sans_N (T);
+ -- This will be something like "Op_And" or "Op_Add"
+
+ Op_Name_With_Op : constant String :=
+ (if T = N_Op_Plus then "Op_Add"
+ elsif T = N_Op_Minus then "Op_Subtract"
+ else Op);
+ -- Special cases for unary operators that have the same name
+ -- as a binary operator; we use the binary operator name in
+ -- that case.
+
+ Slid : constant String (1 .. Op_Name_With_Op'Length) :=
+ Op_Name_With_Op;
+ pragma Assert (Slid (1 .. 3) = "Op_");
+
+ Op_Name : constant String :=
+ (if T in N_Op_Rotate_Left |
+ N_Op_Rotate_Right |
+ N_Op_Shift_Left |
+ N_Op_Shift_Right |
+ N_Op_Shift_Right_Arithmetic
+ then Slid (4 .. Slid'Last)
+ else Slid);
+ -- Special cases for shifts and rotates; the node kind has
+ -- "Op_", but the Name_Id constant does not.
+
+ begin
+ Put (S, "Set_Chars (N, Name_" & Op_Name & ");" & LF);
+ Put (S, "Set_Entity (N, Standard_" & Op & ");" & LF);
+ end;
+ end if;
+
+ if Type_Table (T).Nmake_Assert.all /= "" then
+ Put (S, "pragma Assert (" &
+ Type_Table (T).Nmake_Assert.all & ");" & LF);
+ end if;
+
+ Put (S, "return N;" & LF);
+ Decrease_Indent (S, 3);
+
+ Put (S, "end Make_" & Image_Sans_N (T) & ";" & LF & LF);
+ end if;
+ end loop;
+ end Put_Make_Bodies;
+
+ ---------------
+ -- Put_Nmake --
+ ---------------
+
+ -- Documentation for the Nmake package, generated by Put_Nmake below.
+
+ -- The Nmake package contains a set of routines used to construct tree
+ -- nodes using a functional style. There is one routine for each node
+ -- type defined in Gen_IL.Gen.Gen_Nodes with the general interface:
+
+ -- function Make_xxx (Sloc : Source_Ptr,
+ -- Field_Name_1 : Field_Name_1_Type [:= default]
+ -- Field_Name_2 : Field_Name_2_Type [:= default]
+ -- ...)
+ -- return Node_Id
+
+ -- Only syntactic fields are included.
+
+ -- Default values are provided as specified in Gen_Nodes, except that if
+ -- no default is specified for a flag field, it has a default of False.
+
+ -- Warning: since calls to Make_xxx routines are normal function calls, the
+ -- arguments can be evaluated in any order. This means that at most one such
+ -- argument can have side effects (e.g. be a call to a parse routine).
+
+ procedure Put_Nmake is
+ S : Sink;
+ B : Sink;
+
+ begin
+ Create_File (S, "nmake.ads");
+ Create_File (B, "nmake.adb");
+ Put (S, "with Namet; use Namet;" & LF);
+ Put (S, "with Nlists; use Nlists;" & LF);
+ Put (S, "with Types; use Types;" & LF);
+ Put (S, "with Uintp; use Uintp;" & LF);
+ Put (S, "with Urealp; use Urealp;" & LF);
+
+ Put (S, LF & "package Nmake is" & LF & LF);
+ Increase_Indent (S, 3);
+
+ Put (S, "-- This package is automatically generated." & LF & LF);
+ Put (S, "-- See Put_Nmake in gen_il-gen.adb for documentation." & LF & LF);
+
+ Put_Make_Decls (S, Node_Kind);
+
+ Decrease_Indent (S, 3);
+ Put (S, "end Nmake;" & LF);
+
+ Put (B, "with Atree; use Atree;" & LF);
+ Put (B, "with Sinfo.Nodes; use Sinfo.Nodes;" & LF);
+ Put (B, "with Sinfo.Utils; use Sinfo.Utils;" & LF);
+ Put (B, "with Snames; use Snames;" & LF);
+ Put (B, "with Stand; use Stand;" & LF);
+
+ Put (B, LF & "package body Nmake is" & LF & LF);
+ Increase_Indent (B, 3);
+
+ Put (B, "-- This package is automatically generated." & LF & LF);
+ Put (B, "pragma Style_Checks (""M200"");" & LF);
+
+ Put_Make_Bodies (B, Node_Kind);
+
+ Decrease_Indent (B, 3);
+ Put (B, "end Nmake;" & LF);
+ end Put_Nmake;
+
+ -----------------------
+ -- Put_Seinfo_Tables --
+ -----------------------
+
+ procedure Put_Seinfo_Tables is
+ S : Sink;
+ B : Sink;
+
+ Type_Layout : Concrete_Type_Layout_Array;
+
+ function Get_Last_Bit
+ (T : Concrete_Type; F : Opt_Field_Enum; First_Bit : Bit_Offset)
+ return Bit_Offset;
+ function First_Bit_Image (First_Bit : Bit_Offset) return String;
+ function Last_Bit_Image (Last_Bit : Bit_Offset) return String;
+
+ procedure Put_Field_List (Bit : Bit_Offset);
+ -- Print out the list of fields that are allocated (in part, for
+ -- fields bigger than one bit) at the given bit offset. This allows
+ -- us to see which fields are overlaid with each other, which should
+ -- only happen if the sets of types with those fields are disjoint.
+
+ function Get_Last_Bit
+ (T : Concrete_Type; F : Opt_Field_Enum; First_Bit : Bit_Offset)
+ return Bit_Offset is
+ begin
+ return Result : Bit_Offset do
+ if F = No_Field then
+ -- We don't have a field size for No_Field, so just look at
+ -- the bits up to the next word boundary.
+
+ Result := First_Bit;
+
+ while (Result + 1) mod 32 /= 0
+ and then Type_Layout (T) (Result + 1) = No_Field
+ loop
+ Result := Result + 1;
+ end loop;
+
+ else
+ Result := First_Bit + Field_Size (F) - 1;
+ end if;
+ end return;
+ end Get_Last_Bit;
+
+ function First_Bit_Image (First_Bit : Bit_Offset) return String is
+ W : constant Bit_Offset := First_Bit / 32;
+ B : constant Bit_Offset := First_Bit mod 32;
+ pragma Assert (W * 32 + B = First_Bit);
+ begin
+ return
+ Image (W) & "*32" & (if B = 0 then "" else " + " & Image (B));
+ end First_Bit_Image;
+
+ function Last_Bit_Image (Last_Bit : Bit_Offset) return String is
+ W : constant Bit_Offset := (Last_Bit + 1) / 32;
+ begin
+ if W * 32 - 1 = Last_Bit then
+ return Image (W) & "*32 - 1";
+ else
+ return First_Bit_Image (Last_Bit);
+ end if;
+ end Last_Bit_Image;
+
+ function Image_Or_Waste (F : Opt_Field_Enum) return String is
+ (if F = No_Field then "Wasted_Bits" else Image (F));
+
+ Num_Wasted_Bits : Bit_Offset'Base := 0;
+
+ Type_Layout_Size : Bit_Offset'Base := Type_Layout'Size;
+ -- Total size of Type_Layout, including the Field_Arrays its
+ -- components point to.
+
+ procedure Put_Field_List (Bit : Bit_Offset) is
+ First_Time : Boolean := True;
+ begin
+ for F in Field_Enum loop
+ if F /= Between_Node_And_Entity_Fields
+ and then Bit in First_Bit (F, Field_Table (F).Offset)
+ .. Last_Bit (F, Field_Table (F).Offset)
+ then
+ if First_Time then
+ First_Time := False;
+ else
+ Put (B, "," & LF);
+ end if;
+
+ Put (B, Image (F));
+ end if;
+ end loop;
+ end Put_Field_List;
+
+ begin -- Put_Seinfo_Tables
+ Create_File (S, "seinfo_tables.ads");
+ Create_File (B, "seinfo_tables.adb");
+
+ for T in Concrete_Type loop
+ Type_Layout (T) := new Field_Array'
+ (0 .. Type_Bit_Size_Aligned (T) - 1 => No_Field);
+ Type_Layout_Size := Type_Layout_Size + Type_Layout (T).all'Size;
+
+ for F in Field_Enum loop
+ if Fields_Per_Node (T) (F) then
+ declare
+ Off : constant Field_Offset := Field_Table (F).Offset;
+ subtype Bit_Range is Bit_Offset
+ range First_Bit (F, Off) .. Last_Bit (F, Off);
+ begin
+ pragma Assert
+ (Type_Layout (T) (Bit_Range) = (Bit_Range => No_Field));
+ Type_Layout (T) (Bit_Range) := (others => F);
+ end;
+ end if;
+ end loop;
+ end loop;
+
+ for T in Concrete_Type loop
+ for B in 0 .. Type_Bit_Size_Aligned (T) - 1 loop
+ if Type_Layout (T) (B) = No_Field then
+ Num_Wasted_Bits := Num_Wasted_Bits + 1;
+ end if;
+ end loop;
+ end loop;
+
+ Put (S, LF & "package Seinfo_Tables is" & LF & LF);
+ Increase_Indent (S, 3);
+
+ Put (S, "-- This package is automatically generated." & LF & LF);
+
+ Put (S, "-- This package is not used by the compiler." & LF);
+ Put (S, "-- The body contains tables that are intended to be used by humans to" & LF);
+ Put (S, "-- help understand the layout of various data structures." & LF);
+ Put (S, "-- Search for ""--"" to find major sections of code." & LF & LF);
+
+ Put (S, "pragma Elaborate_Body;" & LF);
+
+ Decrease_Indent (S, 3);
+ Put (S, LF & "end Seinfo_Tables;" & LF);
+
+ Put (B, "with Gen_IL.Types; use Gen_IL.Types;" & LF);
+ Put (B, "with Gen_IL.Fields; use Gen_IL.Fields;" & LF);
+ Put (B, "with Gen_IL.Internals; use Gen_IL.Internals;" & LF);
+
+ Put (B, LF & "package body Seinfo_Tables is" & LF & LF);
+ Increase_Indent (B, 3);
+
+ Put (B, "-- This package is automatically generated." & LF & LF);
+
+ Put (B, "Num_Wasted_Bits : Bit_Offset'Base := " & Image (Num_Wasted_Bits) &
+ " with Unreferenced;" & LF);
+
+ Put (B, LF & "Wasted_Bits : constant Opt_Field_Enum := No_Field;" & LF);
+
+ Put (B, LF & "-- Table showing the layout of each Node_Or_Entity_Type. For each" & LF);
+ Put (B, "-- concrete type, we show the bits used by each field. Each field" & LF);
+ Put (B, "-- uses the same bit range in all types. This table is not used by" & LF);
+ Put (B, "-- the compiler; it is for information only." & LF & LF);
+
+ Put (B, "-- Wasted_Bits are unused bits between fields, and padding at the end" & LF);
+ Put (B, "-- to round up to a multiple of the slot size." & LF);
+
+ Put (B, LF & "-- Type_Layout is " & Image (Type_Layout_Size / 8) & " bytes." & LF);
+
+ Put (B, LF & "pragma Style_Checks (Off);" & LF);
+ Put (B, "Type_Layout : constant Concrete_Type_Layout_Array := " & LF);
+ Increase_Indent (B, 2);
+ Put (B, "-- Concrete node types:" & LF);
+ Put (B, "(");
+ Increase_Indent (B, 1);
+
+ declare
+ First_Time : Boolean := True;
+ begin
+ for T in Concrete_Type loop
+ if First_Time then
+ First_Time := False;
+ else
+ Put (B, "," & LF & LF);
+ end if;
+
+ if T = Concrete_Entity'First then
+ Put (B, "-- Concrete entity types:" & LF & LF);
+ end if;
+
+ Put (B, Image (T) & " => new Field_Array'" & LF);
+
+ Increase_Indent (B, 2);
+ Put (B, "(");
+ Increase_Indent (B, 1);
+
+ declare
+ First_Time : Boolean := True;
+ First_Bit : Bit_Offset := 0;
+ begin
+ while First_Bit < Type_Bit_Size_Aligned (T) loop
+ if First_Time then
+ First_Time := False;
+ else
+ Put (B, "," & LF);
+ end if;
+
+ declare
+ F : constant Opt_Field_Enum :=
+ Type_Layout (T) (First_Bit);
+ begin
+ declare
+ Last_Bit : constant Bit_Offset :=
+ Get_Last_Bit (T, F, First_Bit);
+ begin
+ pragma Assert
+ (Type_Layout (T) (First_Bit .. Last_Bit) =
+ (First_Bit .. Last_Bit => F));
+
+ if Last_Bit = First_Bit then
+ Put (B, First_Bit_Image (First_Bit) & " => " &
+ Image_Or_Waste (F));
+ else
+ pragma Assert
+ (if F /= No_Field then
+ First_Bit mod Field_Size (F) = 0);
+ Put (B, First_Bit_Image (First_Bit) & " .. " &
+ Last_Bit_Image (Last_Bit) & " => " &
+ Image_Or_Waste (F));
+ end if;
+
+ First_Bit := Last_Bit + 1;
+ end;
+ end;
+ end loop;
+ end;
+
+ Decrease_Indent (B, 1);
+ Put (B, ")");
+ Decrease_Indent (B, 2);
+ end loop;
+ end;
+
+ Decrease_Indent (B, 1);
+ Put (B, ") -- Type_Layout" & LF);
+ Increase_Indent (B, 6);
+ Put (B, "with Export, Convention => Ada;" & LF);
+ Decrease_Indent (B, 6);
+ Decrease_Indent (B, 2);
+
+ Put (B, LF & "-- Table mapping bit offsets to the set of fields at that offset" & LF & LF);
+ Put (B, "Bit_Used : constant Offset_To_Fields_Mapping :=" & LF);
+
+ Increase_Indent (B, 2);
+ Put (B, "(");
+ Increase_Indent (B, 1);
+
+ declare
+ First_Time : Boolean := True;
+ begin
+ for Bit in 0 .. Bit_Offset'Max
+ (Max_Node_Bit_Size, Max_Entity_Bit_Size)
+ loop
+ if First_Time then
+ First_Time := False;
+ else
+ Put (B, "," & LF & LF);
+ end if;
+
+ Put (B, First_Bit_Image (Bit) & " => new Field_Array'" & LF);
+
+ -- Use [...] notation here, to get around annoying Ada
+ -- limitations on empty and singleton aggregates. This code is
+ -- not used in the compiler, so there are no bootstrap issues.
+
+ Increase_Indent (B, 2);
+ Put (B, "[");
+ Increase_Indent (B, 1);
+
+ Put_Field_List (Bit);
+
+ Decrease_Indent (B, 1);
+ Put (B, "]");
+ Decrease_Indent (B, 2);
+ end loop;
+ end;
+
+ Decrease_Indent (B, 1);
+ Put (B, "); -- Bit_Used" & LF);
+ Decrease_Indent (B, 2);
+
+ Decrease_Indent (B, 3);
+ Put (B, LF & "end Seinfo_Tables;" & LF);
+
+ end Put_Seinfo_Tables;
+
+ -----------------------------
+ -- Put_C_Type_And_Subtypes --
+ -----------------------------
+
+ procedure Put_C_Type_And_Subtypes
+ (S : in out Sink; Root : Root_Type) is
+
+ Cur_Pos : Root_Nat := 0;
+ -- Current Node_Kind'Pos or Entity_Kind'Pos to be printed
+
+ procedure Put_Enum_Lit (T : Node_Or_Entity_Type);
+ -- Print out the #define corresponding to the Ada enumeration literal
+ -- for T in Node_Kind and Entity_Kind (i.e. concrete types).
+ -- This looks like "#define Some_Kind <pos>", where Some_Kind
+ -- is the Node_Kind or Entity_Kind enumeration literal, and
+ -- <pos> is Node_Kind'Pos or Entity_Kind'Pos of that literal.
+
+ procedure Put_Kind_Subtype (T : Node_Or_Entity_Type);
+ -- Print out the SUBTYPE macro call corresponding to an abstract
+ -- type.
+
+ procedure Put_Enum_Lit (T : Node_Or_Entity_Type) is
+ begin
+ if T in Concrete_Type then
+ Put (S, "#define " & Image (T) & " " & Image (Cur_Pos) & LF);
+ Cur_Pos := Cur_Pos + 1;
+ end if;
+ end Put_Enum_Lit;
+
+ procedure Put_Kind_Subtype (T : Node_Or_Entity_Type) is
+ begin
+ if T in Abstract_Type and then Type_Table (T).Parent /= No_Type then
+ Put (S, "SUBTYPE (" & Image (T) & ", " &
+ Image (Type_Table (T).Parent) & "," & LF);
+ Increase_Indent (S, 3);
+ Put (S, Image (Type_Table (T).First) & "," & LF);
+ Put (S, Image (Type_Table (T).Last) & ")" & LF);
+ Decrease_Indent (S, 3);
+ end if;
+ end Put_Kind_Subtype;
+
+ begin
+ Iterate_Types (Root, Pre => Put_Enum_Lit'Access);
+
+ Put (S, "#define Number_" & Node_Or_Entity (Root) & "_Kinds " &
+ Image (Cur_Pos) & "" & LF & LF);
+
+ Iterate_Types (Root, Pre => Put_Kind_Subtype'Access);
+
+ Put_Union_Membership (S, Root);
+ end Put_C_Type_And_Subtypes;
+
+ ----------------------------
+ -- Put_Low_Level_C_Getter --
+ ----------------------------
+
+ procedure Put_Low_Level_C_Getter
+ (S : in out Sink; T : Type_Enum)
+ is
+ T_Image : constant String := Get_Set_Id_Image (T);
+
+ begin
+ Put (S, "INLINE " & T_Image & "" & LF);
+ Put (S, "Get_" & Image (T) & " (Node_Id N, Field_Offset Offset)" & LF);
+
+ Increase_Indent (S, 3);
+
+ -- Same special cases for getters as in
+ -- Put_Low_Level_Accessor_Instantiations.
+
+ if T in Uint_Subtype then
+ pragma Assert (Field_Size (T) = 32);
+ Put (S, "{ return (" & T_Image &
+ ") Get_Valid_32_Bit_Field(N, Offset); }" & LF & LF);
+
+ elsif Field_Has_Special_Default (T) then
+ pragma Assert (Field_Size (T) = 32);
+ Put (S, "{ return (" & T_Image &
+ ") Get_32_Bit_Field_With_Default(N, Offset, " &
+ Special_Default (T) & "); }" & LF & LF);
+
+ else
+ Put (S, "{ return (" & T_Image & ") Get_" &
+ Image (Field_Size (T)) & "_Bit_Field(N, Offset); }" & LF & LF);
+ end if;
+
+ Decrease_Indent (S, 3);
+ end Put_Low_Level_C_Getter;
+
+ -----------------------------
+ -- Put_High_Level_C_Getter --
+ -----------------------------
+
+ procedure Put_High_Level_C_Getter
+ (S : in out Sink; F : Field_Enum)
+ is
+ begin
+ Put (S, "INLINE " & Get_Set_Id_Image (Field_Table (F).Field_Type) &
+ " " & Image (F) & " (Node_Id N)" & LF);
+
+ Increase_Indent (S, 3);
+ Put (S, "{ return " &
+ Low_Level_Getter_Name (Field_Table (F).Field_Type) &
+ "(" & Node_To_Fetch_From (F) & ", " &
+ Image (Field_Table (F).Offset) & "); }" & LF & LF);
+ Decrease_Indent (S, 3);
+ end Put_High_Level_C_Getter;
+
+ ------------------------------
+ -- Put_High_Level_C_Getters --
+ ------------------------------
+
+ procedure Put_High_Level_C_Getters
+ (S : in out Sink; Root : Root_Type)
+ is
+ begin
+ Put (S, "// Getters for fields" & LF & LF);
+
+ for F in First_Field (Root) .. Last_Field (Root) loop
+ Put_High_Level_C_Getter (S, F);
+ end loop;
+ end Put_High_Level_C_Getters;
+
+ --------------------------
+ -- Put_Union_Membership --
+ --------------------------
+
+ procedure Put_Union_Membership
+ (S : in out Sink; Root : Root_Type) is
+
+ procedure Put_Ors (T : Abstract_Type);
+ -- Print the "or" (i.e. "||") of tests whether kind is in each child
+ -- type.
+
+ procedure Put_Ors (T : Abstract_Type) is
+ First_Time : Boolean := True;
+ begin
+ for Child of Type_Table (T).Children loop
+ if First_Time then
+ First_Time := False;
+ else
+ Put (S, " ||" & LF);
+ end if;
+
+ -- Unions, other abstract types, and concrete types each have
+ -- their own way of testing membership in the C++ code.
+
+ if Child in Abstract_Type then
+ if Type_Table (Child).Is_Union then
+ Put (S, "Is_In_" & Image (Child) & " (kind)");
+
+ else
+ Put (S, "IN (kind, " & Image (Child) & ")");
+ end if;
+
+ else
+ Put (S, "kind == " & Image (Child));
+ end if;
+ end loop;
+ end Put_Ors;
+
+ begin
+ Put (S, LF & "// Membership tests for union types" & LF & LF);
+
+ for T in First_Abstract (Root) .. Last_Abstract (Root) loop
+ if Type_Table (T) /= null and then Type_Table (T).Is_Union then
+ Put (S, "INLINE Boolean" & LF);
+ Put (S, "Is_In_" & Image (T) & " (" &
+ Node_Or_Entity (Root) & "_Kind kind)" & LF);
+
+ Put (S, "{" & LF);
+ Increase_Indent (S, 3);
+ Put (S, "return" & LF);
+ Increase_Indent (S, 3);
+ Put_Ors (T);
+ Decrease_Indent (S, 3);
+ Decrease_Indent (S, 3);
+ Put (S, ";" & LF & "}" & LF);
+
+ Put (S, "" & LF);
+ end if;
+ end loop;
+ end Put_Union_Membership;
+
+ ---------------------
+ -- Put_Sinfo_Dot_H --
+ ---------------------
+
+ procedure Put_Sinfo_Dot_H is
+ S : Sink;
+
+ begin
+ Create_File (S, "sinfo.h");
+ Put (S, "#ifdef __cplusplus" & LF);
+ Put (S, "extern ""C"" {" & LF);
+ Put (S, "#endif" & LF & LF);
+
+ Put (S, "typedef Boolean Flag;" & LF & LF);
+
+ Put_C_Type_And_Subtypes (S, Node_Kind);
+
+ Put (S, "// Getters corresponding to instantiations of Atree.Get_n_Bit_Field"
+ & LF & LF);
+
+ for T in Special_Type loop
+ Put_Low_Level_C_Getter (S, T);
+ end loop;
+
+ Put_High_Level_C_Getters (S, Node_Kind);
+
+ Put (S, "#ifdef __cplusplus" & LF);
+ Put (S, "}" & LF);
+ Put (S, "#endif" & LF);
+ end Put_Sinfo_Dot_H;
+
+ ---------------------
+ -- Put_Einfo_Dot_H --
+ ---------------------
+
+ procedure Put_Einfo_Dot_H is
+ S : Sink;
+
+ procedure Put_Membership_Query_Spec (T : Node_Or_Entity_Type);
+ procedure Put_Membership_Query_Defn (T : Node_Or_Entity_Type);
+ -- Print out the Is_... function for T that calls the IN macro on the
+ -- SUBTYPE.
+
+ procedure Put_Membership_Query_Spec (T : Node_Or_Entity_Type) is
+ Im : constant String := Image (T);
+ pragma Assert (Im (Im'Last - 4 .. Im'Last) = "_Kind");
+ Im2 : constant String := Im (Im'First .. Im'Last - 5);
+ Typ : constant String :=
+ (if Is_Descendant (Type_Kind, T)
+ and then T /= Type_Kind
+ then "_Type"
+ else "");
+ begin
+ pragma Assert (not Type_Table (T).Is_Union);
+
+ Put (S, "INLINE B Is_" & Im2 & Typ & " (E Id)");
+ end Put_Membership_Query_Spec;
+
+ procedure Put_Membership_Query_Defn (T : Node_Or_Entity_Type) is
+ begin
+ if T in Abstract_Type and T not in Root_Type then
+ Put_Membership_Query_Spec (T);
+ Put (S, "" & LF);
+ Increase_Indent (S, 3);
+ Put (S, "{ return IN (Ekind (Id), " & Image (T) & "); }" & LF);
+ Decrease_Indent (S, 3);
+ end if;
+ end Put_Membership_Query_Defn;
+
+ begin
+ Create_File (S, "einfo.h");
+ Put (S, "#ifdef __cplusplus" & LF);
+ Put (S, "extern ""C"" {" & LF);
+ Put (S, "#endif" & LF & LF);
+
+ Put (S, "typedef Boolean Flag;" & LF & LF);
+
+ Put_C_Type_And_Subtypes (S, Entity_Kind);
+
+ -- Note that we do not call Put_Low_Level_C_Getter here. Those are in
+ -- sinfo.h, so every file that #includes einfo.h must #include
+ -- sinfo.h first.
+
+ Put_High_Level_C_Getters (S, Entity_Kind);
+
+ Put (S, "// Abstract type queries" & LF & LF);
+
+ Iterate_Types (Entity_Kind, Pre => Put_Membership_Query_Defn'Access);
+
+ Put (S, LF & "#ifdef __cplusplus" & LF);
+ Put (S, "}" & LF);
+ Put (S, "#endif" & LF);
+ end Put_Einfo_Dot_H;
+
+ begin -- Compile
+
+ Check_Completeness;
+
+ Compute_Ranges (Node_Kind);
+ Compute_Ranges (Entity_Kind);
+ Compute_Fields_Per_Node;
+ Compute_Field_Offsets;
+ Compute_Type_Sizes;
+ Check_For_Syntactic_Field_Mismatch;
+
+ Verify_Type_Table;
+
+ Node_Field_Types_Used :=
+ Field_Types_Used (Node_Field'First, Node_Field'Last);
+ Entity_Field_Types_Used :=
+ Field_Types_Used (Entity_Field'First, Entity_Field'Last);
+
+ Put_Seinfo;
+
+ Put_Nodes;
+
+ Put_Entities;
+
+ Put_Nmake;
+
+ Put_Seinfo_Tables;
+
+ Put_Sinfo_Dot_H;
+ Put_Einfo_Dot_H;
+
+ end Compile;
+
+ --------
+ -- Sy --
+ --------
+
+ function Sy
+ (Field : Node_Field;
+ Field_Type : Type_Enum;
+ Default_Value : Field_Default_Value := No_Default;
+ Pre, Pre_Get, Pre_Set : String := "") return Field_Sequence is
+ begin
+ return
+ (1 => Create_Syntactic_Field
+ (Field, Field_Type, Default_Value, Pre, Pre_Get, Pre_Set));
+ end Sy;
+
+ --------
+ -- Sm --
+ --------
+
+ function Sm
+ (Field : Field_Enum;
+ Field_Type : Type_Enum;
+ Type_Only : Type_Only_Enum := No_Type_Only;
+ Pre, Pre_Get, Pre_Set : String := "") return Field_Sequence is
+ begin
+ return (1 => Create_Semantic_Field
+ (Field, Field_Type, Type_Only, Pre, Pre_Get, Pre_Set));
+ end Sm;
+
+end Gen_IL.Gen;
diff --git a/gcc/ada/gen_il-gen.ads b/gcc/ada/gen_il-gen.ads
new file mode 100644
index 0000000..1d24ebf
--- /dev/null
+++ b/gcc/ada/gen_il-gen.ads
@@ -0,0 +1,256 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- G E N _ I L . G E N --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 2020-2021, Free Software Foundation, Inc. --
+-- --
+-- GNAT is 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. --
+-- --
+------------------------------------------------------------------------------
+
+-- "Language design is library design and library design is language design".
+-- -- Bjarne Stroustrup
+
+-- This package provides a "little language" for defining type hierarchies,
+-- which we call "Gen_IL.Gen". In particular, it is used to describe the type
+-- hierarchies rooted at Node_Id and Entity_Id in the intermediate language
+-- used by GNAT.
+
+-- The type hierarchy is a strict hierarchy (treeish, no multiple
+-- inheritance). We have "abstract" and "concrete" types. Each type has a
+-- "parent", except for the root type (Node_Id or Entity_Id). All leaf types
+-- in the hierarchy are concrete; all nonleaf types (including the two root
+-- types) are abstract. One can create instances of concrete, but not
+-- abstract, types.
+--
+-- Descendants of Node_Id/Node_Kind are node types, and descendants of
+-- Entity_Id/Entity_Kind are entity types.
+--
+-- Types have "fields". Each type inherits all the fields from its parent, and
+-- may add new ones. A node field can be marked "syntactic"; entity fields are
+-- never syntactic. A nonsyntactic field is "semantic".
+--
+-- If a field is syntactic, then the constructors in Nmake take a parameter to
+-- initialize that field. In addition, the tree-traversal routines in Atree
+-- (Traverse_Func and Traverse_Proc) traverse syntactic fields that are of
+-- type Node_Id (or subtypes of Node_Id) or List_Id. Finally, (with some
+-- exceptions documented in the body) the setter for a syntactic node or list
+-- field "Set_F (N, Val)" will set the Parent of Val to N, unless Val is Empty
+-- or Error[_List].
+--
+-- Note that the same field can be syntactic in some node types but semantic
+-- in other node types. This is an added complexity that we might want to
+-- eliminate someday. We shouldn't add any new such cases.
+--
+-- A "program" written in the Gen_IL.Gen language consists of calls to the
+-- "Create_..." routines below, followed by a call to Compile, also below. In
+-- order to understand what's going on, you need to look not only at the
+-- Gen_IL.Gen "code", but at the output of the compiler -- at least, look at
+-- the specs of Sinfo.Nodes and Einfo.Entities, because GNAT invokes those
+-- directly. It's not like a normal language where you don't usually have to
+-- look at the generated machine code.
+--
+-- Thus, the Gen_IL.Gen code is really Ada code, and when you run it as an Ada
+-- program, it generates the above-mentioned files. The program is somewhat
+-- unusual in that it has no input. Everything it needs to generate code is
+-- embodied in it.
+
+-- Why don't we just use a variant record, instead of inventing a wheel?
+-- Or a hierarchy of tagged types?
+--
+-- The key feature that Ada's variant records and tagged types lack, and that
+-- this little language has, is that if two types have a field with the same
+-- name, then those are the same field, even though they weren't inherited
+-- from a common ancestor. Such fields are required to have the same type, the
+-- same default value, and the same extra precondition.
+
+with Gen_IL.Types; use Gen_IL.Types;
+pragma Warnings (Off);
+with Gen_IL.Fields; use Gen_IL.Fields; -- for children
+pragma Warnings (On);
+with Gen_IL.Internals; use Gen_IL.Internals;
+use Gen_IL.Internals.Type_Vectors;
+use Gen_IL.Internals.Field_Vectors;
+
+package Gen_IL.Gen is
+
+ procedure Create_Root_Node_Type
+ (T : Abstract_Node;
+ Fields : Field_Sequence := No_Fields)
+ with Pre => T = Node_Kind;
+ -- Create the root node type (Node_Kind), which is an abstract type
+
+ procedure Create_Abstract_Node_Type
+ (T : Abstract_Node; Parent : Abstract_Type;
+ Fields : Field_Sequence := No_Fields);
+ -- Create an abstract node type (other than the root node type)
+
+ procedure Create_Concrete_Node_Type
+ (T : Concrete_Node; Parent : Abstract_Type;
+ Fields : Field_Sequence := No_Fields;
+ Nmake_Assert : String := "");
+ -- Create a concrete node type. Every node is an instance of a concrete
+ -- node type. Nmake_Assert is an assertion to put in the Make_... function
+ -- in the generated Nmake package. It should be a String that represents a
+ -- Boolean expression.
+
+ procedure Create_Root_Entity_Type
+ (T : Abstract_Entity;
+ Fields : Field_Sequence := No_Fields)
+ with Pre => T = Entity_Kind;
+ -- Create the root entity type (Entity_Kind), which is an abstract type
+
+ procedure Create_Abstract_Entity_Type
+ (T : Abstract_Entity; Parent : Abstract_Type;
+ Fields : Field_Sequence := No_Fields);
+ -- Create an abstract entity type (other than the root entity type)
+
+ procedure Create_Concrete_Entity_Type
+ (T : Concrete_Entity; Parent : Abstract_Type;
+ Fields : Field_Sequence := No_Fields);
+ -- Create a concrete entity type. Every entity is an instance of a concrete
+ -- entity type.
+
+ function Create_Syntactic_Field
+ (Field : Node_Field;
+ Field_Type : Type_Enum;
+ Default_Value : Field_Default_Value := No_Default;
+ Pre, Pre_Get, Pre_Set : String := "") return Field_Desc;
+ -- Create a syntactic field of a node type. Entities do not have syntactic
+ -- fields.
+
+ function Create_Semantic_Field
+ (Field : Field_Enum;
+ Field_Type : Type_Enum;
+ Type_Only : Type_Only_Enum := No_Type_Only;
+ Pre, Pre_Get, Pre_Set : String := "") return Field_Desc;
+ -- Create a semantic field of a node or entity type
+
+ -- Create_Syntactic_Field is used for syntactic fields of nodes. The order
+ -- of calls to Create_Syntactic_Field determines the order of the formal
+ -- parameters of the Make_... functions in Nmake.
+ --
+ -- Create_Semantic_Field is used for semantic fields of nodes, and all
+ -- fields of entities are considered semantic. The order of calls doesn't
+ -- make any difference.
+ --
+ -- Field_Type is the type of the field. Default_Value is the default value
+ -- for the parameter of the Make_... function in Nmake; this is effective
+ -- only for syntactic fields. Flag fields of syntactic nodes always have a
+ -- default value, which is False unless specified as Default_True. Pre is
+ -- an additional precondition for the field getter and setter, in addition
+ -- to the precondition that asserts that the type has that field. It should
+ -- be a String that represents a Boolean expression. Pre_Get and Pre_Set
+ -- are similar to Pre, but for the getter or setter only, respectively.
+ --
+ -- If multiple calls to these occur for the same Field but different types,
+ -- the Field_Type, Pre, Pre_Get, and Pre_Set must match. Default_Value
+ -- should match for syntactic fields. See the declaration of Type_Only_Enum
+ -- for Type_Only.
+ --
+ -- (The matching Default_Value requirement is a simplification from the
+ -- earlier hand-written version.)
+
+ -- When adding new node or entity kinds, or adding new fields, all back
+ -- ends must be made aware of the changes. In addition, the documentation
+ -- in Sinfo or Einfo needs to be updated.
+
+ -- To add a new node or entity type, add it to the enumeration type in
+ -- Gen_IL.Types, taking care that it is in the approprate range
+ -- (Abstract_Node, Abstract_Entity, Concrete_Node, or Concrete_Entity).
+ -- Then add a call to one of the above type-creation procedures to
+ -- Gen_IL.Gen.Gen_Nodes or Gen_IL.Gen.Gen_Entities.
+ --
+ -- To add a new field to a type, add it to the enumeration type in
+ -- Gen_IL.Fields in the appropriate range. Then add a call to one of
+ -- the above field-creation procedures to Gen_IL.Gen.Gen_Nodes or
+ -- Gen_IL.Gen.Gen_Entities.
+ --
+ -- If a type or field name does not follow the usual Mixed_Case convention,
+ -- such as "SPARK_Pragma", then you have to add a special case to one of
+ -- the Image functions in Gen_IL.Internals and in Treepr.
+
+ -- Forward references are not allowed. So if you say:
+ --
+ -- Create..._Type (..., Parent => P);
+ --
+ -- then Create..._Type must have already been called to create P.
+ --
+ -- Likewise, if you say:
+ --
+ -- Create..._Field (T, F, Field_Type, ...);
+ --
+ -- then Create..._Type must have already been called to create T and
+ -- (if it's a node or entity type) to create Field_Type.
+ --
+ -- To delete a node or entity type, delete it from Gen_IL.Types, update the
+ -- subranges in Gen_IL.Internals if necessary, and delete all occurrences
+ -- from Gen_IL.Gen.Gen_Entities. To delete a field, delete it from
+ -- Gen_IL.Fields, and delete all occurrences from Gen_IL.Gen.Gen_Entities.
+
+ -- If a field is not set, it is initialized by default to whatever value is
+ -- represented by all-zero bits, with two exceptions: Elist fields default
+ -- to No_Elist, and Uint fields default to Uint_0. In retrospect, it would
+ -- have been better to use No_Uint instead of Uint_0.
+
+ procedure Create_Node_Union_Type
+ (T : Abstract_Node; Children : Type_Array);
+ procedure Create_Entity_Union_Type
+ (T : Abstract_Entity; Children : Type_Array);
+ -- Create a "union" type that is the union of the Children. This is used
+ -- for nonhierachical types. This is the opposite of the normal "object
+ -- oriented" routines above, which create child types based on existing
+ -- parents. Here we are creating parent types based on existing child
+ -- types. A union type is considered to be an abstract type because it has
+ -- multiple children. We do not allow union types to have their own fields,
+ -- because that would introduce the well-known complexity of multiple
+ -- inheritance. That restriction could be relaxed, but for now, union types
+ -- are mainly for allowing things like "Pre => X in Some_Union_Type".
+
+ Illegal : exception;
+ -- Exception raised when Gen_IL code (in particular in Gen_Nodes and
+ -- Gen_Entities) is illegal. We don't try elaborate error recovery, but
+ -- hopefully the exception message will indicate what's wrong. You might
+ -- have to go in the debugger to see which line it's complaining about.
+
+ procedure Compile;
+
+private
+
+ function Sy
+ (Field : Node_Field;
+ Field_Type : Type_Enum;
+ Default_Value : Field_Default_Value := No_Default;
+ Pre, Pre_Get, Pre_Set : String := "") return Field_Sequence;
+ function Sm
+ (Field : Field_Enum;
+ Field_Type : Type_Enum;
+ Type_Only : Type_Only_Enum := No_Type_Only;
+ Pre, Pre_Get, Pre_Set : String := "") return Field_Sequence;
+ -- The above functions return Field_Sequence. This is a trick to get around
+ -- the fact that Ada doesn't allow singleton positional aggregates. It
+ -- allows us to write things like:
+ --
+ -- Cc (N_Empty, Node_Kind,
+ -- (Sy (Chars, Name_Id, Default_No_Name)));
+ --
+ -- where that thing pretending to be an aggregate is really a parenthesized
+ -- expression. See Gen_Nodes for documentation of the functions these are
+ -- standing in for.
+
+end Gen_IL.Gen;
diff --git a/gcc/ada/gen_il-internals.adb b/gcc/ada/gen_il-internals.adb
new file mode 100644
index 0000000..d77fe7a
--- /dev/null
+++ b/gcc/ada/gen_il-internals.adb
@@ -0,0 +1,480 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- G E N _ I L . U T I L S --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 2020-2021, Free Software Foundation, Inc. --
+-- --
+-- GNAT is 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. --
+-- --
+------------------------------------------------------------------------------
+
+package body Gen_IL.Internals is
+
+ ---------
+ -- Nil --
+ ---------
+
+ procedure Nil (T : Node_Or_Entity_Type) is
+ begin
+ null;
+ end Nil;
+
+ --------------------
+ -- Node_Or_Entity --
+ --------------------
+
+ function Node_Or_Entity (Root : Root_Type) return String is
+ begin
+ if Root = Node_Kind then
+ return "Node";
+ else
+ return "Entity";
+ end if;
+ end Node_Or_Entity;
+
+ ------------------------------
+ -- Num_Concrete_Descendants --
+ ------------------------------
+
+ function Num_Concrete_Descendants
+ (T : Node_Or_Entity_Type) return Natural is
+ begin
+ return Concrete_Type'Pos (Type_Table (T).Last) -
+ Concrete_Type'Pos (Type_Table (T).First) + 1;
+ end Num_Concrete_Descendants;
+
+ function First_Abstract (Root : Root_Type) return Abstract_Type is
+ (case Root is
+ when Node_Kind => Abstract_Node'First,
+ when others => Abstract_Entity'First); -- Entity_Kind
+ function Last_Abstract (Root : Root_Type) return Abstract_Type is
+ (case Root is
+ when Node_Kind => Abstract_Node'Last,
+ when others => Abstract_Entity'Last); -- Entity_Kind
+
+ function First_Concrete (Root : Root_Type) return Concrete_Type is
+ (case Root is
+ when Node_Kind => Concrete_Node'First,
+ when others => Concrete_Entity'First); -- Entity_Kind
+ function Last_Concrete (Root : Root_Type) return Concrete_Type is
+ (case Root is
+ when Node_Kind => Concrete_Node'Last,
+ when others => Concrete_Entity'Last); -- Entity_Kind
+
+ function First_Field (Root : Root_Type) return Field_Enum is
+ (case Root is
+ when Node_Kind => Node_Field'First,
+ when others => Entity_Field'First); -- Entity_Kind
+ function Last_Field (Root : Root_Type) return Field_Enum is
+ (case Root is
+ when Node_Kind => Node_Field'Last,
+ when others => Entity_Field'Last); -- Entity_Kind
+
+ -----------------------
+ -- Verify_Type_Table --
+ -----------------------
+
+ procedure Verify_Type_Table is
+ begin
+ for T in Node_Or_Entity_Type loop
+ if Type_Table (T) /= null then
+ if not Type_Table (T).Is_Union then
+ case T is
+ when Concrete_Node | Concrete_Entity =>
+ pragma Assert (Type_Table (T).First = T);
+ pragma Assert (Type_Table (T).Last = T);
+
+ when Abstract_Node | Abstract_Entity =>
+ pragma Assert
+ (Type_Table (T).First < Type_Table (T).Last);
+
+ when Type_Boundaries =>
+ null;
+ end case;
+ end if;
+ end if;
+ end loop;
+ end Verify_Type_Table;
+
+ --------------
+ -- Id_Image --
+ --------------
+
+ function Id_Image (T : Type_Enum) return String is
+ begin
+ case T is
+ when Flag =>
+ return "Boolean";
+ when Node_Kind =>
+ return "Node_Id";
+ when Entity_Kind =>
+ return "Entity_Id";
+ when Node_Kind_Type =>
+ return "Node_Kind";
+ when Entity_Kind_Type =>
+ return "Entity_Kind";
+ when others =>
+ return Image (T) & "_Id";
+ end case;
+ end Id_Image;
+
+ ----------------------
+ -- Get_Set_Id_Image --
+ ----------------------
+
+ function Get_Set_Id_Image (T : Type_Enum) return String is
+ begin
+ case T is
+ when Node_Kind =>
+ return "Node_Id";
+ when Entity_Kind =>
+ return "Entity_Id";
+ when Node_Kind_Type =>
+ return "Node_Kind";
+ when Entity_Kind_Type =>
+ return "Entity_Kind";
+ when others =>
+ return Image (T);
+ end case;
+ end Get_Set_Id_Image;
+
+ -----------
+ -- Image --
+ -----------
+
+ function Image (T : Opt_Type_Enum) return String is
+ begin
+ case T is
+ -- We special case the following; otherwise the compiler will give
+ -- "wrong case" warnings in compiler code.
+
+ when N_Pop_xxx_Label =>
+ return "N_Pop_xxx_Label";
+
+ when N_Push_Pop_xxx_Label =>
+ return "N_Push_Pop_xxx_Label";
+
+ when N_Push_xxx_Label =>
+ return "N_Push_xxx_Label";
+
+ when N_Raise_xxx_Error =>
+ return "N_Raise_xxx_Error";
+
+ when N_SCIL_Node =>
+ return "N_SCIL_Node";
+
+ when N_SCIL_Dispatch_Table_Tag_Init =>
+ return "N_SCIL_Dispatch_Table_Tag_Init";
+
+ when N_SCIL_Dispatching_Call =>
+ return "N_SCIL_Dispatching_Call";
+
+ when N_SCIL_Membership_Test =>
+ return "N_SCIL_Membership_Test";
+
+ when others =>
+ return Capitalize (T'Img);
+ end case;
+ end Image;
+
+ ------------------
+ -- Image_Sans_N --
+ ------------------
+
+ function Image_Sans_N (T : Opt_Type_Enum) return String is
+ Im : constant String := Image (T);
+ pragma Assert (Im (1 .. 2) = "N_");
+ begin
+ return Im (3 .. Im'Last);
+ end Image_Sans_N;
+
+ -------------------------
+ -- Put_Types_With_Bars --
+ -------------------------
+
+ procedure Put_Types_With_Bars (S : in out Sink; U : Type_Vector) is
+ First_Time : Boolean := True;
+ begin
+ Increase_Indent (S, 3);
+
+ for T of U loop
+ if First_Time then
+ First_Time := False;
+ else
+ Put (S, LF & "| ");
+ end if;
+
+ Put (S, Image (T));
+ end loop;
+
+ Decrease_Indent (S, 3);
+ end Put_Types_With_Bars;
+
+ ----------------------------
+ -- Put_Type_Ids_With_Bars --
+ ----------------------------
+
+ procedure Put_Type_Ids_With_Bars (S : in out Sink; U : Type_Vector) is
+ First_Time : Boolean := True;
+ begin
+ Increase_Indent (S, 3);
+
+ for T of U loop
+ if First_Time then
+ First_Time := False;
+ else
+ Put (S, LF & "| ");
+ end if;
+
+ Put (S, Id_Image (T));
+ end loop;
+
+ Decrease_Indent (S, 3);
+ end Put_Type_Ids_With_Bars;
+
+ -----------
+ -- Image --
+ -----------
+
+ function Image (F : Opt_Field_Enum) return String is
+ begin
+ case F is
+ -- Special cases for the same reason as in the above Image
+ -- function.
+
+ when Alloc_For_BIP_Return =>
+ return "Alloc_For_BIP_Return";
+ when Assignment_OK =>
+ return "Assignment_OK";
+ when Backwards_OK =>
+ return "Backwards_OK";
+ when BIP_Initialization_Call =>
+ return "BIP_Initialization_Call";
+ when Body_Needed_For_SAL =>
+ return "Body_Needed_For_SAL";
+ when Conversion_OK =>
+ return "Conversion_OK";
+ when CR_Discriminant =>
+ return "CR_Discriminant";
+ when DTC_Entity =>
+ return "DTC_Entity";
+ when DT_Entry_Count =>
+ return "DT_Entry_Count";
+ when DT_Offset_To_Top_Func =>
+ return "DT_Offset_To_Top_Func";
+ when DT_Position =>
+ return "DT_Position";
+ when Forwards_OK =>
+ return "Forwards_OK";
+ when Has_Inherited_DIC =>
+ return "Has_Inherited_DIC";
+ when Has_Own_DIC =>
+ return "Has_Own_DIC";
+ when Has_RACW =>
+ return "Has_RACW";
+ when Has_SP_Choice =>
+ return "Has_SP_Choice";
+ when Ignore_SPARK_Mode_Pragmas =>
+ return "Ignore_SPARK_Mode_Pragmas";
+ when Is_Constr_Subt_For_UN_Aliased =>
+ return "Is_Constr_Subt_For_UN_Aliased";
+ when Is_CPP_Class =>
+ return "Is_CPP_Class";
+ when Is_CUDA_Kernel =>
+ return "Is_CUDA_Kernel";
+ when Is_DIC_Procedure =>
+ return "Is_DIC_Procedure";
+ when Is_Discrim_SO_Function =>
+ return "Is_Discrim_SO_Function";
+ when Is_Elaboration_Checks_OK_Id =>
+ return "Is_Elaboration_Checks_OK_Id";
+ when Is_Elaboration_Checks_OK_Node =>
+ return "Is_Elaboration_Checks_OK_Node";
+ when Is_Elaboration_Warnings_OK_Id =>
+ return "Is_Elaboration_Warnings_OK_Id";
+ when Is_Elaboration_Warnings_OK_Node =>
+ return "Is_Elaboration_Warnings_OK_Node";
+ when Is_Known_Guaranteed_ABE =>
+ return "Is_Known_Guaranteed_ABE";
+ when Is_RACW_Stub_Type =>
+ return "Is_RACW_Stub_Type";
+ when Is_SPARK_Mode_On_Node =>
+ return "Is_SPARK_Mode_On_Node";
+ when Local_Raise_Not_OK =>
+ return "Local_Raise_Not_OK";
+ when LSP_Subprogram =>
+ return "LSP_Subprogram";
+ when OK_To_Rename =>
+ return "OK_To_Rename";
+ when Referenced_As_LHS =>
+ return "Referenced_As_LHS";
+ when RM_Size =>
+ return "RM_Size";
+ when SCIL_Controlling_Tag =>
+ return "SCIL_Controlling_Tag";
+ when SCIL_Entity =>
+ return "SCIL_Entity";
+ when SCIL_Tag_Value =>
+ return "SCIL_Tag_Value";
+ when SCIL_Target_Prim =>
+ return "SCIL_Target_Prim";
+ when Shift_Count_OK =>
+ return "Shift_Count_OK";
+ when SPARK_Aux_Pragma =>
+ return "SPARK_Aux_Pragma";
+ when SPARK_Aux_Pragma_Inherited =>
+ return "SPARK_Aux_Pragma_Inherited";
+ when SPARK_Pragma =>
+ return "SPARK_Pragma";
+ when SPARK_Pragma_Inherited =>
+ return "SPARK_Pragma_Inherited";
+ when Split_PPC =>
+ return "Split_PPC";
+ when SSO_Set_High_By_Default =>
+ return "SSO_Set_High_By_Default";
+ when SSO_Set_Low_By_Default =>
+ return "SSO_Set_Low_By_Default";
+ when TSS_Elist =>
+ return "TSS_Elist";
+
+ when others =>
+ return Capitalize (F'Img);
+ end case;
+ end Image;
+
+ function Image (Default : Field_Default_Value) return String is
+ (Capitalize (Default'Img));
+
+ -----------------
+ -- Value_Image --
+ -----------------
+
+ function Value_Image (Default : Field_Default_Value) return String is
+ begin
+ if Default = No_Default then
+ return Image (Default);
+
+ else
+ -- Strip off the prefix and capitalize it
+
+ declare
+ Im : constant String := Image (Default);
+ Prefix : constant String := "Default_";
+ begin
+ pragma Assert (Im (1 .. Prefix'Length) = Prefix);
+ return Im (Prefix'Length + 1 .. Im'Last);
+ end;
+ end if;
+ end Value_Image;
+
+ -------------------
+ -- Iterate_Types --
+ -------------------
+
+ procedure Iterate_Types
+ (Root : Node_Or_Entity_Type;
+ Pre, Post : not null access procedure (T : Node_Or_Entity_Type) :=
+ Nil'Access)
+ is
+ procedure Recursive (T : Node_Or_Entity_Type);
+ -- Recursive walk
+
+ procedure Recursive (T : Node_Or_Entity_Type) is
+ begin
+ Pre (T);
+
+ for Child of Type_Table (T).Children loop
+ Recursive (Child);
+ end loop;
+
+ Post (T);
+ end Recursive;
+
+ begin
+ Recursive (Root);
+ end Iterate_Types;
+
+ -------------------
+ -- Is_Descendant --
+ -------------------
+
+ function Is_Descendant (Ancestor, Descendant : Node_Or_Entity_Type)
+ return Boolean is
+ begin
+ if Ancestor = Descendant then
+ return True;
+
+ elsif Descendant in Root_Type then
+ return False;
+
+ else
+ return Is_Descendant (Ancestor, Type_Table (Descendant).Parent);
+ end if;
+ end Is_Descendant;
+
+ ------------------------
+ -- Put_Type_Hierarchy --
+ ------------------------
+
+ procedure Put_Type_Hierarchy (S : in out Sink; Root : Root_Type) is
+ Level : Natural := 0;
+
+ function Indentation return String is ((1 .. 3 * Level => ' '));
+ -- Indentation string of space characters. We can't use the Indent
+ -- primitive, because we want this indentation after the "--".
+
+ procedure Pre (T : Node_Or_Entity_Type);
+ procedure Post (T : Node_Or_Entity_Type);
+ -- Pre and Post actions passed to Iterate_Types
+
+ procedure Pre (T : Node_Or_Entity_Type) is
+ begin
+ Put (S, "-- " & Indentation & Image (T) & LF);
+ Level := Level + 1;
+ end Pre;
+
+ procedure Post (T : Node_Or_Entity_Type) is
+ begin
+ Level := Level - 1;
+
+ -- Put out an "end" line only if there are many descendants, for
+ -- an arbitrary definition of "many".
+
+ if Num_Concrete_Descendants (T) > 10 then
+ Put (S, "-- " & Indentation & "end " & Image (T) & LF);
+ end if;
+ end Post;
+
+ N_Or_E : constant String :=
+ (case Root is
+ when Node_Kind => "nodes",
+ when others => "entities"); -- Entity_Kind
+
+ -- Start of processing for Put_Type_Hierarchy
+
+ begin
+ Put (S, "-- Type hierarchy for " & N_Or_E & LF);
+ Put (S, "--" & LF);
+
+ Iterate_Types (Root, Pre'Access, Post'Access);
+
+ Put (S, "--" & LF);
+ Put (S, "-- End type hierarchy for " & N_Or_E & LF & LF);
+ end Put_Type_Hierarchy;
+
+end Gen_IL.Internals;
diff --git a/gcc/ada/gen_il-internals.ads b/gcc/ada/gen_il-internals.ads
new file mode 100644
index 0000000..ae448de
--- /dev/null
+++ b/gcc/ada/gen_il-internals.ads
@@ -0,0 +1,282 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- G E N _ I L . U T I L S --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 2020-2021, Free Software Foundation, Inc. --
+-- --
+-- GNAT is 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 Ada.Containers.Vectors; use Ada.Containers;
+
+with GNAT.Strings; use GNAT.Strings;
+
+with Gen_IL.Types; use Gen_IL.Types;
+with Gen_IL.Fields; use Gen_IL.Fields;
+
+package Gen_IL.Internals is
+
+ function Image (T : Opt_Type_Enum) return String;
+
+ function Image_Sans_N (T : Opt_Type_Enum) return String;
+ -- Returns the image without the leading "N_"
+
+ ----------------
+
+ type Type_Set is array (Type_Enum) of Boolean;
+
+ type Type_Index is new Positive;
+ subtype Type_Count is Type_Index'Base range 0 .. Type_Index'Last;
+ package Type_Vectors is new Vectors (Type_Index, Type_Enum);
+ use Type_Vectors;
+ subtype Type_Vector is Type_Vectors.Vector;
+
+ type Type_Array is array (Type_Index range <>) of Type_Enum;
+
+ ----------------
+
+ procedure Put_Types_With_Bars (S : in out Sink; U : Type_Vector);
+ procedure Put_Type_Ids_With_Bars (S : in out Sink; U : Type_Vector);
+ -- Put the types with vertical bars in between, as in
+ -- N_This | N_That | N_Other
+ -- or
+ -- N_This_Id | N_That_Id | N_Other_Id
+
+ function Id_Image (T : Type_Enum) return String;
+ -- Image of the type for use with _Id types
+
+ function Get_Set_Id_Image (T : Type_Enum) return String;
+ -- Image of the type for use with getters and setters
+
+ ----------------
+
+ type Fields_Present_Array is array (Field_Enum) of Type_Set;
+
+ type Field_Set is array (Field_Enum) of Boolean;
+ type Fields_Per_Node_Type is array (Node_Or_Entity_Type) of Field_Set;
+
+ type Field_Index is new Positive;
+ package Field_Vectors is new Vectors (Field_Index, Field_Enum);
+ subtype Field_Vector is Field_Vectors.Vector;
+
+ type Bit_Offset is new Root_Nat range 0 .. 32_000 - 1;
+ -- Offset in bits. The number 32_000 is chosen because there are fewer than
+ -- 1000 fields, but offsets are in size units (1 bit for flags, 32 bits for
+ -- most others, also 2, 4, and 8).
+
+ type Field_Offset is new Bit_Offset;
+
+ type Type_Info (Is_Union : Boolean) is record
+ Parent : Opt_Abstract_Type;
+ -- Parent of this type (single inheritance). No_Type for a root
+ -- type (Node_Kind or Entity_Kind). For union types, this is
+ -- a root type.
+
+ Children : Type_Vector;
+ -- Inverse of Parent
+
+ Concrete_Descendants : Type_Vector;
+
+ case Is_Union is
+ when True =>
+ null;
+
+ when False =>
+ First, Last : Concrete_Type;
+ -- This type includes concrete types in the range First..Last. For
+ -- a concrete type, First=Last. For an abstract type, First..Last
+ -- includes two or more types.
+
+ Fields : Field_Vector;
+
+ Nmake_Assert : String_Access; -- only for concrete node types
+ end case;
+ end record;
+
+ type Type_Info_Ptr is access all Type_Info;
+
+ Type_Table : array (Node_Or_Entity_Type) of Type_Info_Ptr;
+ -- Table mapping from enumeration literals representing types to
+ -- information about the type.
+
+ procedure Verify_Type_Table;
+ -- Check Type_Table for consistency
+
+ function Num_Concrete_Descendants
+ (T : Node_Or_Entity_Type) return Natural;
+ -- Number of concrete descendants of T, including (if T is concrete)
+ -- itself.
+
+ type Field_Default_Value is
+ (No_Default,
+ Default_Empty, -- Node_Id
+ Default_No_List, Default_Empty_List, -- List_Id
+ Default_False, Default_True, -- Flag
+ Default_No_Elist, -- Elist_Id
+ Default_No_Name, -- Name_Id
+ Default_Uint_0); -- Uint
+ -- Default value for a field in the Nmake functions. No_Default if the
+ -- field parameter has no default value. Otherwise this indicates the
+ -- default value used, which must matcht the type of the field.
+
+ function Image (Default : Field_Default_Value) return String;
+ -- This will be something like "Default_Empty".
+ function Value_Image (Default : Field_Default_Value) return String;
+ -- This will be something like "Empty".
+
+ type Type_Only_Enum is
+ (No_Type_Only, Base_Type_Only, Impl_Base_Type_Only, Root_Type_Only);
+ -- These correspond to the "[base type only]", "[implementation base type
+ -- only]", and "[root type only]" annotations documented in einfo.ads.
+ -- The default is No_Type_Only, indicating the field is not one of
+ -- these special "[... only]" ones.
+
+ type Field_Info is record
+ Have_This_Field : Type_Vector;
+ -- Types that have this field
+
+ Field_Type : Type_Enum;
+ -- Type of the field. Currently, we use Node_Id for all node-valued
+ -- fields, but we could narrow down to children of that. Similar for
+ -- Entity_Id.
+
+ Default_Value : Field_Default_Value;
+ Type_Only : Type_Only_Enum;
+ Pre, Pre_Get, Pre_Set : String_Access;
+ -- Above record the information in the calls to Create_...Field.
+ -- See Gen_IL.Gen for details.
+
+ Offset : Field_Offset;
+ -- Offset of the field from the start of the node, in units of the field
+ -- size. So if a field is 4 bits in size, it starts at bit number
+ -- Offset*4 from the start of the node.
+ end record;
+
+ type Field_Info_Ptr is access all Field_Info;
+
+ Field_Table : array (Field_Enum) of Field_Info_Ptr;
+ -- Table mapping from enumeration literals representing fields to
+ -- information about the field.
+
+ -- Getters for fields of types Elist_Id and Uint need special treatment of
+ -- defaults. In particular, if the field has its initial 0 value, getters
+ -- need to return the appropriate default value. Note that these defaults
+ -- have nothing to do with the defaults mentioned above for Nmake
+ -- functions.
+
+ function Field_Has_Special_Default
+ (Field_Type : Type_Enum) return Boolean is
+ (Field_Type in Elist_Id | Uint);
+ -- These are the field types that have a default value that is not
+ -- represented as zero.
+
+ function Special_Default
+ (Field_Type : Type_Enum) return String is
+ (if Field_Type = Elist_Id then "No_Elist" else "Uint_0");
+
+ function Invalid_Val
+ (Field_Type : Uint_Subtype) return String is
+ ("No_Uint");
+ -- We could generalize this to other than Uint at some point
+
+ ----------------
+
+ subtype Node_Field is
+ Field_Enum range
+ Field_Enum'First ..
+ Field_Enum'Pred (Between_Node_And_Entity_Fields);
+
+ subtype Entity_Field is
+ Field_Enum range
+ Field_Enum'Succ (Between_Node_And_Entity_Fields) ..
+ Field_Enum'Last;
+
+ function Image (F : Opt_Field_Enum) return String;
+
+ function F_Image (F : Opt_Field_Enum) return String is
+ ("F_" & Image (F));
+ -- Prepends "F_" to Image (F). This is used for the enumeration literals in
+ -- the generated Sinfo.Nodes.Node_Field and Einfo.Entities.Entity_Field
+ -- types. If we used Image (F), these enumeration literals would overload
+ -- the getter functions, which confuses gdb.
+
+ procedure Nil (T : Node_Or_Entity_Type);
+ -- Null procedure
+
+ procedure Iterate_Types
+ (Root : Node_Or_Entity_Type;
+ Pre, Post : not null access procedure (T : Node_Or_Entity_Type) :=
+ Nil'Access);
+ -- Iterate top-down on the type hierarchy. Call Pre and Post before and
+ -- after walking child types. Note that this ignores union types, because
+ -- they are nonhierarchical. The order in which concrete types are visited
+ -- matches the order of the generated enumeration types Node_Kind and
+ -- Entity_Kind, which is not the same as the order of the Type_Enum
+ -- type in Gen_IL.Types.
+
+ function Is_Descendant (Ancestor, Descendant : Node_Or_Entity_Type)
+ return Boolean;
+ -- True if Descendant is a descendant of Ancestor; that is,
+ -- True if Ancestor is an ancestor of Descendant. True for
+ -- a type itself.
+
+ procedure Put_Type_Hierarchy (S : in out Sink; Root : Root_Type);
+
+ ----------------
+
+ type Field_Desc is record
+ F : Field_Enum;
+ Is_Syntactic : Boolean;
+ -- The same field can be syntactic in some nodes but semantic in others
+ end record;
+
+ type Field_Sequence_Index is new Positive;
+ type Field_Sequence is array (Field_Sequence_Index range <>) of Field_Desc;
+ No_Fields : constant Field_Sequence := (1 .. 0 => <>);
+
+ type Field_Array is array (Bit_Offset range <>) of Opt_Field_Enum;
+ type Field_Array_Ptr is access all Field_Array;
+
+ type Concrete_Type_Layout_Array is array (Concrete_Type) of Field_Array_Ptr;
+ -- Mapping from types to mappings from offsets to fields. Each bit offset
+ -- is mapped to the corresponding field for the given type. An n-bit field
+ -- will have n bit offsets mapped to the same field.
+
+ type Offset_To_Fields_Mapping is
+ array (Bit_Offset range <>) of Field_Array_Ptr;
+ -- Mapping from bit offsets to fields using that offset
+
+ function First_Abstract (Root : Root_Type) return Abstract_Type;
+ function Last_Abstract (Root : Root_Type) return Abstract_Type;
+ -- First and Last abstract types descended from the Root. So for example if
+ -- Root = Node_Kind, then First_Abstract = Abstract_Node'First.
+
+ function First_Concrete (Root : Root_Type) return Concrete_Type;
+ function Last_Concrete (Root : Root_Type) return Concrete_Type;
+ -- First and Last concrete types descended from the Root
+
+ function First_Field (Root : Root_Type) return Field_Enum;
+ function Last_Field (Root : Root_Type) return Field_Enum;
+ -- First and Last node or entity fields
+
+ function Node_Or_Entity (Root : Root_Type) return String;
+ -- Return "Node" or "Entity" depending on whether Root = Node_Kind or
+ -- Entity_Kind.
+
+end Gen_IL.Internals;
diff --git a/gcc/ada/gen_il-main.adb b/gcc/ada/gen_il-main.adb
new file mode 100644
index 0000000..d624406
--- /dev/null
+++ b/gcc/ada/gen_il-main.adb
@@ -0,0 +1,34 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- G E N _ I L . M A I N --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 2020-2021, Free Software Foundation, Inc. --
+-- --
+-- GNAT is 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 Gen_IL.Gen.Gen_Nodes;
+with Gen_IL.Gen.Gen_Entities;
+
+procedure Gen_IL.Main is
+begin
+ Gen_IL.Gen.Gen_Nodes;
+ Gen_IL.Gen.Gen_Entities;
+ Gen_IL.Gen.Compile;
+end Gen_IL.Main;
diff --git a/gcc/ada/gen_il-types.ads b/gcc/ada/gen_il-types.ads
new file mode 100644
index 0000000..321eec6
--- /dev/null
+++ b/gcc/ada/gen_il-types.ads
@@ -0,0 +1,582 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- G E N _ I L . T Y P E S --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 2020-2021, Free Software Foundation, Inc. --
+-- --
+-- GNAT is 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. --
+-- --
+------------------------------------------------------------------------------
+
+package Gen_IL.Types is
+
+ -- Enumeration of all the types that are "of interest". We have an
+ -- enumeration literal here for every node kind, every entity kind,
+ -- and every type that can be the type of a field.
+
+ -- The following is "optional type enumeration" -- i.e. it is Type_Enum
+ -- (declared below) plus the special null value No_Type. See the spec of
+ -- Gen_IL.Gen for how to modify this. (Of course, in Ada we have to define
+ -- this backwards from the above conceptual description.)
+
+ -- Note that there are various subranges of this type declared below,
+ -- which might need to be kept in sync when modifying this.
+
+ -- The "Between_..." literals below are simply for making the subranges.
+ -- When adding literals to this enumeration type, be sure to put them in
+ -- the right place so they end up in the appropriate subranges
+ -- (Abstract_Node, Abstract_Entity, Concrete_Node, Concrete_Entity).
+
+ type Opt_Type_Enum is
+ (No_Type,
+
+ Flag,
+ -- We use Flag for Boolean, so we don't conflict with
+ -- Standard.Boolean.
+
+ Node_Id,
+ List_Id,
+ Elist_Id,
+ Name_Id,
+ String_Id,
+ Uint,
+ Valid_Uint,
+ Unat,
+ Upos,
+ Nonzero_Uint,
+ Ureal,
+
+ Node_Kind_Type, -- Type of result of Nkind function, i.e. Node_Kind
+ Entity_Kind_Type, -- Type of result of Ekind function, i.e. Entity_Kind
+ Source_Ptr,
+ Small_Paren_Count_Type,
+ Union_Id,
+ Convention_Id,
+
+ Component_Alignment_Kind,
+ Mechanism_Type,
+
+ Between_Special_And_Abstract_Node_Types,
+
+ -- Abstract node types:
+
+ Node_Kind, -- root of node type hierarchy
+ N_Access_To_Subprogram_Definition,
+ N_Array_Type_Definition,
+ N_Binary_Op,
+ N_Body_Stub,
+ N_Declaration,
+ N_Delay_Statement,
+ N_Direct_Name,
+ N_Entity,
+ N_Formal_Subprogram_Declaration,
+ N_Generic_Declaration,
+ N_Generic_Instantiation,
+ N_Generic_Renaming_Declaration,
+ N_Has_Chars,
+ N_Has_Entity,
+ N_Has_Etype,
+ N_Multiplying_Operator,
+ N_Later_Decl_Item,
+ N_Membership_Test,
+ N_Numeric_Or_String_Literal,
+ N_Op,
+ N_Op_Boolean,
+ N_Op_Compare,
+ N_Op_Shift,
+ N_Proper_Body,
+ N_Push_xxx_Label,
+ N_Pop_xxx_Label,
+ N_Push_Pop_xxx_Label,
+ N_Raise_xxx_Error,
+ N_Renaming_Declaration,
+ N_Representation_Clause,
+ N_Short_Circuit,
+ N_SCIL_Node,
+ N_Statement_Other_Than_Procedure_Call,
+ N_Subprogram_Call,
+ N_Subprogram_Instantiation,
+ N_Has_Condition,
+ N_Subexpr,
+ N_Subprogram_Specification,
+ N_Unary_Op,
+ N_Unit_Body,
+
+ -- End of abstract node types.
+
+ Between_Abstract_Node_And_Abstract_Entity_Types,
+
+ -- Abstract entity types:
+
+ Entity_Kind, -- root of entity type hierarchy
+ Access_Kind,
+ Access_Subprogram_Kind,
+ Access_Protected_Kind,
+ Aggregate_Kind,
+ Allocatable_Kind,
+ Anonymous_Access_Kind,
+ Array_Kind,
+ Assignable_Kind,
+ Class_Wide_Kind,
+ Composite_Kind,
+ Concurrent_Kind,
+ Concurrent_Body_Kind,
+ Constant_Or_Variable_Kind,
+ Decimal_Fixed_Point_Kind,
+ Digits_Kind,
+ Discrete_Kind,
+ Discrete_Or_Fixed_Point_Kind,
+ Elementary_Kind,
+ Enumeration_Kind,
+ Entry_Kind,
+ Exception_Or_Object_Kind,
+ Fixed_Point_Kind,
+ Float_Kind,
+ Formal_Kind,
+ Formal_Object_Kind,
+ Generic_Subprogram_Kind,
+ Generic_Unit_Kind,
+ Incomplete_Kind,
+ Incomplete_Or_Private_Kind,
+ Integer_Kind,
+ Modular_Integer_Kind,
+ Named_Access_Kind,
+ Named_Kind,
+ Numeric_Kind,
+ Object_Kind,
+ Ordinary_Fixed_Point_Kind,
+ Overloadable_Kind,
+ Private_Kind,
+ Protected_Kind,
+ Real_Kind,
+ Record_Kind,
+ Record_Field_Kind,
+ Scalar_Kind,
+ Subprogram_Kind,
+ Signed_Integer_Kind,
+ Task_Kind,
+ Type_Kind,
+ Void_Or_Type_Kind,
+
+ -- End of abstract entity types.
+
+ Between_Abstract_Entity_And_Concrete_Node_Types,
+
+ -- Concrete node types:
+
+ N_Unused_At_Start,
+ N_At_Clause,
+ N_Component_Clause,
+ N_Enumeration_Representation_Clause,
+ N_Mod_Clause,
+ N_Record_Representation_Clause,
+ N_Attribute_Definition_Clause,
+ N_Empty,
+ N_Pragma_Argument_Association,
+ N_Error,
+ N_Defining_Character_Literal,
+ N_Defining_Identifier,
+ N_Defining_Operator_Symbol,
+ N_Expanded_Name,
+ N_Identifier,
+ N_Operator_Symbol,
+ N_Character_Literal,
+ N_Op_Add,
+ N_Op_Concat,
+ N_Op_Expon,
+ N_Op_Subtract,
+ N_Op_Divide,
+ N_Op_Mod,
+ N_Op_Multiply,
+ N_Op_Rem,
+ N_Op_And,
+ N_Op_Eq,
+ N_Op_Ge,
+ N_Op_Gt,
+ N_Op_Le,
+ N_Op_Lt,
+ N_Op_Ne,
+ N_Op_Or,
+ N_Op_Xor,
+ N_Op_Rotate_Left,
+ N_Op_Rotate_Right,
+ N_Op_Shift_Left,
+ N_Op_Shift_Right,
+ N_Op_Shift_Right_Arithmetic,
+ N_Op_Abs,
+ N_Op_Minus,
+ N_Op_Not,
+ N_Op_Plus,
+ N_Attribute_Reference,
+ N_In,
+ N_Not_In,
+ N_And_Then,
+ N_Or_Else,
+ N_Function_Call,
+ N_Procedure_Call_Statement,
+ N_Raise_Constraint_Error,
+ N_Raise_Program_Error,
+ N_Raise_Storage_Error,
+ N_Integer_Literal,
+ N_Real_Literal,
+ N_String_Literal,
+ N_Explicit_Dereference,
+ N_Expression_With_Actions,
+ N_If_Expression,
+ N_Indexed_Component,
+ N_Null,
+ N_Qualified_Expression,
+ N_Quantified_Expression,
+ N_Aggregate,
+ N_Allocator,
+ N_Case_Expression,
+ N_Delta_Aggregate,
+ N_Extension_Aggregate,
+ N_Raise_Expression,
+ N_Range,
+ N_Reference,
+ N_Selected_Component,
+ N_Slice,
+ N_Target_Name,
+ N_Type_Conversion,
+ N_Unchecked_Expression,
+ N_Unchecked_Type_Conversion,
+ N_Subtype_Indication,
+ N_Component_Declaration,
+ N_Entry_Declaration,
+ N_Expression_Function,
+ N_Formal_Object_Declaration,
+ N_Formal_Type_Declaration,
+ N_Full_Type_Declaration,
+ N_Incomplete_Type_Declaration,
+ N_Iterator_Specification,
+ N_Loop_Parameter_Specification,
+ N_Object_Declaration,
+ N_Protected_Type_Declaration,
+ N_Private_Extension_Declaration,
+ N_Private_Type_Declaration,
+ N_Subtype_Declaration,
+ N_Function_Specification,
+ N_Procedure_Specification,
+ N_Access_Function_Definition,
+ N_Access_Procedure_Definition,
+ N_Task_Type_Declaration,
+ N_Package_Body_Stub,
+ N_Protected_Body_Stub,
+ N_Subprogram_Body_Stub,
+ N_Task_Body_Stub,
+ N_Function_Instantiation,
+ N_Procedure_Instantiation,
+ N_Package_Instantiation,
+ N_Package_Body,
+ N_Subprogram_Body,
+ N_Protected_Body,
+ N_Task_Body,
+ N_Implicit_Label_Declaration,
+ N_Package_Declaration,
+ N_Single_Task_Declaration,
+ N_Subprogram_Declaration,
+ N_Use_Package_Clause,
+ N_Generic_Package_Declaration,
+ N_Generic_Subprogram_Declaration,
+ N_Constrained_Array_Definition,
+ N_Unconstrained_Array_Definition,
+ N_Exception_Renaming_Declaration,
+ N_Object_Renaming_Declaration,
+ N_Package_Renaming_Declaration,
+ N_Subprogram_Renaming_Declaration,
+ N_Generic_Function_Renaming_Declaration,
+ N_Generic_Package_Renaming_Declaration,
+ N_Generic_Procedure_Renaming_Declaration,
+ N_Abort_Statement,
+ N_Accept_Statement,
+ N_Assignment_Statement,
+ N_Asynchronous_Select,
+ N_Block_Statement,
+ N_Case_Statement,
+ N_Code_Statement,
+ N_Compound_Statement,
+ N_Conditional_Entry_Call,
+ N_Delay_Relative_Statement,
+ N_Delay_Until_Statement,
+ N_Entry_Call_Statement,
+ N_Free_Statement,
+ N_Goto_Statement,
+ N_Goto_When_Statement,
+ N_Loop_Statement,
+ N_Null_Statement,
+ N_Raise_Statement,
+ N_Raise_When_Statement,
+ N_Requeue_Statement,
+ N_Simple_Return_Statement,
+ N_Extended_Return_Statement,
+ N_Return_When_Statement,
+ N_Selective_Accept,
+ N_Timed_Entry_Call,
+ N_Exit_Statement,
+ N_If_Statement,
+ N_Accept_Alternative,
+ N_Delay_Alternative,
+ N_Elsif_Part,
+ N_Entry_Body_Formal_Part,
+ N_Iteration_Scheme,
+ N_Terminate_Alternative,
+ N_Formal_Abstract_Subprogram_Declaration,
+ N_Formal_Concrete_Subprogram_Declaration,
+ N_Push_Constraint_Error_Label,
+ N_Push_Program_Error_Label,
+ N_Push_Storage_Error_Label,
+ N_Pop_Constraint_Error_Label,
+ N_Pop_Program_Error_Label,
+ N_Pop_Storage_Error_Label,
+ N_SCIL_Dispatch_Table_Tag_Init,
+ N_SCIL_Dispatching_Call,
+ N_SCIL_Membership_Test,
+ N_Abortable_Part,
+ N_Abstract_Subprogram_Declaration,
+ N_Access_Definition,
+ N_Access_To_Object_Definition,
+ N_Aspect_Specification,
+ N_Call_Marker,
+ N_Case_Expression_Alternative,
+ N_Case_Statement_Alternative,
+ N_Compilation_Unit,
+ N_Compilation_Unit_Aux,
+ N_Component_Association,
+ N_Component_Definition,
+ N_Component_List,
+ N_Contract,
+ N_Derived_Type_Definition,
+ N_Decimal_Fixed_Point_Definition,
+ N_Defining_Program_Unit_Name,
+ N_Delta_Constraint,
+ N_Designator,
+ N_Digits_Constraint,
+ N_Discriminant_Association,
+ N_Discriminant_Specification,
+ N_Enumeration_Type_Definition,
+ N_Entry_Body,
+ N_Entry_Call_Alternative,
+ N_Entry_Index_Specification,
+ N_Exception_Declaration,
+ N_Exception_Handler,
+ N_Floating_Point_Definition,
+ N_Formal_Decimal_Fixed_Point_Definition,
+ N_Formal_Derived_Type_Definition,
+ N_Formal_Discrete_Type_Definition,
+ N_Formal_Floating_Point_Definition,
+ N_Formal_Modular_Type_Definition,
+ N_Formal_Ordinary_Fixed_Point_Definition,
+ N_Formal_Package_Declaration,
+ N_Formal_Private_Type_Definition,
+ N_Formal_Incomplete_Type_Definition,
+ N_Formal_Signed_Integer_Type_Definition,
+ N_Freeze_Entity,
+ N_Freeze_Generic_Entity,
+ N_Generic_Association,
+ 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,
+ N_Number_Declaration,
+ N_Ordinary_Fixed_Point_Definition,
+ N_Others_Choice,
+ N_Package_Specification,
+ N_Parameter_Association,
+ N_Parameter_Specification,
+ N_Pragma,
+ N_Protected_Definition,
+ N_Range_Constraint,
+ N_Real_Range_Specification,
+ N_Record_Definition,
+ N_Signed_Integer_Type_Definition,
+ N_Single_Protected_Declaration,
+ N_Subunit,
+ N_Task_Definition,
+ N_Triggering_Alternative,
+ N_Use_Type_Clause,
+ N_Validate_Unchecked_Conversion,
+ N_Variable_Reference_Marker,
+ N_Variant,
+ N_Variant_Part,
+ N_With_Clause,
+ N_Unused_At_End,
+
+ -- End of concrete node types.
+
+ Between_Concrete_Node_And_Concrete_Entity_Types,
+
+ -- Concrete entity types:
+
+ E_Void,
+ E_Component,
+ E_Constant,
+ E_Discriminant,
+ E_Loop_Parameter,
+ E_Variable,
+ E_Out_Parameter,
+ E_In_Out_Parameter,
+ E_In_Parameter,
+ E_Generic_In_Out_Parameter,
+ E_Generic_In_Parameter,
+ E_Named_Integer,
+ E_Named_Real,
+ E_Enumeration_Type,
+ E_Enumeration_Subtype,
+ E_Signed_Integer_Type,
+ E_Signed_Integer_Subtype,
+ E_Modular_Integer_Type,
+ E_Modular_Integer_Subtype,
+ E_Ordinary_Fixed_Point_Type,
+ E_Ordinary_Fixed_Point_Subtype,
+ E_Decimal_Fixed_Point_Type,
+ E_Decimal_Fixed_Point_Subtype,
+ E_Floating_Point_Type,
+ E_Floating_Point_Subtype,
+ E_Access_Type,
+ E_Access_Subtype,
+ E_Access_Attribute_Type,
+ E_Allocator_Type,
+ E_General_Access_Type,
+ E_Access_Subprogram_Type,
+ E_Access_Protected_Subprogram_Type,
+ E_Anonymous_Access_Protected_Subprogram_Type,
+ E_Anonymous_Access_Subprogram_Type,
+ E_Anonymous_Access_Type,
+ E_Array_Type,
+ E_Array_Subtype,
+ E_String_Literal_Subtype,
+ E_Class_Wide_Type,
+ E_Class_Wide_Subtype,
+ E_Record_Type,
+ E_Record_Subtype,
+ E_Record_Type_With_Private,
+ E_Record_Subtype_With_Private,
+ E_Private_Type,
+ E_Private_Subtype,
+ E_Limited_Private_Type,
+ E_Limited_Private_Subtype,
+ E_Incomplete_Type,
+ E_Incomplete_Subtype,
+ E_Task_Type,
+ E_Task_Subtype,
+ E_Protected_Type,
+ E_Protected_Subtype,
+ E_Exception_Type,
+ E_Subprogram_Type,
+ E_Enumeration_Literal,
+ E_Function,
+ E_Operator,
+ E_Procedure,
+ E_Abstract_State,
+ E_Entry,
+ E_Entry_Family,
+ E_Block,
+ E_Entry_Index_Parameter,
+ E_Exception,
+ E_Generic_Function,
+ E_Generic_Procedure,
+ E_Generic_Package,
+ E_Label,
+ E_Loop,
+ E_Return_Statement,
+ E_Package,
+ E_Package_Body,
+ E_Protected_Body,
+ E_Task_Body,
+ E_Subprogram_Body
+
+ -- End of concrete entity types.
+
+ ); -- Type_Enum
+
+ subtype Type_Enum is Opt_Type_Enum
+ range Opt_Type_Enum'Succ (No_Type) .. Opt_Type_Enum'Last;
+ -- Enumeration of types -- Opt_Type_Enum without the special null value
+ -- No_Type.
+
+ subtype Node_Or_Entity_Type is
+ Type_Enum range
+ Type_Enum'Succ (Between_Special_And_Abstract_Node_Types) ..
+ Type_Enum'Last;
+
+ subtype Abstract_Type is
+ Type_Enum range
+ Type_Enum'Succ (Between_Special_And_Abstract_Node_Types) ..
+ Type_Enum'Pred (Between_Abstract_Entity_And_Concrete_Node_Types);
+ subtype Abstract_Node is
+ Abstract_Type range
+ Type_Enum'Succ (Between_Special_And_Abstract_Node_Types) ..
+ Type_Enum'Pred (Between_Abstract_Node_And_Abstract_Entity_Types);
+ subtype Abstract_Entity is
+ Abstract_Type range
+ Type_Enum'Succ (Between_Abstract_Node_And_Abstract_Entity_Types) ..
+ Type_Enum'Pred (Between_Abstract_Entity_And_Concrete_Node_Types);
+
+ subtype Concrete_Type is
+ Type_Enum range
+ Type_Enum'Succ (Between_Abstract_Entity_And_Concrete_Node_Types) ..
+ Type_Enum'Last;
+ subtype Concrete_Node is
+ Concrete_Type range
+ Type_Enum'Succ (Between_Abstract_Entity_And_Concrete_Node_Types) ..
+ Type_Enum'Pred (Between_Concrete_Node_And_Concrete_Entity_Types);
+ subtype Concrete_Entity is
+ Concrete_Type range
+ Type_Enum'Succ (Between_Concrete_Node_And_Concrete_Entity_Types) ..
+ Type_Enum'Last;
+
+ subtype Root_Type is Abstract_Type with
+ Predicate => Root_Type in Node_Kind | Entity_Kind;
+
+ subtype Node_Type is Node_Or_Entity_Type with
+ Predicate => Node_Type in Abstract_Node | Concrete_Node;
+ subtype Entity_Type is Node_Or_Entity_Type with
+ Predicate => Entity_Type in Abstract_Entity | Concrete_Entity;
+
+ subtype Special_Type is Type_Enum range
+ Flag .. Type_Enum'Pred (Between_Special_And_Abstract_Node_Types);
+
+ subtype Traversed_Field_Type is Type_Enum with Predicate =>
+ Traversed_Field_Type in Node_Id | List_Id | Node_Type;
+ -- These are the types of fields traversed by Traverse_Func
+
+ subtype Entity_Node is Node_Type with
+ Predicate => Entity_Node in
+ N_Defining_Character_Literal
+ | N_Defining_Identifier
+ | N_Defining_Operator_Symbol;
+
+ subtype Opt_Abstract_Type is Opt_Type_Enum with
+ Predicate => Opt_Abstract_Type = No_Type or
+ Opt_Abstract_Type in Abstract_Type;
+
+ subtype Type_Boundaries is Type_Enum with
+ Predicate => Type_Boundaries in
+ Between_Abstract_Node_And_Abstract_Entity_Types |
+ Between_Abstract_Entity_And_Concrete_Node_Types |
+ Between_Concrete_Node_And_Concrete_Entity_Types;
+ -- These are not used, other than to separate the various subranges.
+
+ subtype Uint_Subtype is Type_Enum with
+ Predicate => Uint_Subtype in Valid_Uint | Unat | Upos | Nonzero_Uint;
+
+end Gen_IL.Types;
diff --git a/gcc/ada/gen_il.adb b/gcc/ada/gen_il.adb
new file mode 100644
index 0000000..23619b6
--- /dev/null
+++ b/gcc/ada/gen_il.adb
@@ -0,0 +1,148 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- G E N _ I L --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 2020-2021, Free Software Foundation, Inc. --
+-- --
+-- GNAT is 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 Ada.Streams.Stream_IO; use Ada.Streams.Stream_IO;
+
+package body Gen_IL is
+
+ procedure Put (F : File_Type; S : String);
+ -- The output primitive
+
+ -----------
+ -- Image --
+ -----------
+
+ function Image (X : Root_Int) return String is
+ Result : constant String := X'Img;
+ begin
+ if Result (1) = ' ' then
+ return Result (2 .. Result'Last);
+ else
+ return Result;
+ end if;
+ end Image;
+
+ ----------------
+ -- Capitalize --
+ ----------------
+
+ procedure Capitalize (S : in out String) is
+ Cap : Boolean := True;
+ begin
+ for X of S loop
+ declare
+ Old : constant Character := X;
+ begin
+ if Cap then
+ X := To_Upper (X);
+ else
+ X := To_Lower (X);
+ end if;
+
+ Cap := not (Is_Letter (Old) or else Is_Digit (Old));
+ end;
+ end loop;
+ end Capitalize;
+
+ ----------------
+ -- Capitalize --
+ ----------------
+
+ function Capitalize (S : String) return String is
+ begin
+ return Result : String (S'Range) := S do
+ Capitalize (Result);
+ end return;
+ end Capitalize;
+
+ -----------------
+ -- Create_File --
+ -----------------
+
+ procedure Create_File (Buffer : in out Sink; Name : String) is
+ begin
+ Create (Buffer.File, Out_File, Name);
+ Buffer.Indent := 0;
+ Buffer.New_Line := True;
+ end Create_File;
+
+ ---------------------
+ -- Increase_Indent --
+ ---------------------
+
+ procedure Increase_Indent (Buffer : in out Sink; Amount : Natural) is
+ begin
+ Buffer.Indent := Buffer.Indent + Amount;
+ end Increase_Indent;
+
+ ---------------------
+ -- Decrease_Indent --
+ ---------------------
+
+ procedure Decrease_Indent (Buffer : in out Sink; Amount : Natural) is
+ begin
+ Buffer.Indent := Buffer.Indent - Amount;
+ end Decrease_Indent;
+
+ ---------
+ -- Put --
+ ---------
+
+ procedure Put (F : File_Type; S : String) is
+ begin
+ String'Write (Stream (F), S);
+ end Put;
+
+ procedure Put (Buffer : in out Sink; Item : String) is
+ begin
+ -- If the first character is LF, indent after it only
+
+ if Item (Item'First) = ASCII.LF then
+ Put (Buffer.File, LF);
+ Buffer.New_Line := True;
+
+ if Item'Length > 1 then
+ Put (Buffer, Item (Item'First + 1 .. Item'Last));
+ end if;
+
+ return;
+ end if;
+
+ -- If this is a new line, indent
+
+ if Buffer.New_Line and then Buffer.Indent > 0 then
+ declare
+ S : constant String (1 .. Buffer.Indent) := (others => ' ');
+ begin
+ Put (Buffer.File, S);
+ end;
+ end if;
+
+ Put (Buffer.File, Item);
+
+ Buffer.New_Line := Item (Item'Last) = ASCII.LF;
+ end Put;
+
+end Gen_IL;
diff --git a/gcc/ada/gen_il.ads b/gcc/ada/gen_il.ads
new file mode 100644
index 0000000..5f307fe
--- /dev/null
+++ b/gcc/ada/gen_il.ads
@@ -0,0 +1,96 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- G E N _ I L --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 2020-2021, Free Software Foundation, Inc. --
+-- --
+-- GNAT is 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. --
+-- --
+------------------------------------------------------------------------------
+
+pragma Warnings (Off); -- with clauses for children
+with Ada.Characters.Handling; use Ada.Characters.Handling;
+with Ada.Streams.Stream_IO;
+pragma Warnings (On);
+
+package Gen_IL is -- generate intermediate language
+
+ -- This package and children generates the main intermediate language used
+ -- by the GNAT compiler, which is a decorated syntax tree.
+
+ -- The generated Ada packages are:
+ --
+ -- Seinfo
+ -- Sinfo.Nodes
+ -- Einfo.Entities
+ -- Nmake
+ -- Seinfo_Tables
+ --
+ -- We also generate C code:
+ --
+ -- einfo.h
+ -- sinfo.h
+ -- snames.h
+ --
+ -- It is necessary to look at this generated code in order to understand
+ -- the compiler. In addition, it is necessary to look at comments in the
+ -- spec and body of Gen_IL.
+ --
+ -- Note that the Gen_IL "compiler" and the GNAT Ada compiler are separate
+ -- programs, with no dependencies between them in either direction. That
+ -- is, Gen_IL does not say "with" of GNAT units, and GNAT does not say
+ -- "with Gen_IL". There are many things declared in Gen_IL and GNAT with
+ -- the same name; these are typically related, but they are not the same
+ -- thing.
+
+ -- Misc declarations used throughout:
+
+ type Root_Int is new Integer;
+ function Image (X : Root_Int) return String;
+ -- Without the extra blank. You can derive from Root_Int or the subtypes
+ -- below, and inherit a convenient Image function that leaves out that
+ -- blank.
+
+ subtype Root_Nat is Root_Int range 0 .. Root_Int'Last;
+ subtype Root_Pos is Root_Int range 1 .. Root_Int'Last;
+
+ function Capitalize (S : String) return String;
+ procedure Capitalize (S : in out String);
+ -- Turns an identifier into Mixed_Case
+
+ -- The following declares a minimal implementation of formatted output
+ -- that is piggybacked on Ada.Streams.Stream_IO for bootstrap reasons.
+ -- It uses LF as universal line terminator to make it host independent.
+
+ type Sink is record
+ File : Ada.Streams.Stream_IO.File_Type;
+ Indent : Natural;
+ New_Line : Boolean;
+ end record;
+
+ procedure Create_File (Buffer : in out Sink; Name : String);
+
+ procedure Increase_Indent (Buffer : in out Sink; Amount : Natural);
+
+ procedure Decrease_Indent (Buffer : in out Sink; Amount : Natural);
+
+ procedure Put (Buffer : in out Sink; Item : String);
+
+ LF : constant String := "" & ASCII.LF;
+
+end Gen_IL;
diff --git a/gcc/ada/get_scos.adb b/gcc/ada/get_scos.adb
index 703d572..eb9efaa 100644
--- a/gcc/ada/get_scos.adb
+++ b/gcc/ada/get_scos.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2009-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2009-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute 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 277c604..1388c52 100644
--- a/gcc/ada/get_scos.ads
+++ b/gcc/ada/get_scos.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2009-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2009-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute 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 881c06c..cd2aed2 100644
--- a/gcc/ada/get_targ.adb
+++ b/gcc/ada/get_targ.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -284,7 +284,7 @@ package body Get_Targ is
function Get_Max_Unaligned_Field return Pos is
begin
- return 64; -- Can be different on some targets (e.g., AAMP)
+ return 64; -- Can be different on some targets
end Get_Max_Unaligned_Field;
-----------------------------
diff --git a/gcc/ada/get_targ.ads b/gcc/ada/get_targ.ads
index 5315292..1928273 100644
--- a/gcc/ada/get_targ.ads
+++ b/gcc/ada/get_targ.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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 @@
-- the Wide_Character_Type uses twice the size of a C char, instead of the
-- size of wchar_t.
-with Einfo; use Einfo;
with Types; use Types;
package Get_Targ is
diff --git a/gcc/ada/ghost.adb b/gcc/ada/ghost.adb
index 866f7f7..42ea0f5 100644
--- a/gcc/ada/ghost.adb
+++ b/gcc/ada/ghost.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2014-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2014-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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,23 +24,27 @@
------------------------------------------------------------------------------
with Alloc;
-with Aspects; use Aspects;
-with Atree; use Atree;
-with Einfo; use Einfo;
-with Elists; use Elists;
-with Errout; use Errout;
-with Namet; use Namet;
-with Nlists; use Nlists;
-with Nmake; use Nmake;
-with Sem; use Sem;
-with Sem_Aux; use Sem_Aux;
-with Sem_Disp; use Sem_Disp;
-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;
-with Snames; use Snames;
+with Aspects; use Aspects;
+with Atree; use Atree;
+with Einfo; use Einfo;
+with Einfo.Entities; use Einfo.Entities;
+with Einfo.Utils; use Einfo.Utils;
+with Elists; use Elists;
+with Errout; use Errout;
+with Namet; use Namet;
+with Nlists; use Nlists;
+with Nmake; use Nmake;
+with Sem; use Sem;
+with Sem_Aux; use Sem_Aux;
+with Sem_Disp; use Sem_Disp;
+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;
+with Sinfo.Nodes; use Sinfo.Nodes;
+with Sinfo.Utils; use Sinfo.Utils;
+with Snames; use Snames;
with Table;
package body Ghost is
@@ -159,6 +163,9 @@ package body Ghost is
-- Determine whether node Context denotes a Ghost-friendly context where
-- a Ghost entity can safely reside (SPARK RM 6.9(10)).
+ function In_Aspect_Or_Pragma_Predicate (N : Node_Id) return Boolean;
+ -- Return True iff N is enclosed in an aspect or pragma Predicate
+
-------------------------
-- Is_OK_Ghost_Context --
-------------------------
@@ -540,6 +547,40 @@ package body Ghost is
end if;
end Check_Ghost_Policy;
+ -----------------------------------
+ -- In_Aspect_Or_Pragma_Predicate --
+ -----------------------------------
+
+ function In_Aspect_Or_Pragma_Predicate (N : Node_Id) return Boolean is
+ Par : Node_Id := N;
+ begin
+ while Present (Par) loop
+ if Nkind (Par) = N_Pragma
+ and then Get_Pragma_Id (Par) = Pragma_Predicate
+ then
+ return True;
+
+ elsif Nkind (Par) = N_Aspect_Specification
+ and then Same_Aspect (Get_Aspect_Id (Par), Aspect_Predicate)
+ then
+ return True;
+
+ -- Stop the search when it's clear it cannot be inside an aspect
+ -- or pragma.
+
+ elsif Is_Declaration (Par)
+ or else Is_Statement (Par)
+ or else Is_Body (Par)
+ then
+ return False;
+ end if;
+
+ Par := Parent (Par);
+ end loop;
+
+ return False;
+ end In_Aspect_Or_Pragma_Predicate;
+
-- Start of processing for Check_Ghost_Context
begin
@@ -555,6 +596,19 @@ package body Ghost is
else
Error_Msg_N ("ghost entity cannot appear in this context", Ghost_Ref);
+
+ -- When the Ghost entity appears in a pragma Predicate, explain the
+ -- reason for this being illegal, and suggest a fix instead.
+
+ if In_Aspect_Or_Pragma_Predicate (Ghost_Ref) then
+ Error_Msg_N
+ ("\as predicates are checked in membership tests, "
+ & "the type and its predicate must be both ghost",
+ Ghost_Ref);
+ Error_Msg_N
+ ("\either make the type ghost "
+ & "or use a type invariant on a private type", Ghost_Ref);
+ end if;
end if;
end Check_Ghost_Context;
@@ -1191,11 +1245,21 @@ package body Ghost is
-- processing them in that mode can lead to spurious errors.
if Expander_Active then
+ -- Cases where full analysis is needed, involving array indexing
+ -- which would otherwise be missing array-bounds checks:
+
if not Analyzed (Orig_Lhs)
- and then Nkind (Orig_Lhs) = N_Indexed_Component
- and then Nkind (Prefix (Orig_Lhs)) = N_Selected_Component
- and then Nkind (Prefix (Prefix (Orig_Lhs))) =
- N_Indexed_Component
+ and then
+ ((Nkind (Orig_Lhs) = N_Indexed_Component
+ and then Nkind (Prefix (Orig_Lhs)) = N_Selected_Component
+ and then Nkind (Prefix (Prefix (Orig_Lhs))) =
+ N_Indexed_Component)
+ or else
+ (Nkind (Orig_Lhs) = N_Selected_Component
+ and then Nkind (Prefix (Orig_Lhs)) = N_Indexed_Component
+ and then Nkind (Prefix (Prefix (Orig_Lhs))) =
+ N_Selected_Component
+ and then Nkind (Parent (N)) /= N_Loop_Statement))
then
Analyze (Orig_Lhs);
end if;
diff --git a/gcc/ada/ghost.ads b/gcc/ada/ghost.ads
index 12b52c4..2b241f4 100644
--- a/gcc/ada/ghost.ads
+++ b/gcc/ada/ghost.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2014-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2014-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute 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-style.texi b/gcc/ada/gnat-style.texi
index 50adaab..37ce690 100644
--- a/gcc/ada/gnat-style.texi
+++ b/gcc/ada/gnat-style.texi
@@ -1,94 +1,71 @@
\input texinfo @c -*-texinfo-*-
@c %**start of header
-
-@c oooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooo
-@c o
-@c GNAT DOCUMENTATION o
-@c o
-@c G N A T C O D I N G S T Y L E o
-@c o
-@c Copyright (C) 1992-2012, AdaCore o
-@c o
-@c oooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooo
-
@setfilename gnat-style.info
+@documentencoding UTF-8
+@ifinfo
+@*Generated by Sphinx 4.0.2.@*
+@end ifinfo
+@settitle GNAT Coding Style A Guide for GNAT Developers
+@defindex ge
+@paragraphindent 0
+@exampleindent 4
+@finalout
+@dircategory GNU Ada Tools
+@direntry
+* gnat-style: (gnat-style.info). gnat-style
+@end direntry
-@copying
-Copyright @copyright{} 1992-2012, AdaCore
+@definfoenclose strong,`,'
+@definfoenclose emph,`,'
+@c %**end of header
-Permission is granted to copy, distribute and/or modify this document
-under the terms of the GNU Free Documentation License, Version 1.3 or
-any later version published by the Free Software Foundation; with no
-Invariant Sections, with no Front-Cover Texts and with no Back-Cover
-Texts. A copy of the license is included in the section entitled
-``GNU Free Documentation License''.
-@end copying
+@copying
+@quotation
+GNAT Coding Style: A Guide for GNAT Developers , Jun 23, 2021
-@settitle GNAT Coding Style
-@setchapternewpage odd
+AdaCore
-@include gcc-common.texi
+Copyright @copyright{} 2008-2021, Free Software Foundation
+@end quotation
-@dircategory Software development
-@direntry
-* gnat-style: (gnat-style). GNAT Coding Style
-@end direntry
-
-@macro syntax{element}
-@t{\element\}
-@end macro
-@c %**end of header
+@end copying
@titlepage
-@titlefont{GNAT Coding Style:}
-@sp 1
-@title A Guide for GNAT Developers
-@subtitle GNAT, The GNU Ada Compiler
-@versionsubtitle
-@author Ada Core Technologies, Inc.
-@page
-@vskip 0pt plus 1filll
-
+@title GNAT Coding Style A Guide for GNAT Developers
@insertcopying
@end titlepage
+@contents
-@raisesections
+@c %** start of user preamble
-@node Top, General, , (dir)
-@comment node-name, next, previous, up
+@c %** end of user preamble
@ifnottex
-@noindent
-GNAT Coding Style@*
-A Guide for GNAT Developers
-@sp 2
-@noindent
-GNAT, The GNU Ada Compiler@*
-
-@noindent
+@node Top
+@top GNAT Coding Style A Guide for GNAT Developers
@insertcopying
@end ifnottex
-
+@c %**start of body
+@anchor{gnat-style doc}@anchor{0}
@menu
-* General::
-* Lexical Elements::
-* Declarations and Types::
-* Expressions and Names::
-* Statements::
-* Subprograms::
-* Packages::
-* Program Structure::
-* GNU Free Documentation License::
-* Index::
+* General::
+* Lexical Elements::
+* Declarations and Types::
+* Expressions and Names::
+* Statements::
+* Subprograms::
+* Packages and Visibility Rules::
+* Program Structure and Compilation Issues::
+* Index::
+
@end menu
-@c -------------------------------------------------------------------------
-@node General, Lexical Elements, Top, Top
-@section General
-@c -------------------------------------------------------------------------
+@node General,Lexical Elements,Top,Top
+@anchor{gnat-style general}@anchor{1}@anchor{gnat-style gnat-coding-style-a-guide-for-gnat-developers}@anchor{2}
+@chapter General
+
-@noindent
Most of GNAT is written in Ada using a consistent style to ensure
readability of the code. This document has been written to help
maintain this consistent style, while having a large group of developers
@@ -97,148 +74,184 @@ work on the compiler.
For the coding style in the C parts of the compiler and run time,
see the GNU Coding Guidelines.
-This document is structured after the @cite{Ada Reference Manual}.
+This document is structured after the Ada Reference Manual.
Those familiar with that document should be able to quickly
lookup style rules for particular constructs.
+@node Lexical Elements,Declarations and Types,General,Top
+@anchor{gnat-style lexical-elements}@anchor{3}
+@chapter Lexical Elements
-@c -------------------------------------------------------------------------
-@node Lexical Elements, Declarations and Types, General, Top
-@section Lexical Elements
-@c -------------------------------------------------------------------------
-@cindex Lexical elements
-
-@subsection Character Set and Separators
-@c -------------------------------------------------------------------------
-@cindex Character set
-@cindex ASCII
-@cindex Separators
-@cindex End-of-line
-@cindex Line length
-@cindex Indentation
-
-@itemize @bullet
-@item
-The character set used should be plain 7-bit ASCII@.
+
+@menu
+* Character Set and Separators::
+* Identifiers::
+* Numeric Literals::
+* Reserved Words::
+* Comments::
+
+@end menu
+
+@node Character Set and Separators,Identifiers,,Lexical Elements
+@anchor{gnat-style character-set-and-separators}@anchor{4}
+@section Character Set and Separators
+
+
+@geindex Character set
+
+@geindex ASCII
+
+@geindex Separators
+
+@geindex End-of-line
+
+@geindex Line length
+
+@geindex Indentation
+
+
+@itemize *
+
+@item
+The character set used should be plain 7-bit ASCII.
The only separators allowed are space and the end-of-line sequence.
No other control character or format effector (such as @code{HT},
-@code{VT}, @code{FF})
+@code{VT}, @code{FF} )
should be used.
The normal end-of-line sequence is used, which may be
@code{LF}, @code{CR/LF} or @code{CR},
depending on the host system. An optional @code{SUB}
-(@code{16#1A#}) may be present as the
+( @code{16#1A#} ) may be present as the
last character in the file on hosts using that character as file terminator.
-@item
+@item
Files that are checked in or distributed should be in host format.
-@item
+@item
A line should never be longer than 79 characters, not counting the line
separator.
-@item
+@item
Lines must not have trailing blanks.
-@item
+@item
Indentation is 3 characters per level for @code{if} statements, loops, and
@code{case} statements.
For exact information on required spacing between lexical
-elements, see file @file{style.adb}.
-@cindex @file{style.adb} file
+elements, see file style.adb.
+
+@geindex style.adb file
@end itemize
+@node Identifiers,Numeric Literals,Character Set and Separators,Lexical Elements
+@anchor{gnat-style identifiers}@anchor{5}
+@section Identifiers
+
-@subsection Identifiers
-@c -------------------------------------------------------------------------
-@itemize @bullet
-@cindex Identifiers
-@item
+@itemize *
+
+@item
Identifiers will start with an upper case letter, and each letter following
an underscore will be upper case.
-@cindex Casing (for identifiers)
+
+@geindex Casing (for identifiers)
+
Short acronyms may be all upper case.
All other letters are lower case.
An exception is for identifiers matching a foreign language. In particular,
-we use all lower case where appropriate for C@.
+we use all lower case where appropriate for C.
-@item
+@item
Use underscores to separate words in an identifier.
-@cindex Underscores
-@item Try to limit your use of abbreviations in identifiers.
+@geindex Underscores
+
+@item
+Try to limit your use of abbreviations in identifiers.
It is ok to make a few abbreviations, explain what they mean, and then
-use them frequently, but don't use lots of obscure abbreviations. An
+use them frequently, but don’t use lots of obscure abbreviations. An
example is the @code{ALI} word which stands for Ada Library
Information and is by convention always written in upper-case when
used in entity names.
-@smallexample @c adanocomment
- procedure Find_ALI_Files;
-@end smallexample
+@example
+procedure Find_ALI_Files;
+@end example
-@item
-Don't use the variable name @code{I}, use @code{J} instead; @code{I} is too
-easily confused with @code{1} in some fonts. Similarly don't use the
+@item
+Don’t use the variable name @code{I}, use @code{J} instead; @code{I} is too
+easily confused with @code{1} in some fonts. Similarly don’t use the
variable @code{O}, which is too easily mistaken for the number @code{0}.
@end itemize
-@subsection Numeric Literals
-@c -------------------------------------------------------------------------
-@cindex Numeric literals
+@node Numeric Literals,Reserved Words,Identifiers,Lexical Elements
+@anchor{gnat-style numeric-literals}@anchor{6}
+@section Numeric Literals
+
+
+
+@itemize *
-@itemize @bullet
-@item
+@item
Numeric literals should include underscores where helpful for
readability.
-@cindex Underscores
-@smallexample
- 1_000_000
- 16#8000_0000#
- 3.14159_26535_89793_23846
-@end smallexample
+@geindex Underscores
+
+@example
+1_000_000
+16#8000_0000#
+3.14159_26535_89793_23846
+@end example
@end itemize
-@subsection Reserved Words
-@c -------------------------------------------------------------------------
-@cindex Reserved words
+@node Reserved Words,Comments,Numeric Literals,Lexical Elements
+@anchor{gnat-style reserved-words}@anchor{7}
+@section Reserved Words
+
+
-@itemize @bullet
-@item
+@itemize *
+
+@item
Reserved words use all lower case.
-@cindex Casing (for reserved words)
-@smallexample @c adanocomment
- return else
-@end smallexample
+@geindex Casing (for reserved words)
+
+@example
+return else
+@end example
-@item
+@item
The words @code{Access}, @code{Delta} and @code{Digits} are
-capitalized when used as @syntax{attribute_designator}.
+capitalized when used as attribute_designator.
@end itemize
-@subsection Comments
-@c -------------------------------------------------------------------------
-@cindex Comments
+@node Comments,,Reserved Words,Lexical Elements
+@anchor{gnat-style comments}@anchor{8}
+@section Comments
-@itemize @bullet
-@item
+
+
+@itemize *
+
+@item
A comment starts with @code{--} followed by two spaces.
-The only exception to this rule (i.e.@: one space is tolerated) is when the
+The only exception to this rule (i.e. one space is tolerated) is when the
comment ends with a single space followed by @code{--}.
It is also acceptable to have only one space between @code{--} and the start
of the comment when the comment is at the end of a line,
after some Ada code.
-@item
+@item
Every sentence in a comment should start with an upper-case letter (including
the first letter of the comment).
-@cindex Casing (in comments)
-@item
-When declarations are commented with ``hanging'' comments, i.e.@:
+@geindex Casing (in comments)
+
+@item
+When declarations are commented with ‘hanging’ comments, i.e.
comments after the declaration, there is no blank line before the
comment, and if it is absolutely necessary to have blank lines within
the comments, e.g. to make paragraph separations within a single comment,
@@ -246,217 +259,232 @@ these blank lines @emph{do} have a @code{--} (unlike the
normal rule, which is to use entirely blank lines for separating
comment paragraphs). The comment starts at same level of indentation
as code it is commenting.
-@cindex Blank lines (in comments)
-@cindex Indentation
-@smallexample @c adanocomment
- z : Integer;
- -- Integer value for storing value of z
- --
- -- The previous line was a blank line.
-@end smallexample
+@geindex Blank lines (in comments)
+
+@geindex Indentation
-@item
+@example
+z : Integer;
+-- Integer value for storing value of z
+--
+-- The previous line was a blank line.
+@end example
+
+@item
Comments that are dubious or incomplete, or that comment on possibly
-wrong or incomplete code, should be preceded or followed by @code{???}@.
+wrong or incomplete code, should be preceded or followed by @code{???}.
-@item
+@item
Comments in a subprogram body must generally be surrounded by blank lines.
An exception is a comment that follows a line containing a single keyword
-(@code{begin}, @code{else}, @code{loop}):
+( @code{begin}, @code{else}, @code{loop} ):
-@smallexample @c adanocomment
-@group
- begin
- -- Comment for the next statement
+@example
+begin
+ -- Comment for the next statement
- A := 5;
+ A := 5;
- -- Comment for the B statement
+ -- Comment for the B statement
- B := 6;
- end;
-@end group
-@end smallexample
+ B := 6;
+end;
+@end example
-@item
+@item
In sequences of statements, comments at the end of the lines should be
aligned.
-@cindex Alignment (in comments)
-@smallexample @c adanocomment
- My_Identifier := 5; -- First comment
- Other_Id := 6; -- Second comment
-@end smallexample
+@geindex Alignment (in comments)
+
+@example
+My_Identifier := 5; -- First comment
+Other_Id := 6; -- Second comment
+@end example
-@item
+@item
Short comments that fit on a single line are @emph{not} ended with a
period. Comments taking more than a line are punctuated in the normal
manner.
-@item
+@item
Comments should focus on @emph{why} instead of @emph{what}.
Descriptions of what subprograms do go with the specification.
-@item
+@item
Comments describing a subprogram spec should specifically mention the
formal argument names. General rule: write a comment that does not
depend on the names of things. The names are supplementary, not
sufficient, as comments.
-@item
+@item
@emph{Do not} put two spaces after periods in comments.
@end itemize
-@c -------------------------------------------------------------------------
-@node Declarations and Types, Expressions and Names, Lexical Elements,Top
-@section Declarations and Types
-@c -------------------------------------------------------------------------
-@cindex Declarations and Types
+@node Declarations and Types,Expressions and Names,Lexical Elements,Top
+@anchor{gnat-style declarations-and-types}@anchor{9}
+@chapter Declarations and Types
+
+
-@itemize @bullet
-@item
+@itemize *
+
+@item
In entity declarations, colons must be surrounded by spaces. Colons
should be aligned.
-@cindex Alignment (in declarations)
-@smallexample @c adanocomment
- Entity1 : Integer;
- My_Entity : Integer;
-@end smallexample
+@geindex Alignment (in declarations)
+
+@example
+Entity1 : Integer;
+My_Entity : Integer;
+@end example
-@item
+@item
Declarations should be grouped in a logical order.
Related groups of declarations may be preceded by a header comment.
-@item
+@item
All local subprograms in a subprogram or package body should be declared
before the first local subprogram body.
-@item
+@item
Do not declare local entities that hide global entities.
-@cindex Hiding of outer entities
-@item
+@geindex Hiding of outer entities
+
+@item
Do not declare multiple variables in one declaration that spans lines.
Start a new declaration on each line, instead.
-@item
-The @syntax{defining_identifier}s of global declarations serve as
-comments of a sort. So don't choose terse names, but look for names
+@item
+The defining_identifiers of global declarations serve as
+comments of a sort. So don’t choose terse names, but look for names
that give useful information instead.
-@item
+@item
Local names can be shorter, because they are used only within
one context, where comments explain their purpose.
-@item
+@item
When starting an initialization or default expression on the line that follows
the declaration line, use 2 characters for indentation.
-@smallexample @c adanocomment
- Entity1 : Integer :=
- Function_Name (Parameters, For_Call);
-@end smallexample
+@example
+Entity1 : Integer :=
+ Function_Name (Parameters, For_Call);
+@end example
-@item
+@item
If an initialization or default expression needs to be continued on subsequent
lines, the continuations should be indented from the start of the expression.
-@smallexample @c adanocomment
- Entity1 : Integer := Long_Function_Name
- (parameters for call);
-@end smallexample
-
+@example
+Entity1 : Integer := Long_Function_Name
+ (parameters for call);
+@end example
@end itemize
+@node Expressions and Names,Statements,Declarations and Types,Top
+@anchor{gnat-style expressions-and-names}@anchor{a}
+@chapter Expressions and Names
+
-@c -------------------------------------------------------------------------
-@node Expressions and Names, Statements, Declarations and Types, Top
-@section Expressions and Names
-@c -------------------------------------------------------------------------
-@cindex Expressions and names
-@itemize @bullet
+@itemize *
-@item
+@item
Every operator must be surrounded by spaces. An exception is that
this rule does not apply to the exponentiation operator, for which
there are no specific layout rules. The reason for this exception
is that sometimes it makes clearer reading to leave out the spaces
around exponentiation.
-@cindex Operators
-@smallexample @c adanocomment
- E := A * B**2 + 3 * (C - D);
-@end smallexample
+@geindex Operators
-@item
+@example
+E := A * B**2 + 3 * (C - D);
+@end example
+
+@item
Use parentheses where they clarify the intended association of operands
with operators:
-@cindex Parenthesization of expressions
-@smallexample @c adanocomment
- (A / B) * C
-@end smallexample
+
+@geindex Parenthesization of expressions
+
+@example
+(A / B) * C
+@end example
@end itemize
-@c -------------------------------------------------------------------------
-@node Statements, Subprograms, Expressions and Names, Top
-@section Statements
-@c -------------------------------------------------------------------------
-@cindex Statements
+@node Statements,Subprograms,Expressions and Names,Top
+@anchor{gnat-style statements}@anchor{b}
+@chapter Statements
+
+
+@menu
+* Simple and Compound Statements::
+* If Statements::
+* Case Statements::
+* Loop Statements::
+* Block Statements::
+
+@end menu
+
+@node Simple and Compound Statements,If Statements,,Statements
+@anchor{gnat-style simple-and-compound-statements}@anchor{c}
+@section Simple and Compound Statements
-@subsection Simple and Compound Statements
-@c -------------------------------------------------------------------------
-@cindex Simple and compound statements
-@itemize @bullet
-@item
+
+@itemize *
+
+@item
Use only one statement or label per line.
-@item
-A longer @syntax{sequence_of_statements} may be divided in logical
+
+@item
+A longer sequence_of_statements may be divided in logical
groups or separated from surrounding code using a blank line.
@end itemize
-@subsection If Statements
-@c -------------------------------------------------------------------------
-@cindex @code{if} statement
+@node If Statements,Case Statements,Simple and Compound Statements,Statements
+@anchor{gnat-style if-statements}@anchor{d}
+@section If Statements
+
-@itemize @bullet
-@item
+
+@itemize *
+
+@item
When the @code{if}, @code{elsif} or @code{else} keywords fit on the
same line with the condition and the @code{then} keyword, then the
statement is formatted as follows:
-@cindex Alignment (in an @code{if} statement)
-
-@smallexample @c adanocomment
-@group
- if @var{condition} then
- ...
- elsif @var{condition} then
- ...
- else
- ...
- end if;
-@end group
-@end smallexample
-
-@noindent
+
+@geindex Alignment (in an if statement)
+
+@example
+if condition then
+ ...
+elsif condition then
+ ...
+else
+ ...
+end if;
+@end example
+
When the above layout is not possible, @code{then} should be aligned
with @code{if}, and conditions should preferably be split before an
@code{and} or @code{or} keyword a follows:
-@smallexample @c adanocomment
-@group
- if @var{long_condition_that_has_to_be_split}
- and then @var{continued_on_the_next_line}
- then
- ...
- end if;
-@end group
-@end smallexample
-
-@noindent
+@example
+if long_condition_that_has_to_be_split
+ and then continued_on_the_next_line
+then
+ ...
+end if;
+@end example
+
The @code{elsif}, @code{else} and @code{end if} always line up with
the @code{if} keyword. The preferred location for splitting the line
is before @code{and} or @code{or}. The continuation of a condition is
@@ -464,287 +492,280 @@ indented with two spaces or as many as needed to make nesting clear.
As an exception, if conditions are closely related either of the
following is allowed:
-@smallexample
-@group
- if x = lakdsjfhlkashfdlkflkdsalkhfsalkdhflkjdsahf
- or else
- x = asldkjhalkdsjfhhfd
- or else
- x = asdfadsfadsf
- then
- ...
- end if;
-@end group
-
-@group
- if x = lakdsjfhlkashfdlkflkdsalkhfsalkdhflkjdsahf or else
- x = asldkjhalkdsjfhhfd or else
- x = asdfadsfadsf
- then
- ...
- end if;
-@end group
-@end smallexample
-
-@item
-Conditions should use short-circuit forms (@code{and then},
-@code{or else}), except when the operands are boolean variables
+@example
+if x = lakdsjfhlkashfdlkflkdsalkhfsalkdhflkjdsahf
+ or else
+ x = asldkjhalkdsjfhhfd
+ or else
+ x = asdfadsfadsf
+then
+ ...
+end if;
+
+if x = lakdsjfhlkashfdlkflkdsalkhfsalkdhflkjdsahf or else
+ x = asldkjhalkdsjfhhfd or else
+ x = asdfadsfadsf
+then
+ ...
+end if;
+@end example
+
+@item
+Conditions should use short-circuit forms ( @code{and then},
+@code{or else} ), except when the operands are boolean variables
or boolean constants.
-@cindex Short-circuit forms
-@item
+@geindex Short-circuit forms
+
+@item
Complex conditions in @code{if} statements are indented two characters:
-@cindex Indentation (in @code{if} statements)
-
-@smallexample @c adanocomment
-@group
- if @var{this_complex_condition}
- and then @var{that_other_one}
- and then @var{one_last_one}
- then
- ...
- end if;
-@end group
-@end smallexample
-
-@noindent
+
+@geindex Indentation (in if statements)
+
+@example
+if this_complex_condition
+ and then that_other_one
+ and then one_last_one
+then
+ ...
+end if;
+@end example
+
There are some cases where complex conditionals can be laid out
in manners that do not follow these rules to preserve better
parallelism between branches, e.g.
-@smallexample @c adanocomment
-@group
- if xyz.abc (gef) = 'c'
- or else
- xyz.abc (gef) = 'x'
- then
- ...
- end if;
-@end group
-@end smallexample
+@example
+if xyz.abc (gef) = 'c'
+ or else
+ xyz.abc (gef) = 'x'
+then
+ ...
+end if;
+@end example
-
-@item
+@item
Every @code{if} block is preceded and followed by a blank line, except
-where it begins or ends a @syntax{sequence_of_statements}.
-@cindex Blank lines (in an @code{if} statement)
+where it begins or ends a sequence_of_statements.
+
+@geindex Blank lines (in an if statement)
-@smallexample @c adanocomment
-@group
- A := 5;
+@example
+A := 5;
- if A = 5 then
- null;
- end if;
+if A = 5 then
+ null;
+end if;
- A := 6;
-@end group
-@end smallexample
+A := 6;
+@end example
@end itemize
-@subsection Case Statements
-@cindex @code{case} statements
+@node Case Statements,Loop Statements,If Statements,Statements
+@anchor{gnat-style case-statements}@anchor{e}
+@section Case Statements
+
+
+
+@itemize *
-@itemize @bullet
-@item
+@item
Layout is as below. For long @code{case} statements, the extra indentation
can be saved by aligning the @code{when} clauses with the opening @code{case}.
-@smallexample @c adanocomment
-@group
- case @var{expression} is
- when @var{condition} =>
- ...
- when @var{condition} =>
- ...
- end case;
-@end group
-@end smallexample
+@example
+case expression is
+ when condition =>
+ ...
+ when condition =>
+ ...
+end case;
+@end example
@end itemize
-@subsection Loop Statements
-@cindex Loop statements
+@node Loop Statements,Block Statements,Case Statements,Statements
+@anchor{gnat-style loop-statements}@anchor{f}
+@section Loop Statements
+
+
-@itemize @bullet
-@item
+@itemize *
+
+@item
When possible, have @code{for} or @code{while} on one line with the
condition and the @code{loop} keyword.
-@smallexample @c adanocomment
-@group
- for J in S'Range loop
- ...
- end loop;
-@end group
-@end smallexample
-
-@noindent
-If the condition is too long, split the condition (see ``If
-statements'' above) and align @code{loop} with the @code{for} or
+@example
+for J in S'Range loop
+ ...
+end loop;
+@end example
+
+If the condition is too long, split the condition (see ‘If
+statements’ above) and align @code{loop} with the @code{for} or
@code{while} keyword.
-@cindex Alignment (in a loop statement)
-
-@smallexample @c adanocomment
-@group
- while @var{long_condition_that_has_to_be_split}
- and then @var{continued_on_the_next_line}
- loop
- ...
- end loop;
-@end group
-@end smallexample
-
-@noindent
-If the @syntax{loop_statement} has an identifier, it is laid out as follows:
-
-@smallexample @c adanocomment
-@group
- Outer : while not @var{condition} loop
- ...
- end Outer;
-@end group
-@end smallexample
+
+@geindex Alignment (in a loop statement)
+
+@example
+while long_condition_that_has_to_be_split
+ and then continued_on_the_next_line
+loop
+ ...
+end loop;
+@end example
+
+If the loop_statement has an identifier, it is laid out as follows:
+
+@example
+Outer : while not condition loop
+ ...
+end Outer;
+@end example
@end itemize
-@subsection Block Statements
-@cindex Block statement
+@node Block Statements,,Loop Statements,Statements
+@anchor{gnat-style block-statements}@anchor{10}
+@section Block Statements
+
+
+
+@itemize *
-@itemize @bullet
-@item
+@item
The @code{declare} (optional), @code{begin} and @code{end} words
-are aligned, except when the @syntax{block_statement} is named. There
+are aligned, except when the block_statement is named. There
is a blank line before the @code{begin} keyword:
-@cindex Alignment (in a block statement)
-@smallexample @c adanocomment
-@group
- Some_Block : declare
- ...
+@geindex Alignment (in a block statement)
- begin
- ...
- end Some_Block;
-@end group
-@end smallexample
+@example
+Some_Block : declare
+ ...
+begin
+ ...
+end Some_Block;
+@end example
@end itemize
-@c -------------------------------------------------------------------------
-@node Subprograms, Packages, Statements, Top
-@section Subprograms
-@c -------------------------------------------------------------------------
-@cindex Subprograms
+@node Subprograms,Packages and Visibility Rules,Statements,Top
+@anchor{gnat-style subprograms}@anchor{11}
+@chapter Subprograms
-@subsection Subprogram Declarations
-@c -------------------------------------------------------------------------
-@itemize @bullet
-@item
+@menu
+* Subprogram Declarations::
+* Subprogram Bodies::
+
+@end menu
+
+@node Subprogram Declarations,Subprogram Bodies,,Subprograms
+@anchor{gnat-style subprogram-declarations}@anchor{12}
+@section Subprogram Declarations
+
+
+
+@itemize *
+
+@item
Do not write the @code{in} for parameters.
-@smallexample @c adanocomment
- function Length (S : String) return Integer;
-@end smallexample
+@example
+function Length (S : String) return Integer;
+@end example
-@item
+@item
When the declaration line for a procedure or a function is too long to fit
the entire declaration (including the keyword procedure or function) on a
single line, then fold it, putting a single parameter on a line, aligning
the colons, as in:
-@smallexample @c adanocomment
-@group
- procedure Set_Heading
- (Source : String;
- Count : Natural;
- Pad : Character := Space;
- Fill : Boolean := True);
-@end group
-@end smallexample
-
-@noindent
+@example
+procedure Set_Heading
+ (Source : String;
+ Count : Natural;
+ Pad : Character := Space;
+ Fill : Boolean := True);
+@end example
+
In the case of a function, if the entire spec does not fit on one line, then
the return may appear after the last parameter, as in:
-@smallexample @c adanocomment
-@group
- function Head
- (Source : String;
- Count : Natural;
- Pad : Character := Space) return String;
-@end group
-@end smallexample
+@example
+function Head
+ (Source : String;
+ Count : Natural;
+ Pad : Character := Space) return String;
+@end example
-@noindent
Or it may appear on its own as a separate line. This form is preferred when
putting the return on the same line as the last parameter would result in
an overlong line. The return type may optionally be aligned with the types
of the parameters (usually we do this aligning if it results only in a small
-number of extra spaces, and otherwise we don't attempt to align). So two
+number of extra spaces, and otherwise we don’t attempt to align). So two
alternative forms for the above spec are:
-@smallexample @c adanocomment
-@group
- function Head
- (Source : String;
- Count : Natural;
- Pad : Character := Space)
- return String;
-
- function Head
- (Source : String;
- Count : Natural;
- Pad : Character := Space)
- return String;
-@end group
-@end smallexample
-
+@example
+function Head
+ (Source : String;
+ Count : Natural;
+ Pad : Character := Space)
+ return String;
+
+function Head
+ (Source : String;
+ Count : Natural;
+ Pad : Character := Space)
+ return String;
+@end example
@end itemize
-@subsection Subprogram Bodies
-@c -------------------------------------------------------------------------
-@cindex Subprogram bodies
+@node Subprogram Bodies,,Subprogram Declarations,Subprograms
+@anchor{gnat-style subprogram-bodies}@anchor{13}
+@section Subprogram Bodies
+
+
-@itemize @bullet
-@item
+@itemize *
+
+@item
Function and procedure bodies should usually be sorted alphabetically. Do
not attempt to sort them in some logical order by functionality. For a
sequence of subprogram specs, a general alphabetical sorting is also
usually appropriate, but occasionally it makes sense to group by major
function, with appropriate headers.
-@item
+@item
All subprograms have a header giving the function name, with the following
format:
-@smallexample @c adanocomment
-@group
- -----------------
- -- My_Function --
- -----------------
+@example
+-----------------
+-- My_Function --
+-----------------
- procedure My_Function is
- begin
- ...
- end My_Function;
-@end group
-@end smallexample
+procedure My_Function is
+begin
+ ...
+end My_Function;
+@end example
-@noindent
Note that the name in the header is preceded by a single space,
not two spaces as for other comments. These headers are used on
nested subprograms as well as outer level subprograms. They may
also be used as headers for sections of comments, or collections
of declarations that are related.
-@item
-Every subprogram body must have a preceding @syntax{subprogram_declaration},
+@item
+Every subprogram body must have a preceding subprogram_declaration,
which includes proper client documentation so that you do not need to
read the subprogram body in order to understand what the subprogram does and
how to call it. All subprograms should be documented, without exceptions.
-@item
-@cindex Blank lines (in subprogram bodies)
+@geindex Blank lines (in subprogram bodies)
+
+@item
A sequence of declarations may optionally be separated from the following
begin by a blank line. Just as we optionally allow blank lines in general
between declarations, this blank line should be present only if it improves
@@ -752,22 +773,20 @@ readability. Generally we avoid this blank line if the declarative part is
small (one or two lines) and the body has no blank lines, and we include it
if the declarative part is long or if the body has blank lines.
-@item
+@item
If the declarations in a subprogram contain at least one nested
subprogram body, then just before the @code{begin} of the enclosing
subprogram, there is a comment line and a blank line:
-@smallexample @c adanocomment
-@group
- -- Start of processing for @var{Enclosing_Subprogram}
+@example
+-- Start of processing for Enclosing_Subprogram
- begin
- ...
- end @var{Enclosing_Subprogram};
-@end group
-@end smallexample
+begin
+ ...
+end Enclosing_Subprogram;
+@end example
-@item
+@item
When nested subprograms are present, variables that are referenced by any
nested subprogram should precede the nested subprogram specs. For variables
that are not referenced by nested procedures, the declarations can either also
@@ -775,180 +794,646 @@ be before any of the nested subprogram specs (this is the old style, more
generally used). Or then can come just before the begin, with a header. The
following example shows the two possible styles:
-@smallexample @c adanocomment
-@group
- procedure Style1 is
- Var_Referenced_In_Nested : Integer;
- Var_Referenced_Only_In_Style1 : Integer;
-
- proc Nested;
- -- Comments ...
-
+@example
+procedure Style1 is
+ Var_Referenced_In_Nested : Integer;
+ Var_Referenced_Only_In_Style1 : Integer;
- ------------
- -- Nested --
- ------------
+ proc Nested;
+ -- Comments ...
- procedure Nested is
- begin
- ...
- end Nested;
+ ------------
+ -- Nested --
+ ------------
- -- Start of processing for Style1
-
- begin
- ...
- end Style1;
+ procedure Nested is
+ begin
+ ...
+ end Nested;
-@end group
+-- Start of processing for Style1
-@group
- procedure Style2 is
- Var_Referenced_In_Nested : Integer;
+begin
+ ...
+end Style1;
- proc Nested;
- -- Comments ...
+procedure Style2 is
+ Var_Referenced_In_Nested : Integer;
- ------------
- -- Nested --
- ------------
+ proc Nested;
+ -- Comments ...
- procedure Nested is
- begin
- ...
- end Nested;
+ ------------
+ -- Nested --
+ ------------
- -- Local variables
+ procedure Nested is
+ begin
+ ...
+ end Nested;
- Var_Referenced_Only_In_Style2 : Integer;
+ -- Local variables
- -- Start of processing for Style2
+ Var_Referenced_Only_In_Style2 : Integer;
- begin
- ...
- end Style2;
+-- Start of processing for Style2
-@end group
-@end smallexample
+begin
+ ...
+end Style2;
+@end example
-@noindent
For new code, we generally prefer Style2, but we do not insist on
modifying all legacy occurrences of Style1, which is still much
more common in the sources.
-
@end itemize
+@node Packages and Visibility Rules,Program Structure and Compilation Issues,Subprograms,Top
+@anchor{gnat-style packages-and-visibility-rules}@anchor{14}
+@chapter Packages and Visibility Rules
+
-@c -------------------------------------------------------------------------
-@node Packages, Program Structure, Subprograms, Top
-@section Packages and Visibility Rules
-@c -------------------------------------------------------------------------
-@cindex Packages
-@itemize @bullet
-@item
+@itemize *
+
+@item
All program units and subprograms have their name at the end:
-@smallexample @c adanocomment
-@group
- package P is
- ...
- end P;
-@end group
-@end smallexample
+@example
+package P is
+ ...
+end P;
+@end example
-@item
-We will use the style of @code{use}-ing @code{with}-ed packages, with
+@item
+We will use the style of @code{use} -ing @code{with} -ed packages, with
the context clauses looking like:
-@cindex @code{use} clauses
-@smallexample @c adanocomment
-@group
- with A; use A;
- with B; use B;
-@end group
-@end smallexample
+@geindex use clauses
+
+@example
+with A; use A;
+with B; use B;
+@end example
-@item
+@item
Names declared in the visible part of packages should be
-unique, to prevent name clashes when the packages are @code{use}d.
-@cindex Name clash avoidance
-
-@smallexample @c adanocomment
-@group
- package Entity is
- type Entity_Kind is ...;
- ...
- end Entity;
-@end group
-@end smallexample
-
-@item
+unique, to prevent name clashes when the packages are @code{use} d.
+
+@geindex Name clash avoidance
+
+@example
+package Entity is
+ type Entity_Kind is ...;
+ ...
+end Entity;
+@end example
+
+@item
After the file header comment, the context clause and unit specification
-should be the first thing in a @syntax{program_unit}.
+should be the first thing in a program_unit.
-@item
+@item
Preelaborate, Pure and Elaborate_Body pragmas should be added right after the
package name, indented an extra level and using the parameterless form:
-@smallexample @c adanocomment
-@group
- package Preelaborate_Package is
- pragma Preelaborate;
- ...
- end Preelaborate_Package;
-@end group
-@end smallexample
-
+@example
+package Preelaborate_Package is
+ pragma Preelaborate;
+ ...
+end Preelaborate_Package;
+@end example
@end itemize
-@c -------------------------------------------------------------------------
-@node Program Structure, GNU Free Documentation License, Packages, Top
-@section Program Structure and Compilation Issues
-@c -------------------------------------------------------------------------
-@cindex Program structure
+@node Program Structure and Compilation Issues,Index,Packages and Visibility Rules,Top
+@anchor{gnat-style program-structure-and-compilation-issues}@anchor{15}
+@chapter Program Structure and Compilation Issues
-@itemize @bullet
-@item
-Every GNAT source file must be compiled with the @option{-gnatg}
+
+
+@itemize *
+
+@item
+Every GNAT source file must be compiled with the @code{-gnatg}
switch to check the coding style.
(Note that you should look at
-@file{style.adb} to see the lexical rules enforced by
-@option{-gnatg}).
-@cindex @option{-gnatg} option (to gcc)
-@cindex @file{style.adb} file
+style.adb to see the lexical rules enforced by @code{-gnatg} ).
+
+@geindex -gnatg option (to gcc)
+
+@geindex style.adb file
-@item
+@item
Each source file should contain only one compilation unit.
-@item
+@item
Filenames should be 8 or fewer characters, followed by the @code{.adb}
extension for a body or @code{.ads} for a spec.
-@cindex File name length
-@item
-Unit names should be distinct when ``krunch''ed to 8 characters
-(see @file{krunch.ads}) and the filenames should match the unit name,
+@geindex File name length
+
+@item
+Unit names should be distinct when ‘krunch’ed to 8 characters
+(see krunch.ads) and the filenames should match the unit name,
except that they are all lower case.
-@cindex @file{krunch.ads} file
+
+@geindex krunch.ads file
@end itemize
+@menu
+* GNU Free Documentation License::
+
+@end menu
-@c **********************************
-@c * GNU Free Documentation License *
-@c **********************************
-@node GNU Free Documentation License,Index, Program Structure, Top
-@unnumberedsec GNU Free Documentation License
-@set nodefaultgnufreedocumentationlicensenode
-@include fdl.texi
-@c GNU Free Documentation License
-@cindex GNU Free Documentation License
+@node GNU Free Documentation License,,,Program Structure and Compilation Issues
+@anchor{share/gnu_free_documentation_license doc}@anchor{16}@anchor{share/gnu_free_documentation_license gnu-fdl}@anchor{17}@anchor{share/gnu_free_documentation_license gnu-free-documentation-license}@anchor{18}
+@section GNU Free Documentation License
+
+
+Version 1.3, 3 November 2008
+
+Copyright 2000, 2001, 2002, 2007, 2008 Free Software Foundation, Inc
+@indicateurl{http://fsf.org/}
+
+Everyone is permitted to copy and distribute verbatim copies of this
+license document, but changing it is not allowed.
+
+@strong{Preamble}
+
+The purpose of this License is to make a manual, textbook, or other
+functional and useful document “free” in the sense of freedom: to
+assure everyone the effective freedom to copy and redistribute it,
+with or without modifying it, either commercially or noncommercially.
+Secondarily, this License preserves for the author and publisher a way
+to get credit for their work, while not being considered responsible
+for modifications made by others.
+
+This License is a kind of “copyleft”, which means that derivative
+works of the document must themselves be free in the same sense. It
+complements the GNU General Public License, which is a copyleft
+license designed for free software.
+
+We have designed this License in order to use it for manuals for free
+software, because free software needs free documentation: a free
+program should come with manuals providing the same freedoms that the
+software does. But this License is not limited to software manuals;
+it can be used for any textual work, regardless of subject matter or
+whether it is published as a printed book. We recommend this License
+principally for works whose purpose is instruction or reference.
+
+@strong{1. APPLICABILITY AND DEFINITIONS}
+
+This License applies to any manual or other work, in any medium, that
+contains a notice placed by the copyright holder saying it can be
+distributed under the terms of this License. Such a notice grants a
+world-wide, royalty-free license, unlimited in duration, to use that
+work under the conditions stated herein. The @strong{Document}, below,
+refers to any such manual or work. Any member of the public is a
+licensee, and is addressed as “@strong{you}”. You accept the license if you
+copy, modify or distribute the work in a way requiring permission
+under copyright law.
+
+A “@strong{Modified Version}” of the Document means any work containing the
+Document or a portion of it, either copied verbatim, or with
+modifications and/or translated into another language.
+
+A “@strong{Secondary Section}” is a named appendix or a front-matter section of
+the Document that deals exclusively with the relationship of the
+publishers or authors of the Document to the Document’s overall subject
+(or to related matters) and contains nothing that could fall directly
+within that overall subject. (Thus, if the Document is in part a
+textbook of mathematics, a Secondary Section may not explain any
+mathematics.) The relationship could be a matter of historical
+connection with the subject or with related matters, or of legal,
+commercial, philosophical, ethical or political position regarding
+them.
+
+The “@strong{Invariant Sections}” are certain Secondary Sections whose titles
+are designated, as being those of Invariant Sections, in the notice
+that says that the Document is released under this License. If a
+section does not fit the above definition of Secondary then it is not
+allowed to be designated as Invariant. The Document may contain zero
+Invariant Sections. If the Document does not identify any Invariant
+Sections then there are none.
+
+The “@strong{Cover Texts}” are certain short passages of text that are listed,
+as Front-Cover Texts or Back-Cover Texts, in the notice that says that
+the Document is released under this License. A Front-Cover Text may
+be at most 5 words, and a Back-Cover Text may be at most 25 words.
+
+A “@strong{Transparent}” copy of the Document means a machine-readable copy,
+represented in a format whose specification is available to the
+general public, that is suitable for revising the document
+straightforwardly with generic text editors or (for images composed of
+pixels) generic paint programs or (for drawings) some widely available
+drawing editor, and that is suitable for input to text formatters or
+for automatic translation to a variety of formats suitable for input
+to text formatters. A copy made in an otherwise Transparent file
+format whose markup, or absence of markup, has been arranged to thwart
+or discourage subsequent modification by readers is not Transparent.
+An image format is not Transparent if used for any substantial amount
+of text. A copy that is not “Transparent” is called @strong{Opaque}.
+
+Examples of suitable formats for Transparent copies include plain
+ASCII without markup, Texinfo input format, LaTeX input format, SGML
+or XML using a publicly available DTD, and standard-conforming simple
+HTML, PostScript or PDF designed for human modification. Examples of
+transparent image formats include PNG, XCF and JPG. Opaque formats
+include proprietary formats that can be read and edited only by
+proprietary word processors, SGML or XML for which the DTD and/or
+processing tools are not generally available, and the
+machine-generated HTML, PostScript or PDF produced by some word
+processors for output purposes only.
+
+The “@strong{Title Page}” means, for a printed book, the title page itself,
+plus such following pages as are needed to hold, legibly, the material
+this License requires to appear in the title page. For works in
+formats which do not have any title page as such, “Title Page” means
+the text near the most prominent appearance of the work’s title,
+preceding the beginning of the body of the text.
+
+The “@strong{publisher}” means any person or entity that distributes
+copies of the Document to the public.
+
+A section “@strong{Entitled XYZ}” means a named subunit of the Document whose
+title either is precisely XYZ or contains XYZ in parentheses following
+text that translates XYZ in another language. (Here XYZ stands for a
+specific section name mentioned below, such as “@strong{Acknowledgements}”,
+“@strong{Dedications}”, “@strong{Endorsements}”, or “@strong{History}”.)
+To “@strong{Preserve the Title}”
+of such a section when you modify the Document means that it remains a
+section “Entitled XYZ” according to this definition.
+
+The Document may include Warranty Disclaimers next to the notice which
+states that this License applies to the Document. These Warranty
+Disclaimers are considered to be included by reference in this
+License, but only as regards disclaiming warranties: any other
+implication that these Warranty Disclaimers may have is void and has
+no effect on the meaning of this License.
+
+@strong{2. VERBATIM COPYING}
+
+You may copy and distribute the Document in any medium, either
+commercially or noncommercially, provided that this License, the
+copyright notices, and the license notice saying this License applies
+to the Document are reproduced in all copies, and that you add no other
+conditions whatsoever to those of this License. You may not use
+technical measures to obstruct or control the reading or further
+copying of the copies you make or distribute. However, you may accept
+compensation in exchange for copies. If you distribute a large enough
+number of copies you must also follow the conditions in section 3.
+
+You may also lend copies, under the same conditions stated above, and
+you may publicly display copies.
+
+@strong{3. COPYING IN QUANTITY}
+
+If you publish printed copies (or copies in media that commonly have
+printed covers) of the Document, numbering more than 100, and the
+Document’s license notice requires Cover Texts, you must enclose the
+copies in covers that carry, clearly and legibly, all these Cover
+Texts: Front-Cover Texts on the front cover, and Back-Cover Texts on
+the back cover. Both covers must also clearly and legibly identify
+you as the publisher of these copies. The front cover must present
+the full title with all words of the title equally prominent and
+visible. You may add other material on the covers in addition.
+Copying with changes limited to the covers, as long as they preserve
+the title of the Document and satisfy these conditions, can be treated
+as verbatim copying in other respects.
+
+If the required texts for either cover are too voluminous to fit
+legibly, you should put the first ones listed (as many as fit
+reasonably) on the actual cover, and continue the rest onto adjacent
+pages.
+
+If you publish or distribute Opaque copies of the Document numbering
+more than 100, you must either include a machine-readable Transparent
+copy along with each Opaque copy, or state in or with each Opaque copy
+a computer-network location from which the general network-using
+public has access to download using public-standard network protocols
+a complete Transparent copy of the Document, free of added material.
+If you use the latter option, you must take reasonably prudent steps,
+when you begin distribution of Opaque copies in quantity, to ensure
+that this Transparent copy will remain thus accessible at the stated
+location until at least one year after the last time you distribute an
+Opaque copy (directly or through your agents or retailers) of that
+edition to the public.
+
+It is requested, but not required, that you contact the authors of the
+Document well before redistributing any large number of copies, to give
+them a chance to provide you with an updated version of the Document.
+
+@strong{4. MODIFICATIONS}
+
+You may copy and distribute a Modified Version of the Document under
+the conditions of sections 2 and 3 above, provided that you release
+the Modified Version under precisely this License, with the Modified
+Version filling the role of the Document, thus licensing distribution
+and modification of the Modified Version to whoever possesses a copy
+of it. In addition, you must do these things in the Modified Version:
+
+
+@enumerate A
+
+@item
+Use in the Title Page (and on the covers, if any) a title distinct
+from that of the Document, and from those of previous versions
+(which should, if there were any, be listed in the History section
+of the Document). You may use the same title as a previous version
+if the original publisher of that version gives permission.
+
+@item
+List on the Title Page, as authors, one or more persons or entities
+responsible for authorship of the modifications in the Modified
+Version, together with at least five of the principal authors of the
+Document (all of its principal authors, if it has fewer than five),
+unless they release you from this requirement.
+
+@item
+State on the Title page the name of the publisher of the
+Modified Version, as the publisher.
+
+@item
+Preserve all the copyright notices of the Document.
+
+@item
+Add an appropriate copyright notice for your modifications
+adjacent to the other copyright notices.
+
+@item
+Include, immediately after the copyright notices, a license notice
+giving the public permission to use the Modified Version under the
+terms of this License, in the form shown in the Addendum below.
+
+@item
+Preserve in that license notice the full lists of Invariant Sections
+and required Cover Texts given in the Document’s license notice.
+
+@item
+Include an unaltered copy of this License.
+
+@item
+Preserve the section Entitled “History”, Preserve its Title, and add
+to it an item stating at least the title, year, new authors, and
+publisher of the Modified Version as given on the Title Page. If
+there is no section Entitled “History” in the Document, create one
+stating the title, year, authors, and publisher of the Document as
+given on its Title Page, then add an item describing the Modified
+Version as stated in the previous sentence.
+
+@item
+Preserve the network location, if any, given in the Document for
+public access to a Transparent copy of the Document, and likewise
+the network locations given in the Document for previous versions
+it was based on. These may be placed in the “History” section.
+You may omit a network location for a work that was published at
+least four years before the Document itself, or if the original
+publisher of the version it refers to gives permission.
+
+@item
+For any section Entitled “Acknowledgements” or “Dedications”,
+Preserve the Title of the section, and preserve in the section all
+the substance and tone of each of the contributor acknowledgements
+and/or dedications given therein.
+
+@item
+Preserve all the Invariant Sections of the Document,
+unaltered in their text and in their titles. Section numbers
+or the equivalent are not considered part of the section titles.
+
+@item
+Delete any section Entitled “Endorsements”. Such a section
+may not be included in the Modified Version.
+
+@item
+Do not retitle any existing section to be Entitled “Endorsements”
+or to conflict in title with any Invariant Section.
+
+@item
+Preserve any Warranty Disclaimers.
+@end enumerate
+
+If the Modified Version includes new front-matter sections or
+appendices that qualify as Secondary Sections and contain no material
+copied from the Document, you may at your option designate some or all
+of these sections as invariant. To do this, add their titles to the
+list of Invariant Sections in the Modified Version’s license notice.
+These titles must be distinct from any other section titles.
+
+You may add a section Entitled “Endorsements”, provided it contains
+nothing but endorsements of your Modified Version by various
+parties—for example, statements of peer review or that the text has
+been approved by an organization as the authoritative definition of a
+standard.
+
+You may add a passage of up to five words as a Front-Cover Text, and a
+passage of up to 25 words as a Back-Cover Text, to the end of the list
+of Cover Texts in the Modified Version. Only one passage of
+Front-Cover Text and one of Back-Cover Text may be added by (or
+through arrangements made by) any one entity. If the Document already
+includes a cover text for the same cover, previously added by you or
+by arrangement made by the same entity you are acting on behalf of,
+you may not add another; but you may replace the old one, on explicit
+permission from the previous publisher that added the old one.
+
+The author(s) and publisher(s) of the Document do not by this License
+give permission to use their names for publicity for or to assert or
+imply endorsement of any Modified Version.
+
+@strong{5. COMBINING DOCUMENTS}
+
+You may combine the Document with other documents released under this
+License, under the terms defined in section 4 above for modified
+versions, provided that you include in the combination all of the
+Invariant Sections of all of the original documents, unmodified, and
+list them all as Invariant Sections of your combined work in its
+license notice, and that you preserve all their Warranty Disclaimers.
+
+The combined work need only contain one copy of this License, and
+multiple identical Invariant Sections may be replaced with a single
+copy. If there are multiple Invariant Sections with the same name but
+different contents, make the title of each such section unique by
+adding at the end of it, in parentheses, the name of the original
+author or publisher of that section if known, or else a unique number.
+Make the same adjustment to the section titles in the list of
+Invariant Sections in the license notice of the combined work.
+
+In the combination, you must combine any sections Entitled “History”
+in the various original documents, forming one section Entitled
+“History”; likewise combine any sections Entitled “Acknowledgements”,
+and any sections Entitled “Dedications”. You must delete all sections
+Entitled “Endorsements”.
+
+@strong{6. COLLECTIONS OF DOCUMENTS}
+
+You may make a collection consisting of the Document and other documents
+released under this License, and replace the individual copies of this
+License in the various documents with a single copy that is included in
+the collection, provided that you follow the rules of this License for
+verbatim copying of each of the documents in all other respects.
+
+You may extract a single document from such a collection, and distribute
+it individually under this License, provided you insert a copy of this
+License into the extracted document, and follow this License in all
+other respects regarding verbatim copying of that document.
+
+@strong{7. AGGREGATION WITH INDEPENDENT WORKS}
+
+A compilation of the Document or its derivatives with other separate
+and independent documents or works, in or on a volume of a storage or
+distribution medium, is called an “aggregate” if the copyright
+resulting from the compilation is not used to limit the legal rights
+of the compilation’s users beyond what the individual works permit.
+When the Document is included in an aggregate, this License does not
+apply to the other works in the aggregate which are not themselves
+derivative works of the Document.
+
+If the Cover Text requirement of section 3 is applicable to these
+copies of the Document, then if the Document is less than one half of
+the entire aggregate, the Document’s Cover Texts may be placed on
+covers that bracket the Document within the aggregate, or the
+electronic equivalent of covers if the Document is in electronic form.
+Otherwise they must appear on printed covers that bracket the whole
+aggregate.
+
+@strong{8. TRANSLATION}
+
+Translation is considered a kind of modification, so you may
+distribute translations of the Document under the terms of section 4.
+Replacing Invariant Sections with translations requires special
+permission from their copyright holders, but you may include
+translations of some or all Invariant Sections in addition to the
+original versions of these Invariant Sections. You may include a
+translation of this License, and all the license notices in the
+Document, and any Warranty Disclaimers, provided that you also include
+the original English version of this License and the original versions
+of those notices and disclaimers. In case of a disagreement between
+the translation and the original version of this License or a notice
+or disclaimer, the original version will prevail.
+
+If a section in the Document is Entitled “Acknowledgements”,
+“Dedications”, or “History”, the requirement (section 4) to Preserve
+its Title (section 1) will typically require changing the actual
+title.
+
+@strong{9. TERMINATION}
+
+You may not copy, modify, sublicense, or distribute the Document
+except as expressly provided under this License. Any attempt
+otherwise to copy, modify, sublicense, or distribute it is void, and
+will automatically terminate your rights under this License.
+
+However, if you cease all violation of this License, then your license
+from a particular copyright holder is reinstated (a) provisionally,
+unless and until the copyright holder explicitly and finally
+terminates your license, and (b) permanently, if the copyright holder
+fails to notify you of the violation by some reasonable means prior to
+60 days after the cessation.
+
+Moreover, your license from a particular copyright holder is
+reinstated permanently if the copyright holder notifies you of the
+violation by some reasonable means, this is the first time you have
+received notice of violation of this License (for any work) from that
+copyright holder, and you cure the violation prior to 30 days after
+your receipt of the notice.
+
+Termination of your rights under this section does not terminate the
+licenses of parties who have received copies or rights from you under
+this License. If your rights have been terminated and not permanently
+reinstated, receipt of a copy of some or all of the same material does
+not give you any rights to use it.
+
+@strong{10. FUTURE REVISIONS OF THIS LICENSE}
+
+The Free Software Foundation may publish new, revised versions
+of the GNU Free Documentation License from time to time. Such new
+versions will be similar in spirit to the present version, but may
+differ in detail to address new problems or concerns. See
+@indicateurl{http://www.gnu.org/copyleft/}.
+
+Each version of the License is given a distinguishing version number.
+If the Document specifies that a particular numbered version of this
+License “or any later version” applies to it, you have the option of
+following the terms and conditions either of that specified version or
+of any later version that has been published (not as a draft) by the
+Free Software Foundation. If the Document does not specify a version
+number of this License, you may choose any version ever published (not
+as a draft) by the Free Software Foundation. If the Document
+specifies that a proxy can decide which future versions of this
+License can be used, that proxy’s public statement of acceptance of a
+version permanently authorizes you to choose that version for the
+Document.
+
+@strong{11. RELICENSING}
+
+“Massive Multiauthor Collaboration Site” (or “MMC Site”) means any
+World Wide Web server that publishes copyrightable works and also
+provides prominent facilities for anybody to edit those works. A
+public wiki that anybody can edit is an example of such a server. A
+“Massive Multiauthor Collaboration” (or “MMC”) contained in the
+site means any set of copyrightable works thus published on the MMC
+site.
+
+“CC-BY-SA” means the Creative Commons Attribution-Share Alike 3.0
+license published by Creative Commons Corporation, a not-for-profit
+corporation with a principal place of business in San Francisco,
+California, as well as future copyleft versions of that license
+published by that same organization.
+
+“Incorporate” means to publish or republish a Document, in whole or
+in part, as part of another Document.
+
+An MMC is “eligible for relicensing” if it is licensed under this
+License, and if all works that were first published under this License
+somewhere other than this MMC, and subsequently incorporated in whole
+or in part into the MMC, (1) had no cover texts or invariant sections,
+and (2) were thus incorporated prior to November 1, 2008.
+
+The operator of an MMC Site may republish an MMC contained in the site
+under CC-BY-SA on the same site at any time before August 1, 2009,
+provided the MMC is eligible for relicensing.
+
+@strong{ADDENDUM: How to use this License for your documents}
+
+To use this License in a document you have written, include a copy of
+the License in the document and put the following copyright and
+license notices just after the title page:
+
+@quotation
+
+Copyright © YEAR YOUR NAME.
+Permission is granted to copy, distribute and/or modify this document
+under the terms of the GNU Free Documentation License, Version 1.3
+or any later version published by the Free Software Foundation;
+with no Invariant Sections, no Front-Cover Texts, and no Back-Cover Texts.
+A copy of the license is included in the section entitled “GNU
+Free Documentation License”.
+@end quotation
-@node Index,,GNU Free Documentation License, Top
-@unnumberedsec Index
+If you have Invariant Sections, Front-Cover Texts and Back-Cover Texts,
+replace the “with … Texts.” line with this:
-@printindex cp
+@quotation
+
+with the Invariant Sections being LIST THEIR TITLES, with the
+Front-Cover Texts being LIST, and with the Back-Cover Texts being LIST.
+@end quotation
+
+If you have Invariant Sections without Cover Texts, or some other
+combination of the three, merge those two alternatives to suit the
+situation.
+
+If your document contains nontrivial examples of program code, we
+recommend releasing these examples in parallel under your choice of
+free software license, such as the GNU General Public License,
+to permit their use in free software.
+
+@node Index,,Program Structure and Compilation Issues,Top
+@unnumbered Index
+
+
+@printindex ge
-@contents
+@c %**end of body
@bye
diff --git a/gcc/ada/gnat1drv.adb b/gcc/ada/gnat1drv.adb
index 0318194..6f65d74 100644
--- a/gcc/ada/gnat1drv.adb
+++ b/gcc/ada/gnat1drv.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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,37 +23,37 @@
-- --
------------------------------------------------------------------------------
-with Atree; use Atree;
-with Back_End; use Back_End;
+with Atree; use Atree;
+with Back_End; use Back_End;
with Checks;
with Comperr;
with Csets;
-with Debug; use Debug;
+with Debug; use Debug;
with Elists;
-with Errout; use Errout;
+with Errout; use Errout;
with Exp_CG;
with Fmap;
-with Fname; use Fname;
-with Fname.UF; use Fname.UF;
+with Fname; use Fname;
+with Fname.UF; use Fname.UF;
with Frontend;
-with Ghost; use Ghost;
-with Gnatvsn; use Gnatvsn;
+with Ghost; use Ghost;
+with Gnatvsn; use Gnatvsn;
with Inline;
-with Lib; use Lib;
-with Lib.Writ; use Lib.Writ;
+with Lib; use Lib;
+with Lib.Writ; use Lib.Writ;
with Lib.Xref;
-with Namet; use Namet;
+with Namet; use Namet;
with Nlists;
-with Opt; use Opt;
-with Osint; use Osint;
-with Osint.C; use Osint.C;
-with Output; use Output;
+with Opt; use Opt;
+with Osint; use Osint;
+with Osint.C; use Osint.C;
+with Output; use Output;
with Par_SCO;
with Prepcomp;
with Repinfo;
with Repinfo.Input;
with Restrict;
-with Rident; use Rident;
+with Rident; use Rident;
with Rtsfind;
with SCOs;
with Sem;
@@ -65,24 +65,25 @@ with Sem_Eval;
with Sem_Prag;
with Sem_Type;
with Set_Targ;
-with Sinfo; use Sinfo;
-with Sinput; use Sinput;
-with Sinput.L; use Sinput.L;
-with Snames; use Snames;
-with Sprint; use Sprint;
+with Sinfo; use Sinfo;
+with Sinfo.Nodes; use Sinfo.Nodes;
+with Sinput; use Sinput;
+with Sinput.L; use Sinput.L;
+with Snames; use Snames;
+with Sprint; use Sprint;
with Stringt;
-with Stylesw; use Stylesw;
-with Targparm; use Targparm;
+with Stylesw; use Stylesw;
+with Targparm; use Targparm;
with Tbuild;
-with Treepr; use Treepr;
+with Treepr; use Treepr;
with Ttypes;
-with Types; use Types;
+with Types; use Types;
with Uintp;
-with Uname; use Uname;
+with Uname; use Uname;
with Urealp;
with Usage;
-with Validsw; use Validsw;
-with Warnsw; use Warnsw;
+with Validsw; use Validsw;
+with Warnsw; use Warnsw;
with System.Assertions;
with System.OS_Lib;
@@ -144,12 +145,12 @@ procedure Gnat1drv is
-- Start of processing for Adjust_Global_Switches
begin
- -- Define pragma GNAT_Annotate as an alias of pragma Annotate, to be
- -- able to work around bootstrap limitations with the old syntax of
- -- pragma Annotate, and use pragma GNAT_Annotate in compiler sources
- -- when needed.
- Map_Pragma_Name (From => Name_Gnat_Annotate, To => Name_Annotate);
+ -- -gnatd_U disables prepending error messages with "error:"
+
+ if Debug_Flag_Underscore_UU then
+ Unique_Error_Tag := False;
+ end if;
-- -gnatd.M enables Relaxed_RM_Semantics
@@ -423,6 +424,12 @@ procedure Gnat1drv is
if Warning_Mode = Suppress then
Debug_Flag_MM := True;
end if;
+
+ -- The implementation of 'Value that uses a perfect hash function
+ -- is significantly more complex and harder to initialize than the
+ -- old implementation. Deactivate it for CodePeer.
+
+ Debug_Flag_Underscore_H := True;
end if;
-- Enable some individual switches that are implied by relaxed RM
@@ -565,6 +572,10 @@ procedure Gnat1drv is
Tagged_Type_Expansion := False;
+ -- Force the use of "error:" prefix for error messages
+
+ Unique_Error_Tag := True;
+
-- Detect that the runtime library support for floating-point numbers
-- may not be compatible with SPARK analysis of IEEE-754 floats.
@@ -600,12 +611,6 @@ procedure Gnat1drv is
Ttypes.Target_Strict_Alignment := True;
end if;
- -- Increase size of allocated entities if debug flag -gnatd.N is set
-
- if Debug_Flag_Dot_NN then
- Atree.Num_Extension_Nodes := Atree.Num_Extension_Nodes + 1;
- end if;
-
-- Disable static allocation of dispatch tables if -gnatd.t is enabled.
-- The front end's layout phase currently treats types that have
-- discriminant-dependent arrays as not being static even when a
@@ -623,13 +628,9 @@ procedure Gnat1drv is
end if;
-- 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: CodePeer mode and
- -- GNATprove mode.
+ -- generating code.
- if Operating_Mode = Generate_Code
- and then not (CodePeer_Mode or GNATprove_Mode)
- then
+ if Operating_Mode = Generate_Code then
case Targparm.Frontend_Exceptions_On_Target is
when True =>
case Targparm.ZCX_By_Default_On_Target is
@@ -819,6 +820,12 @@ procedure Gnat1drv is
Ttypes.Standard_Long_Long_Integer_Size;
end if;
+ -- Forcefully use a 32-bit Duration with only 32-bit integer types
+
+ if Ttypes.System_Max_Integer_Size < 64 then
+ Targparm.Duration_32_Bits_On_Target := True;
+ end if;
+
-- Finally capture adjusted value of Suppress_Options as the initial
-- value for Scope_Suppress, which will be modified as we move from
-- scope to scope (by Suppress/Unsuppress/Overflow_Checks pragmas).
@@ -1081,10 +1088,6 @@ begin
-- Lib.Initialize needs to be called before Scan_Compiler_Arguments,
-- because it initializes a table filled by Scan_Compiler_Arguments.
- -- Atree.Initialize needs to be called after Scan_Compiler_Arguments,
- -- because the value specified by the -gnaten switch is used by
- -- Atree.Initialize.
-
Osint.Initialize;
Fmap.Reset_Tables;
Lib.Initialize;
@@ -1284,29 +1287,6 @@ begin
Exit_Program (E_Errors);
end if;
- -- Set Generate_Code on main unit and its spec. We do this even if are
- -- not generating code, since Lib-Writ uses this to determine which
- -- units get written in the ali file.
-
- Set_Generate_Code (Main_Unit);
-
- -- If we have a corresponding spec, and it comes from source or it is
- -- not a generated spec for a child subprogram body, then we need object
- -- code for the spec unit as well.
-
- if Nkind (Unit (Main_Unit_Node)) in N_Unit_Body
- and then not Acts_As_Spec (Main_Unit_Node)
- then
- if Nkind (Unit (Main_Unit_Node)) = N_Subprogram_Body
- and then not Comes_From_Source (Library_Unit (Main_Unit_Node))
- then
- null;
- else
- Set_Generate_Code
- (Get_Cunit_Unit_Number (Library_Unit (Main_Unit_Node)));
- end if;
- end if;
-
-- Case of no code required to be generated, exit indicating no error
if Original_Operating_Mode = Check_Syntax then
@@ -1708,10 +1688,6 @@ begin
<<End_Of_Program>>
- if Debug_Flag_Dot_AA then
- Atree.Print_Statistics;
- end if;
-
-- The outer exception handler handles an unrecoverable error
exception
diff --git a/gcc/ada/gnat1drv.ads b/gcc/ada/gnat1drv.ads
index baefe8a..94432b4 100644
--- a/gcc/ada/gnat1drv.ads
+++ b/gcc/ada/gnat1drv.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute 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_cuda.adb b/gcc/ada/gnat_cuda.adb
index 39a55e6..b7ce953 100644
--- a/gcc/ada/gnat_cuda.adb
+++ b/gcc/ada/gnat_cuda.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2010-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2010-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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,20 +25,20 @@
-- This package defines CUDA-specific datastructures and functions.
-with Atree; use Atree;
-with Debug; use Debug;
-with Elists; use Elists;
-with Namet; use Namet;
-with Nlists; use Nlists;
-with Nmake; use Nmake;
-with Rtsfind; use Rtsfind;
-with Sinfo; use Sinfo;
-with Stringt; use Stringt;
-with Tbuild; use Tbuild;
-with Uintp; use Uintp;
-with Sem; use Sem;
-with Sem_Util; use Sem_Util;
-with Snames; use Snames;
+with Debug; use Debug;
+with Elists; use Elists;
+with Namet; use Namet;
+with Nlists; use Nlists;
+with Nmake; use Nmake;
+with Rtsfind; use Rtsfind;
+with Sinfo; use Sinfo;
+with Sinfo.Nodes; use Sinfo.Nodes;
+with Stringt; use Stringt;
+with Tbuild; use Tbuild;
+with Uintp; use Uintp;
+with Sem; use Sem;
+with Sem_Util; use Sem_Util;
+with Snames; use Snames;
with GNAT.HTable;
@@ -68,8 +68,8 @@ package body GNAT_CUDA is
function Get_CUDA_Kernels (Pack_Id : Entity_Id) return Elist_Id;
-- Returns an Elist of all procedures marked with pragma CUDA_Global that
- -- are declared within package body Pack_Body. Returns No_Elist if
- -- Pack_Id does not contain such procedures.
+ -- are declared within package body Pack_Body. Returns No_Elist if Pack_Id
+ -- does not contain such procedures.
procedure Set_CUDA_Kernels
(Pack_Id : Entity_Id;
@@ -249,7 +249,7 @@ package body GNAT_CUDA is
-- function.
New_Stmt : Node_Id;
- -- Temporary variable to hold the various newly-created nodes.
+ -- Temporary variable to hold the various newly-created nodes
Kernel_Elmt : Elmt_Id;
Kernel_Id : Entity_Id;
@@ -266,8 +266,7 @@ package body GNAT_CUDA is
while Present (Kernel_Elmt) loop
Kernel_Id := Node (Kernel_Elmt);
- New_Stmt :=
- Build_Kernel_Name_Declaration (Kernel_Id);
+ New_Stmt := Build_Kernel_Name_Declaration (Kernel_Id);
Append (New_Stmt, Pack_Decls);
Analyze (New_Stmt);
@@ -366,7 +365,7 @@ package body GNAT_CUDA is
Make_Aggregate (Loc,
Expressions => New_List (
Make_Integer_Literal (Loc, UI_From_Int (16#466243b1#)),
- Make_Integer_Literal (Loc, UI_From_Int (1)),
+ Make_Integer_Literal (Loc, Uint_1),
Make_Attribute_Reference (Loc,
Prefix => New_Occurrence_Of (Bin_Id, Loc),
Attribute_Name => Name_Address),
@@ -452,39 +451,39 @@ package body GNAT_CUDA is
is
Args : constant List_Id := New_List;
begin
- -- First argument: the handle of the fat binary.
+ -- First argument: the handle of the fat binary
Append (New_Occurrence_Of (Bin, Loc), Args);
- -- Second argument: the host address of the function that is
- -- marked with CUDA_Global.
+ -- Second argument: the host address of the function that is marked
+ -- with CUDA_Global.
Append_To (Args,
Make_Attribute_Reference (Loc,
Prefix => New_Occurrence_Of (Kernel, Loc),
Attribute_Name => Name_Address));
- -- Third argument, the name of the function on the host.
+ -- Third argument, the name of the function on the host
Append (New_Occurrence_Of (Kernel_Name, Loc), Args);
- -- Fourth argument, the name of the function on the device.
+ -- Fourth argument, the name of the function on the device
Append (New_Occurrence_Of (Kernel_Name, Loc), Args);
-- Fith argument: -1. Meaning unknown - this has been copied from
-- LLVM.
- Append (Make_Integer_Literal (Loc, UI_From_Int (-1)), Args);
+ Append (Make_Integer_Literal (Loc, Uint_Minus_1), Args);
- -- Args 6, 7, 8, 9, 10: Null pointers. Again, meaning unknown.
+ -- Args 6, 7, 8, 9, 10: Null pointers. Again, meaning unknown
- for Arg_Count in 1 .. 5 loop
+ for Arg_Count in 6 .. 10 loop
Append_To (Args, New_Occurrence_Of (RTE (RE_Null_Address), Loc));
end loop;
- -- Build the call to CUDARegisterFunction, passing the argument
- -- list we just built.
+ -- Build the call to CUDARegisterFunction, passing the argument list
+ -- we just built.
return
Make_Procedure_Call_Statement (Loc,
@@ -498,21 +497,21 @@ package body GNAT_CUDA is
Loc : constant Source_Ptr := Sloc (N);
Spec_Id : constant Node_Id := Corresponding_Spec (N);
- -- The specification of the package we're adding a cuda init func to.
+ -- The specification of the package we're adding a cuda init func to
Pack_Decls : constant List_Id := Declarations (N);
CUDA_Node_List : constant Elist_Id := Get_CUDA_Kernels (Spec_Id);
- -- CUDA nodes that belong to the package.
+ -- CUDA nodes that belong to the package
CUDA_Init_Func : Entity_Id;
- -- Entity of the cuda init func.
+ -- Entity of the cuda init func
Fat_Binary : Entity_Id;
- -- Entity of the fat binary of N. Bound to said fat binary by a pragma.
+ -- Entity of the fat binary of N. Bound to said fat binary by a pragma
Fat_Binary_Handle : Entity_Id;
- -- Entity of the result of passing the fat binary wrapper to.
+ -- Entity of the result of passing the fat binary wrapper to
-- CUDA.Register_Fat_Binary.
Fat_Binary_Wrapper : Entity_Id;
diff --git a/gcc/ada/gnat_cuda.ads b/gcc/ada/gnat_cuda.ads
index e27be34..200aeeb 100644
--- a/gcc/ada/gnat_cuda.ads
+++ b/gcc/ada/gnat_cuda.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2010-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2010-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute 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 417ee34..349586e 100644
--- a/gcc/ada/gnat_rm.texi
+++ b/gcc/ada/gnat_rm.texi
@@ -3,7 +3,7 @@
@setfilename gnat_rm.info
@documentencoding UTF-8
@ifinfo
-@*Generated by Sphinx 1.4.6.@*
+@*Generated by Sphinx 4.0.2.@*
@end ifinfo
@settitle GNAT Reference Manual
@defindex ge
@@ -21,7 +21,7 @@
@copying
@quotation
-GNAT Reference Manual , Dec 11, 2020
+GNAT Reference Manual , Jun 23, 2021
AdaCore
@@ -58,8 +58,8 @@ AdaCore
Permission is granted to copy, distribute and/or modify this document
under the terms of the GNU Free Documentation License, Version 1.3 or
any later version published by the Free Software Foundation; with no
-Invariant Sections, with the Front-Cover Texts being "GNAT Reference
-Manual", and with no Back-Cover Texts. A copy of the license is
+Invariant Sections, with the Front-Cover Texts being “GNAT Reference
+Manual”, and with no Back-Cover Texts. A copy of the license is
included in the section entitled @ref{1,,GNU Free Documentation License}.
@menu
@@ -154,7 +154,6 @@ Implementation Defined Pragmas
* Pragma Export_Function::
* Pragma Export_Object::
* Pragma Export_Procedure::
-* Pragma Export_Value::
* Pragma Export_Valued_Procedure::
* Pragma Extend_System::
* Pragma Extensions_Allowed::
@@ -282,7 +281,6 @@ Implementation Defined Pragmas
* Pragma Unevaluated_Use_Of_Old::
* Pragma Unimplemented_Unit::
* Pragma Universal_Aliasing::
-* Pragma Universal_Data::
* Pragma Unmodified::
* Pragma Unreferenced::
* Pragma Unreferenced_Objects::
@@ -322,7 +320,7 @@ Implementation Defined Aspects
* Aspect Initializes::
* Aspect Inline_Always::
* Aspect Invariant::
-* Aspect Invariant'Class::
+* Aspect Invariant’Class::
* Aspect Iterable::
* Aspect Linker_Section::
* Aspect Lock_Free::
@@ -331,6 +329,7 @@ Implementation Defined Aspects
* Aspect No_Elaboration_Code_All::
* Aspect No_Inline::
* Aspect No_Tagged_Streams::
+* Aspect No_Task_Parts::
* Aspect Object_Size::
* Aspect Obsolescent::
* Aspect Part_Of::
@@ -354,7 +353,6 @@ Implementation Defined Aspects
* Aspect Test_Case::
* Aspect Thread_Local_Storage::
* Aspect Universal_Aliasing::
-* Aspect Universal_Data::
* Aspect Unmodified::
* Aspect Unreferenced::
* Aspect Unreferenced_Objects::
@@ -438,6 +436,7 @@ Implementation Defined Attributes
* Attribute Universal_Literal_String::
* Attribute Unrestricted_Access::
* Attribute Update::
+* Attribute Valid_Image::
* Attribute Valid_Scalars::
* Attribute VADS_Size::
* Attribute Value_Size::
@@ -558,7 +557,7 @@ Implementation Advice
* RM 3.5.5(8); Enumeration Values: RM 3 5 5 8 Enumeration Values.
* RM 3.5.7(17); Float Types: RM 3 5 7 17 Float Types.
* RM 3.6.2(11); Multidimensional Arrays: RM 3 6 2 11 Multidimensional Arrays.
-* RM 9.6(30-31); Duration'Small: RM 9 6 30-31 Duration'Small.
+* RM 9.6(30-31); Duration’Small: RM 9 6 30-31 Duration’Small.
* RM 10.2.1(12); Consistent Representation: RM 10 2 1 12 Consistent Representation.
* RM 11.4.1(19); Exception Information: RM 11 4 1 19 Exception Information.
* RM 11.5(28); Suppression of Checks: RM 11 5 28 Suppression of Checks.
@@ -584,6 +583,7 @@ Implementation Advice
* RM A.4.4(106); Bounded-Length String Handling: RM A 4 4 106 Bounded-Length String Handling.
* RM A.5.2(46-47); Random Number Generation: RM A 5 2 46-47 Random Number Generation.
* RM A.10.7(23); Get_Immediate: RM A 10 7 23 Get_Immediate.
+* RM A.18; Containers: RM A 18 Containers.
* RM B.1(39-41); Pragma Export: RM B 1 39-41 Pragma Export.
* RM B.2(12-13); Package Interfaces: RM B 2 12-13 Package Interfaces.
* RM B.3(63-71); Interfacing with C: RM B 3 63-71 Interfacing with C.
@@ -860,6 +860,7 @@ Implementation of Specific Ada Features
* GNAT Implementation of Shared Passive Packages::
* Code Generation for Array Aggregates::
* The Size of Discriminated Records with Default Discriminants::
+* Image Values For Nonscalar Types::
* Strict Conformance to the Ada Reference Manual::
GNAT Implementation of Tasking
@@ -913,7 +914,7 @@ Implementation-dependent characteristics
@end menu
@node About This Guide,Implementation Defined Pragmas,Top,Top
-@anchor{gnat_rm/about_this_guide about-this-guide}@anchor{2}@anchor{gnat_rm/about_this_guide doc}@anchor{3}@anchor{gnat_rm/about_this_guide gnat-reference-manual}@anchor{4}@anchor{gnat_rm/about_this_guide id1}@anchor{5}
+@anchor{gnat_rm/about_this_guide doc}@anchor{2}@anchor{gnat_rm/about_this_guide about-this-guide}@anchor{3}@anchor{gnat_rm/about_this_guide gnat-reference-manual}@anchor{4}@anchor{gnat_rm/about_this_guide id1}@anchor{5}
@chapter About This Guide
@@ -928,8 +929,8 @@ invoked in Ada 83 compatibility mode.
By default, GNAT assumes Ada 2012,
but you can override with a compiler switch
to explicitly specify the language version.
-(Please refer to the @emph{GNAT User's Guide} for details on these switches.)
-Throughout this manual, references to 'Ada' without a year suffix
+(Please refer to the @emph{GNAT User’s Guide} for details on these switches.)
+Throughout this manual, references to ‘Ada’ without a year suffix
apply to all the Ada versions of the language.
Ada is designed to be highly portable.
@@ -1002,7 +1003,7 @@ of representation clauses and pragmas that is accepted.
@item
@ref{e,,Standard Library Routines}, provides a listing of packages and a
-brief description of the functionality that is provided by Ada's
+brief description of the functionality that is provided by Ada’s
extensive set of standard library routines as implemented by GNAT.
@item
@@ -1024,7 +1025,7 @@ of the specialized needs annexes.
@item
@ref{13,,Implementation of Specific Ada Features}, discusses issues related
-to GNAT's implementation of machine code insertions, tasking, and several
+to GNAT’s implementation of machine code insertions, tasking, and several
other features.
@item
@@ -1118,7 +1119,7 @@ See the following documents for further information on GNAT:
@itemize *
@item
-@cite{GNAT User's Guide for Native Platforms},
+@cite{GNAT User’s Guide for Native Platforms},
which provides information on how to use the
GNAT development environment.
@@ -1154,7 +1155,7 @@ compiler system.
@end itemize
@node Implementation Defined Pragmas,Implementation Defined Aspects,About This Guide,Top
-@anchor{gnat_rm/implementation_defined_pragmas implementation-defined-pragmas}@anchor{7}@anchor{gnat_rm/implementation_defined_pragmas doc}@anchor{19}@anchor{gnat_rm/implementation_defined_pragmas id1}@anchor{1a}
+@anchor{gnat_rm/implementation_defined_pragmas doc}@anchor{19}@anchor{gnat_rm/implementation_defined_pragmas id1}@anchor{1a}@anchor{gnat_rm/implementation_defined_pragmas implementation-defined-pragmas}@anchor{7}
@chapter Implementation Defined Pragmas
@@ -1233,7 +1234,6 @@ consideration, the use of these pragmas should be minimized.
* Pragma Export_Function::
* Pragma Export_Object::
* Pragma Export_Procedure::
-* Pragma Export_Value::
* Pragma Export_Valued_Procedure::
* Pragma Extend_System::
* Pragma Extensions_Allowed::
@@ -1361,7 +1361,6 @@ consideration, the use of these pragmas should be minimized.
* Pragma Unevaluated_Use_Of_Old::
* Pragma Unimplemented_Unit::
* Pragma Universal_Aliasing::
-* Pragma Universal_Data::
* Pragma Unmodified::
* Pragma Unreferenced::
* Pragma Unreferenced_Objects::
@@ -1414,7 +1413,7 @@ end;
@end example
@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}
+@anchor{gnat_rm/implementation_defined_pragmas id2}@anchor{1c}@anchor{gnat_rm/implementation_defined_pragmas pragma-abstract-state}@anchor{1d}
@section Pragma Abstract_State
@@ -1666,7 +1665,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{26}@anchor{gnat_rm/implementation_defined_pragmas id3}@anchor{27}
+@anchor{gnat_rm/implementation_defined_pragmas id3}@anchor{26}@anchor{gnat_rm/implementation_defined_pragmas pragma-annotate}@anchor{27}
@section Pragma Annotate
@@ -1851,7 +1850,7 @@ The pragma applies in both cases to pragmas and aspects with matching
names, e.g. @code{Pre} applies to the Pre aspect, and @code{Precondition}
applies to both the @code{Precondition} pragma
and the aspect @code{Precondition}. Note that the identifiers for
-pragmas Pre_Class and Post_Class are Pre'Class and Post'Class (not
+pragmas Pre_Class and Post_Class are Pre’Class and Post’Class (not
Pre_Class and Post_Class), since these pragmas are intended to be
identical to the corresponding aspects).
@@ -1868,7 +1867,7 @@ The implementation defined policy @code{DISABLE} is like
@code{IGNORE} except that it completely disables semantic
checking of the corresponding pragma or aspect. This is
useful when the pragma or aspect argument references subprograms
-in a with'ed package which is replaced by a dummy package
+in a with’ed package which is replaced by a dummy package
for the final build.
The implementation defined assertion kind @code{Assertions} applies to all
@@ -1968,7 +1967,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{2d}@anchor{gnat_rm/implementation_defined_pragmas id4}@anchor{2e}
+@anchor{gnat_rm/implementation_defined_pragmas id4}@anchor{2d}@anchor{gnat_rm/implementation_defined_pragmas pragma-async-readers}@anchor{2e}
@section Pragma Async_Readers
@@ -2126,13 +2125,13 @@ This implementation permission accommodates the notion
of infinities in IEEE floating-point, and corresponds to the
efficient execution mode on most machines. GNAT will not raise
overflow exceptions on these machines; instead it will generate
-infinities and NaN's as defined in the IEEE standard.
+infinities and NaN’s as defined in the IEEE standard.
Generating infinities, although efficient, is not always desirable.
Often the preferable approach is to check for overflow, even at the
(perhaps considerable) expense of run-time performance.
-This can be accomplished by defining your own constrained floating-point subtypes -- i.e., by supplying explicit
-range constraints -- and indeed such a subtype
+This can be accomplished by defining your own constrained floating-point subtypes – i.e., by supplying explicit
+range constraints – and indeed such a subtype
can have the same base range as its base type. For example:
@example
@@ -2328,7 +2327,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{39}@anchor{gnat_rm/implementation_defined_pragmas compile-time-error}@anchor{3a}
+@anchor{gnat_rm/implementation_defined_pragmas compile-time-error}@anchor{39}@anchor{gnat_rm/implementation_defined_pragmas pragma-compile-time-error}@anchor{3a}
@section Pragma Compile_Time_Error
@@ -2371,8 +2370,8 @@ 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
+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).
One typical use is within a generic where compile time known characteristics
@@ -2382,7 +2381,7 @@ 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
+a warning. You can use @ref{39,,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
@@ -2746,13 +2745,13 @@ must be of one of the following forms:
@strong{function} @code{Fname} @strong{return} T`
@item
-@strong{function} @code{Fname} @strong{return} T'Class
+@strong{function} @code{Fname} @strong{return} T’Class
@item
-@strong{function} @code{Fname} (...) @strong{return} T`
+@strong{function} @code{Fname} (…) @strong{return} T`
@item
-@strong{function} @code{Fname} (...) @strong{return} T'Class
+@strong{function} @code{Fname} (…) @strong{return} T’Class
@end itemize
where @code{T} is a limited record type imported from C++ with pragma
@@ -2761,7 +2760,7 @@ where @code{T} is a limited record type imported from C++ with pragma
The first two forms import the default constructor, used when an object
of type @code{T} is created on the Ada side with no explicit constructor.
The latter two forms cover all the non-default constructors of the type.
-See the GNAT User's Guide for details.
+See the GNAT User’s Guide for details.
If no constructors are imported, it is impossible to create any objects
on the Ada side and the type is implicitly declared abstract.
@@ -2986,7 +2985,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{53}@anchor{gnat_rm/implementation_defined_pragmas id9}@anchor{54}
+@anchor{gnat_rm/implementation_defined_pragmas id9}@anchor{53}@anchor{gnat_rm/implementation_defined_pragmas pragma-depends}@anchor{54}
@section Pragma Depends
@@ -3120,7 +3119,7 @@ pragma Elaboration_Checks (Dynamic | Static);
This is a configuration pragma which specifies the elaboration model to be
used during compilation. For more information on the elaboration models of
-GNAT, consult the chapter on elaboration order handling in the @emph{GNAT User's
+GNAT, consult the chapter on elaboration order handling in the @emph{GNAT User’s
Guide}.
The pragma may appear in the following contexts:
@@ -3132,7 +3131,7 @@ The pragma may appear in the following contexts:
Configuration pragmas file
@item
-Prior to the context clauses of a compilation unit's initial declaration
+Prior to the context clauses of a compilation unit’s initial declaration
@end itemize
Any other placement of the pragma will result in a warning and the effects of
@@ -3427,7 +3426,7 @@ separate Export pragma (and you probably should from the point of view
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
+@node Pragma Export_Procedure,Pragma Export_Valued_Procedure,Pragma Export_Object,Implementation Defined Pragmas
@anchor{gnat_rm/implementation_defined_pragmas pragma-export-procedure}@anchor{61}
@section Pragma Export_Procedure
@@ -3480,29 +3479,8 @@ string or a static string expressions that evaluates to the null
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{62}
-@section Pragma Export_Value
-
-
-Syntax:
-
-@example
-pragma Export_Value (
- [Value =>] static_integer_EXPRESSION,
- [Link_Name =>] static_string_EXPRESSION);
-@end example
-
-This pragma serves to export a static integer value for external use.
-The first argument specifies the value to be exported. The Link_Name
-argument specifies the symbolic name to be associated with the integer
-value. This pragma is useful for defining a named static value in Ada
-that can be referenced in assembly language units to be linked with
-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{63}
+@node Pragma Export_Valued_Procedure,Pragma Extend_System,Pragma Export_Procedure,Implementation Defined Pragmas
+@anchor{gnat_rm/implementation_defined_pragmas pragma-export-valued-procedure}@anchor{62}
@section Pragma Export_Valued_Procedure
@@ -3560,7 +3538,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{64}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-extend-system}@anchor{63}
@section Pragma Extend_System
@@ -3608,10 +3586,10 @@ definition. Note that such a package is a child of @code{System}
and thus is considered part of the implementation.
To compile it you will have to use the @emph{-gnatg} switch
for compiling System units, as explained in the
-GNAT User's Guide.
+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{65}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-extensions-allowed}@anchor{64}
@section Pragma Extensions_Allowed
@@ -3630,7 +3608,7 @@ 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 202x), and in addition a small number
+implemented (currently Ada 2022), and in addition a number
of GNAT specific extensions are recognized as follows:
@@ -3661,10 +3639,181 @@ now under -gnatX to confirm and potentially refine its usage and syntax.
This new aggregate syntax for arrays and containers is provided under -gnatX
to experiment and confirm this new language syntax.
+
+@item
+Additional @code{when} constructs
+
+In addition to the @code{exit when CONDITION} control structure, several
+additional constructs are allowed following this format. Including
+@code{return when CONDITION}, @code{goto when CONDITION}, and
+@code{raise [with EXCEPTION_MESSAGE] when CONDITION.}
+
+Some examples:
+
+@example
+return Result when Variable > 10;
+
+raise Program_Error with "Element is null" when Element = null;
+
+goto End_Of_Subprogram when Variable = -1;
+@end example
+
+@item
+Casing on composite values (aka pattern matching)
+
+The selector for a case statement may be of a composite type, subject to
+some restrictions (described below). Aggregate syntax is used for choices
+of such a case statement; however, in cases where a “normal” aggregate would
+require a discrete value, a discrete subtype may be used instead; box
+notation can also be used to match all values.
+
+Consider this example:
+
+@example
+type Rec is record
+ F1, F2 : Integer;
+end record;
+
+procedure Caser_1 (X : Rec) is
+begin
+ case X is
+ when (F1 => Positive, F2 => Positive) =>
+ Do_This;
+ when (F1 => Natural, F2 => <>) | (F1 => <>, F2 => Natural) =>
+ Do_That;
+ when others =>
+ Do_The_Other_Thing;
+ end case;
+end Caser_1;
+@end example
+
+If Caser_1 is called and both components of X are positive, then
+Do_This will be called; otherwise, if either component is nonnegative
+then Do_That will be called; otherwise, Do_The_Other_Thing will be called.
+
+If the set of values that match the choice(s) of an earlier alternative
+overlaps the corresponding set of a later alternative, then the first
+set shall be a proper subset of the second (and the later alternative
+will not be executed if the earlier alternative “matches”). All possible
+values of the composite type shall be covered. The composite type of the
+selector shall be a nonlimited untagged (but possibly discriminated)
+record type, all of whose subcomponent subtypes are either static discrete
+subtypes or record types that meet the same restrictions. Support for arrays
+is planned, but not yet implemented.
+
+In addition, pattern bindings are supported. This is a mechanism
+for binding a name to a component of a matching value for use within
+an alternative of a case statement. For a component association
+that occurs within a case choice, the expression may be followed by
+“is <identifier>”. In the special case of a “box” component association,
+the identifier may instead be provided within the box. Either of these
+indicates that the given identifer denotes (a constant view of) the matching
+subcomponent of the case selector.
+
+Consider this example (which uses type Rec from the previous example):
+
+@example
+procedure Caser_2 (X : Rec) is
+begin
+ case X is
+ when (F1 => Positive is Abc, F2 => Positive) =>
+ Do_This (Abc)
+ when (F1 => Natural is N1, F2 => <N2>) |
+ (F1 => <N2>, F2 => Natural is N1) =>
+ Do_That (Param_1 => N1, Param_2 => N2);
+ when others =>
+ Do_The_Other_Thing;
+ end case;
+end Caser_2;
+@end example
+
+This example is the same as the previous one with respect to
+determining whether Do_This, Do_That, or Do_The_Other_Thing will
+be called. But for this version, Do_This takes a parameter and Do_That
+takes two parameters. If Do_This is called, the actual parameter in the
+call will be X.F1.
+
+If Do_That is called, the situation is more complex because there are two
+choices for that alternative. If Do_That is called because the first choice
+matched (i.e., because X.F1 is nonnegative and either X.F1 or X.F2 is zero
+or negative), then the actual parameters of the call will be (in order)
+X.F1 and X.F2. If Do_That is called because the second choice matched (and
+the first one did not), then the actual parameters will be reversed.
+
+Within the choice list for single alternative, each choice must
+define the same set of bindings and the component subtypes for
+for a given identifer must all statically match. Currently, the case
+of a binding for a nondiscrete component is not implemented.
+
+@item
+Fixed lower bounds for array types and subtypes
+
+Unconstrained array types and subtypes can be specified with a lower bound
+that is fixed to a certain value, by writing an index range that uses the
+syntax “<lower-bound-expression> .. <>”. This guarantees that all objects
+of the type or subtype will have the specified lower bound.
+
+For example, a matrix type with fixed lower bounds of zero for each
+dimension can be declared by the following:
+
+@example
+type Matrix is
+ array (Natural range 0 .. <>, Natural range 0 .. <>) of Integer;
+@end example
+
+Objects of type Matrix declared with an index constraint must have index
+ranges starting at zero:
+
+@example
+M1 : Matrix (0 .. 9, 0 .. 19);
+M2 : Matrix (2 .. 11, 3 .. 22); -- Warning about bounds; will raise CE
+@end example
+
+Similarly, a subtype of String can be declared that specifies the lower
+bound of objects of that subtype to be 1:
+
+@quotation
+
+@example
+subtype String_1 is String (1 .. <>);
+@end example
+@end quotation
+
+If a string slice is passed to a formal of subtype String_1 in a call to
+a subprogram S, the slice’s bounds will “slide” so that the lower bound
+is 1. Within S, the lower bound of the formal is known to be 1, so, unlike
+a normal unconstrained String formal, there is no need to worry about
+accounting for other possible lower-bound values. Sliding of bounds also
+occurs in other contexts, such as for object declarations with an
+unconstrained subtype with fixed lower bound, as well as in subtype
+conversions.
+
+Use of this feature increases safety by simplifying code, and can also
+improve the efficiency of indexing operations, since the compiler statically
+knows the lower bound of unconstrained array formals when the formal’s
+subtype has index ranges with static fixed lower bounds.
+
+@item
+Prefixed-view notation for calls to primitive subprograms of untagged types
+
+Since Ada 2005, calls to primitive subprograms of a tagged type that
+have a “prefixed view” (see RM 4.1.3(9.2)) have been allowed to be
+written using the form of a selected_component, with the first actual
+parameter given as the prefix and the name of the subprogram as a
+selector. This prefixed-view notation for calls is extended so as to
+also allow such syntax for calls to primitive subprograms of untagged
+types. The primitives of an untagged type T that have a prefixed view
+are those where the first formal parameter of the subprogram either
+is of type T or is an anonymous access parameter whose designated type
+is T. For a type that has a component that happens to have the same
+simple name as one of the type’s primitive subprograms, where the
+component is visible at the point of a selected_component using that
+name, preference is given to the component in a selected_component
+(as is currently the case for tagged types with such component names).
@end itemize
@node Pragma Extensions_Visible,Pragma External,Pragma Extensions_Allowed,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas id12}@anchor{66}@anchor{gnat_rm/implementation_defined_pragmas pragma-extensions-visible}@anchor{67}
+@anchor{gnat_rm/implementation_defined_pragmas id12}@anchor{65}@anchor{gnat_rm/implementation_defined_pragmas pragma-extensions-visible}@anchor{66}
@section Pragma Extensions_Visible
@@ -3678,7 +3827,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{68}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-external}@anchor{67}
@section Pragma External
@@ -3699,7 +3848,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{69}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-external-name-casing}@anchor{68}
@section Pragma External_Name_Casing
@@ -3788,7 +3937,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{6a}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-fast-math}@anchor{69}
@section Pragma Fast_Math
@@ -3817,7 +3966,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{6b}@anchor{gnat_rm/implementation_defined_pragmas pragma-favor-top-level}@anchor{6c}
+@anchor{gnat_rm/implementation_defined_pragmas id13}@anchor{6a}@anchor{gnat_rm/implementation_defined_pragmas pragma-favor-top-level}@anchor{6b}
@section Pragma Favor_Top_Level
@@ -3836,7 +3985,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{6d}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-finalize-storage-only}@anchor{6c}
@section Pragma Finalize_Storage_Only
@@ -3856,7 +4005,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{6e}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-float-representation}@anchor{6d}
@section Pragma Float_Representation
@@ -3891,7 +4040,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{6f}@anchor{gnat_rm/implementation_defined_pragmas id14}@anchor{70}
+@anchor{gnat_rm/implementation_defined_pragmas id14}@anchor{6e}@anchor{gnat_rm/implementation_defined_pragmas pragma-ghost}@anchor{6f}
@section Pragma Ghost
@@ -3905,7 +4054,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{71}@anchor{gnat_rm/implementation_defined_pragmas id15}@anchor{72}
+@anchor{gnat_rm/implementation_defined_pragmas id15}@anchor{70}@anchor{gnat_rm/implementation_defined_pragmas pragma-global}@anchor{71}
@section Pragma Global
@@ -3930,7 +4079,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{73}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-ident}@anchor{72}
@section Pragma Ident
@@ -3944,7 +4093,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{74}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-ignore-pragma}@anchor{73}
@section Pragma Ignore_Pragma
@@ -3964,7 +4113,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{75}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-implementation-defined}@anchor{74}
@section Pragma Implementation_Defined
@@ -3991,7 +4140,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{76}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-implemented}@anchor{75}
@section Pragma Implemented
@@ -4034,10 +4183,10 @@ By_Entry guarantees that the action of requeueing will proceed from an entry to
another entry. Implementation kind By_Protected_Procedure transforms the
requeue into a dispatching call, thus eliminating the chance of blocking. Kind
By_Any shares the behavior of By_Entry and By_Protected_Procedure depending on
-the target's overriding subprogram kind.
+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{77}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-implicit-packing}@anchor{76}
@section Pragma Implicit_Packing
@@ -4091,7 +4240,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{78}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-import-function}@anchor{77}
@section Pragma Import_Function
@@ -4156,7 +4305,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{79}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-import-object}@anchor{78}
@section Pragma Import_Object
@@ -4182,7 +4331,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{7a}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-import-procedure}@anchor{79}
@section Pragma Import_Procedure
@@ -4222,7 +4371,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{7b}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-import-valued-procedure}@anchor{7a}
@section Pragma Import_Valued_Procedure
@@ -4275,7 +4424,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{7c}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-independent}@anchor{7b}
@section Pragma Independent
@@ -4297,7 +4446,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{7d}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-independent-components}@anchor{7c}
@section Pragma Independent_Components
@@ -4318,7 +4467,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{7e}@anchor{gnat_rm/implementation_defined_pragmas pragma-initial-condition}@anchor{7f}
+@anchor{gnat_rm/implementation_defined_pragmas id16}@anchor{7d}@anchor{gnat_rm/implementation_defined_pragmas pragma-initial-condition}@anchor{7e}
@section Pragma Initial_Condition
@@ -4332,7 +4481,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{80}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-initialize-scalars}@anchor{7f}
@section Pragma Initialize_Scalars
@@ -4413,14 +4562,14 @@ Initialization with low values.
Initialization with a specific bit pattern.
@end itemize
-See the GNAT User's Guide for binder options for specifying these cases.
+See the GNAT User’s Guide for binder options for specifying these cases.
The bind-time approach is intended to provide fast turnaround for testing
with different values, without having to recompile the program.
@item
At execution time, the programmer can specify the invalid values using an
-environment variable. See the GNAT User's Guide for details.
+environment variable. See the GNAT User’s Guide for details.
The execution-time approach is intended to provide fast turnaround for
testing with different values, without having to recompile and rebind the
@@ -4430,7 +4579,7 @@ program.
Note that pragma @code{Initialize_Scalars} is particularly useful in conjunction
with the enhanced validity checking that is now provided in GNAT, which checks
for invalid values under more conditions. Using this feature (see description
-of the @emph{-gnatV} flag in the GNAT User's Guide) in conjunction with pragma
+of the @emph{-gnatV} flag in the GNAT User’s Guide) in conjunction with pragma
@code{Initialize_Scalars} provides a powerful new tool to assist in the detection
of problems caused by uninitialized variables.
@@ -4438,10 +4587,10 @@ Note: the use of @code{Initialize_Scalars} has a fairly extensive effect on the
generated code. This may cause your code to be substantially larger. It may
also cause an increase in the amount of stack required, so it is probably a
good idea to turn on stack checking (see description of stack checking in the
-GNAT User's Guide) when using this pragma.
+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{81}@anchor{gnat_rm/implementation_defined_pragmas id17}@anchor{82}
+@anchor{gnat_rm/implementation_defined_pragmas id17}@anchor{80}@anchor{gnat_rm/implementation_defined_pragmas pragma-initializes}@anchor{81}
@section Pragma Initializes
@@ -4468,7 +4617,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{83}@anchor{gnat_rm/implementation_defined_pragmas pragma-inline-always}@anchor{84}
+@anchor{gnat_rm/implementation_defined_pragmas id18}@anchor{82}@anchor{gnat_rm/implementation_defined_pragmas pragma-inline-always}@anchor{83}
@section Pragma Inline_Always
@@ -4487,7 +4636,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{85}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-inline-generic}@anchor{84}
@section Pragma Inline_Generic
@@ -4505,7 +4654,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{86}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-interface}@anchor{85}
@section Pragma Interface
@@ -4532,7 +4681,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{87}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-interface-name}@anchor{86}
@section Pragma Interface_Name
@@ -4551,7 +4700,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{88}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-interrupt-handler}@anchor{87}
@section Pragma Interrupt_Handler
@@ -4562,16 +4711,10 @@ pragma Interrupt_Handler (procedure_LOCAL_NAME);
@end example
This program unit pragma is supported for parameterless protected procedures
-as described in Annex C of the Ada Reference Manual. On the AAMP target
-the pragma can also be specified for nonprotected parameterless procedures
-that are declared at the library level (which includes procedures
-declared at the top level of a library package). In the case of AAMP,
-when this pragma is applied to a nonprotected procedure, the instruction
-@code{IERET} is generated for returns from the procedure, enabling
-maskable interrupts, in place of the normal return instruction.
+as described in Annex C of the Ada Reference Manual.
@node Pragma Interrupt_State,Pragma Invariant,Pragma Interrupt_Handler,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-interrupt-state}@anchor{89}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-interrupt-state}@anchor{88}
@section Pragma Interrupt_State
@@ -4653,11 +4796,11 @@ operating system documentation, or the value of the array @code{Reserved}
declared in the spec of package @code{System.OS_Interface}.
Overriding the default state of signals used by the Ada runtime may interfere
-with an application's runtime behavior in the cases of the synchronous signals,
+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{8a}@anchor{gnat_rm/implementation_defined_pragmas pragma-invariant}@anchor{8b}
+@anchor{gnat_rm/implementation_defined_pragmas id19}@anchor{89}@anchor{gnat_rm/implementation_defined_pragmas pragma-invariant}@anchor{8a}
@section Pragma Invariant
@@ -4688,7 +4831,7 @@ is violated. If no Message parameter is provided, a default message that
identifies the line on which the pragma appears is used.
It is permissible to have multiple Invariants for the same type entity, in
-which case they are and'ed together. It is permissible to use this pragma
+which case they are and’ed together. It is permissible to use this pragma
in Ada 2012 mode, but you cannot have both an invariant aspect and an
invariant pragma for the same entity.
@@ -4696,7 +4839,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{8c}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-keep-names}@anchor{8b}
@section Pragma Keep_Names
@@ -4716,7 +4859,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{8d}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-license}@anchor{8c}
@section Pragma License
@@ -4772,13 +4915,13 @@ are recognized, and license information is derived from them as follows.
A GNAT license header starts with a line containing 78 hyphens. The following
comment text is searched for the appearance of any of the following strings.
-If the string 'GNU General Public License' is found, then the unit is assumed
-to have GPL license, unless the string 'As a special exception' follows, in
+If the string ‘GNU General Public License’ is found, then the unit is assumed
+to have GPL license, unless the string ‘As a special exception’ follows, in
which case the license is assumed to be modified GPL.
If one of the strings
-'This specification is adapted from the Ada Semantic Interface' or
-'This specification is derived from the Ada Reference Manual' is found
+‘This specification is adapted from the Ada Semantic Interface’ or
+‘This specification is derived from the Ada Reference Manual’ is found
then the unit is assumed to be unrestricted.
These default actions means that a program with a restricted license pragma
@@ -4811,7 +4954,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{8e}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-link-with}@anchor{8d}
@section Pragma Link_With
@@ -4835,7 +4978,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{8f}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-linker-alias}@anchor{8e}
@section Pragma Linker_Alias
@@ -4876,7 +5019,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{90}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-linker-constructor}@anchor{8f}
@section Pragma Linker_Constructor
@@ -4906,7 +5049,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{91}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-linker-destructor}@anchor{90}
@section Pragma Linker_Destructor
@@ -4929,7 +5072,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{92}@anchor{gnat_rm/implementation_defined_pragmas pragma-linker-section}@anchor{93}
+@anchor{gnat_rm/implementation_defined_pragmas id20}@anchor{91}@anchor{gnat_rm/implementation_defined_pragmas pragma-linker-section}@anchor{92}
@section Pragma Linker_Section
@@ -4946,7 +5089,7 @@ declared at the library level. This pragma specifies the name of the
linker section for the given entity. It is equivalent to
@code{__attribute__((section))} in GNU C and causes @code{LOCAL_NAME} to
be placed in the @code{static_string_EXPRESSION} section of the
-executable (assuming the linker doesn't rename the section).
+executable (assuming the linker doesn’t rename the section).
GNAT also provides an implementation defined aspect of the same name.
In the case of specifying this aspect for a type, the effect is to
@@ -5003,7 +5146,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{94}@anchor{gnat_rm/implementation_defined_pragmas pragma-lock-free}@anchor{95}
+@anchor{gnat_rm/implementation_defined_pragmas id21}@anchor{93}@anchor{gnat_rm/implementation_defined_pragmas pragma-lock-free}@anchor{94}
@section Pragma Lock_Free
@@ -5055,7 +5198,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{96}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-loop-invariant}@anchor{95}
@section Pragma Loop_Invariant
@@ -5074,7 +5217,7 @@ except that in an @code{Assertion_Policy} pragma, the identifier
of statements of a loop body, or nested inside block statements that
appear in the sequence of statements of a loop body.
The intention is that it be used to
-represent a "loop invariant" assertion, i.e. something that is true each
+represent a “loop invariant” assertion, i.e. something that is true each
time through the loop, and which can be used to show that the loop is
achieving its purpose.
@@ -5088,7 +5231,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{97}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-loop-optimize}@anchor{96}
@section Pragma Loop_Optimize
@@ -5150,7 +5293,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{98}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-loop-variant}@anchor{97}
@section Pragma Loop_Variant
@@ -5197,7 +5340,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{99}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-machine-attribute}@anchor{98}
@section Pragma Machine_Attribute
@@ -5214,7 +5357,7 @@ Machine-dependent attributes can be specified for types and/or
declarations. This pragma is semantically equivalent to
@code{__attribute__((@emph{attribute_name}))} (if @code{info} is not
specified) or @code{__attribute__((@emph{attribute_name(info})))}
-or @code{__attribute__((@emph{attribute_name(info,...})))} in GNU C,
+or @code{__attribute__((@emph{attribute_name(info,…})))} in GNU C,
where @emph{attribute_name} is recognized by the compiler middle-end
or the @code{TARGET_ATTRIBUTE_TABLE} machine specific macro. Note
that a string literal for the optional parameter @code{info} or the
@@ -5223,7 +5366,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{9a}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-main}@anchor{99}
@section Pragma Main
@@ -5243,7 +5386,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{9b}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-main-storage}@anchor{9a}
@section Pragma Main_Storage
@@ -5262,7 +5405,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{9c}@anchor{gnat_rm/implementation_defined_pragmas pragma-max-queue-length}@anchor{9d}
+@anchor{gnat_rm/implementation_defined_pragmas id22}@anchor{9b}@anchor{gnat_rm/implementation_defined_pragmas pragma-max-queue-length}@anchor{9c}
@section Pragma Max_Queue_Length
@@ -5280,7 +5423,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{9e}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-no-body}@anchor{9d}
@section Pragma No_Body
@@ -5303,7 +5446,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{9f}@anchor{gnat_rm/implementation_defined_pragmas id23}@anchor{a0}
+@anchor{gnat_rm/implementation_defined_pragmas id23}@anchor{9e}@anchor{gnat_rm/implementation_defined_pragmas pragma-no-caching}@anchor{9f}
@section Pragma No_Caching
@@ -5317,7 +5460,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{a1}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-no-component-reordering}@anchor{a0}
@section Pragma No_Component_Reordering
@@ -5336,7 +5479,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{a2}@anchor{gnat_rm/implementation_defined_pragmas pragma-no-elaboration-code-all}@anchor{a3}
+@anchor{gnat_rm/implementation_defined_pragmas id24}@anchor{a1}@anchor{gnat_rm/implementation_defined_pragmas pragma-no-elaboration-code-all}@anchor{a2}
@section Pragma No_Elaboration_Code_All
@@ -5350,12 +5493,12 @@ This is a program unit pragma (there is also an equivalent aspect of the
same name) that establishes the restriction @code{No_Elaboration_Code} for
the current unit and any extended main source units (body and subunits).
It also has the effect of enforcing a transitive application of this
-aspect, so that if any unit is implicitly or explicitly with'ed by the
+aspect, so that if any unit is implicitly or explicitly with’ed by the
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{a4}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-no-heap-finalization}@anchor{a3}
@section Pragma No_Heap_Finalization
@@ -5387,7 +5530,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{a5}@anchor{gnat_rm/implementation_defined_pragmas pragma-no-inline}@anchor{a6}
+@anchor{gnat_rm/implementation_defined_pragmas id25}@anchor{a4}@anchor{gnat_rm/implementation_defined_pragmas pragma-no-inline}@anchor{a5}
@section Pragma No_Inline
@@ -5405,7 +5548,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{a7}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-no-return}@anchor{a6}
@section Pragma No_Return
@@ -5432,7 +5575,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{a8}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-no-strict-aliasing}@anchor{a7}
@section Pragma No_Strict_Aliasing
@@ -5449,12 +5592,12 @@ arguments is a configuration pragma which applies to all access types
declared in units to which the pragma applies. For a detailed
description of the strict aliasing optimization, and the situations
in which it must be suppressed, see the section on Optimization and Strict Aliasing
-in the @cite{GNAT User's Guide}.
+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{a9}@anchor{gnat_rm/implementation_defined_pragmas id26}@anchor{aa}
+@anchor{gnat_rm/implementation_defined_pragmas id26}@anchor{a8}@anchor{gnat_rm/implementation_defined_pragmas pragma-no-tagged-streams}@anchor{a9}
@section Pragma No_Tagged_Streams
@@ -5493,7 +5636,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{ab}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-normalize-scalars}@anchor{aa}
@section Pragma Normalize_Scalars
@@ -5514,14 +5657,14 @@ are as follows:
@item @emph{Standard.Character}
Objects whose root type is Standard.Character are initialized to
-Character'Last unless the subtype range excludes NUL (in which case
+Character’Last unless the subtype range excludes NUL (in which case
NUL is used). This choice will always generate an invalid value if
one exists.
@item @emph{Standard.Wide_Character}
Objects whose root type is Standard.Wide_Character are initialized to
-Wide_Character'Last unless the subtype range excludes NUL (in which case
+Wide_Character’Last unless the subtype range excludes NUL (in which case
NUL is used). This choice will always generate an invalid value if
one exists.
@@ -5575,7 +5718,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{ac}@anchor{gnat_rm/implementation_defined_pragmas id27}@anchor{ad}
+@anchor{gnat_rm/implementation_defined_pragmas id27}@anchor{ab}@anchor{gnat_rm/implementation_defined_pragmas pragma-obsolescent}@anchor{ac}
@section Pragma Obsolescent
@@ -5671,7 +5814,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{ae}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-optimize-alignment}@anchor{ad}
@section Pragma Optimize_Alignment
@@ -5757,7 +5900,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{af}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-ordered}@anchor{ae}
@section Pragma Ordered
@@ -5846,10 +5989,10 @@ template can be instantiated for both cases), so we never generate warnings
for the case of generic enumerated types.
For additional information please refer to the description of the
-@emph{-gnatw.u} switch in the GNAT User's Guide.
+@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{b0}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-overflow-mode}@anchor{af}
@section Pragma Overflow_Mode
@@ -5865,8 +6008,8 @@ MODE ::= STRICT | MINIMIZED | ELIMINATED
This pragma sets the current overflow mode to the given setting. For details
of the meaning of these modes, please refer to the
-'Overflow Check Handling in GNAT' appendix in the
-GNAT User's Guide. If only the @code{General} parameter is present,
+‘Overflow Check Handling in GNAT’ appendix in the
+GNAT User’s Guide. If only the @code{General} parameter is present,
the given mode applies to all expressions. If both parameters are present,
the @code{General} mode applies to expressions outside assertions, and
the @code{Eliminated} mode applies to expressions within assertions.
@@ -5888,7 +6031,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{b1}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-overriding-renamings}@anchor{b0}
@section Pragma Overriding_Renamings
@@ -5923,7 +6066,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{b2}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-partition-elaboration-policy}@anchor{b1}
@section Pragma Partition_Elaboration_Policy
@@ -5940,7 +6083,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{b3}@anchor{gnat_rm/implementation_defined_pragmas pragma-part-of}@anchor{b4}
+@anchor{gnat_rm/implementation_defined_pragmas id28}@anchor{b2}@anchor{gnat_rm/implementation_defined_pragmas pragma-part-of}@anchor{b3}
@section Pragma Part_Of
@@ -5956,7 +6099,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{b5}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-passive}@anchor{b4}
@section Pragma Passive
@@ -5977,10 +6120,10 @@ optimized. GNAT does not attempt to optimize any tasks in this manner
(since protected objects are available in place of passive tasks).
For more information on the subject of passive tasks, see the section
-'Passive Task Optimization' in the GNAT Users Guide.
+‘Passive Task Optimization’ in the GNAT Users Guide.
@node Pragma Persistent_BSS,Pragma Post,Pragma Passive,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas id29}@anchor{b6}@anchor{gnat_rm/implementation_defined_pragmas pragma-persistent-bss}@anchor{b7}
+@anchor{gnat_rm/implementation_defined_pragmas id29}@anchor{b5}@anchor{gnat_rm/implementation_defined_pragmas pragma-persistent-bss}@anchor{b6}
@section Pragma Persistent_BSS
@@ -6011,7 +6154,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 Post,Pragma Postcondition,Pragma Persistent_BSS,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-post}@anchor{b8}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-post}@anchor{b7}
@section Pragma Post
@@ -6036,7 +6179,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{b9}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-postcondition}@anchor{b8}
@section Pragma Postcondition
@@ -6061,7 +6204,7 @@ implicit returns at the end of procedure bodies and associated
exception handlers).
In addition, the boolean expression which is the condition which
-must be true may contain references to function'Result in the case
+must be true may contain references to function’Result in the case
of a function to refer to the returned value.
@code{Postcondition} pragmas may appear either immediately following the
@@ -6128,7 +6271,7 @@ If a postcondition fails, then the exception
a message argument was supplied, then the given string
will be used as the exception message. If no message
argument was supplied, then the default message has
-the form "Postcondition failed at file_name:line". The
+the form “Postcondition failed at file_name:line”. The
exception is raised in the context of the subprogram
body, so it is possible to catch postcondition failures
within the subprogram body itself.
@@ -6201,7 +6344,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{ba}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-post-class}@anchor{b9}
@section Pragma Post_Class
@@ -6236,7 +6379,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{bb}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-rename-pragma}@anchor{ba}
@section Pragma Rename_Pragma
@@ -6268,14 +6411,14 @@ pragma Rename_Pragma (
Renamed => Inline_Always);
@end example
-Then GNAT will treat "pragma Inline_Only ..." as if you had written
-"pragma Inline_Always ...".
+Then GNAT will treat “pragma Inline_Only …” as if you had written
+“pragma Inline_Always …”.
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.
+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{bc}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-pre}@anchor{bb}
@section Pragma Pre
@@ -6300,7 +6443,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{bd}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-precondition}@anchor{bc}
@section Pragma Precondition
@@ -6320,7 +6463,7 @@ pragma Precondition (
The @code{Precondition} pragma is similar to @code{Postcondition}
except that the corresponding checks take place immediately upon
entry to the subprogram, and if a precondition fails, the exception
-is raised in the context of the caller, and the attribute 'Result
+is raised in the context of the caller, and the attribute ‘Result
cannot be used within the precondition expression.
Otherwise, the placement and visibility rules are identical to those
@@ -6359,7 +6502,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{be}@anchor{gnat_rm/implementation_defined_pragmas id30}@anchor{bf}
+@anchor{gnat_rm/implementation_defined_pragmas id30}@anchor{bd}@anchor{gnat_rm/implementation_defined_pragmas pragma-predicate}@anchor{be}
@section Pragma Predicate
@@ -6404,7 +6547,7 @@ the program and thus do not have a neutral effect if ignored.
The motivation behind providing pragmas equivalent to
corresponding aspects is to allow a program to be written
using the pragmas, and then compiled with a compiler that
-will ignore the pragmas. That doesn't work in the case of
+will ignore the pragmas. That doesn’t work in the case of
static and dynamic predicates, since if the corresponding
pragmas are ignored, then the behavior of the program is
fundamentally changed (for example a membership test
@@ -6413,7 +6556,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{c0}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-predicate-failure}@anchor{bf}
@section Pragma Predicate_Failure
@@ -6430,7 +6573,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{c1}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-preelaborable-initialization}@anchor{c0}
@section Pragma Preelaborable_Initialization
@@ -6445,7 +6588,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{c2}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-prefix-exception-messages}@anchor{c1}
@section Pragma Prefix_Exception_Messages
@@ -6476,7 +6619,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{c3}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-pre-class}@anchor{c2}
@section Pragma Pre_Class
@@ -6511,7 +6654,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{c4}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-priority-specific-dispatching}@anchor{c3}
@section Pragma Priority_Specific_Dispatching
@@ -6535,7 +6678,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{c5}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-profile}@anchor{c4}
@section Pragma Profile
@@ -6681,7 +6824,7 @@ packages:
@end itemize
This set of configuration pragmas and restrictions correspond to the
-definition of the 'Ravenscar Profile' for limited tasking, devised and
+definition of the ‘Ravenscar Profile’ for limited tasking, devised and
published by the @cite{International Real-Time Ada Workshop@comma{} 1997}.
A description is also available at
@indicateurl{http://www-users.cs.york.ac.uk/~burns/ravenscar.ps}.
@@ -6724,7 +6867,7 @@ The @code{Max_Protected_Entries}, @code{Max_Entry_Queue_Length}, and
Details on the rationale for @code{Jorvik} and implications for use may be
found in @cite{A New Ravenscar-Based Profile} by P. Rogers, J. Ruiz,
-T. Gingold and P. Bernardi, in @cite{Reliable Software Technologies -- Ada Europe 2017}, Springer-Verlag Lecture Notes in Computer Science,
+T. Gingold and P. Bernardi, in @cite{Reliable Software Technologies – Ada Europe 2017}, Springer-Verlag Lecture Notes in Computer Science,
Number 10300.
@item
@@ -6814,7 +6957,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{c6}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-profile-warnings}@anchor{c5}
@section Pragma Profile_Warnings
@@ -6832,7 +6975,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{c7}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-propagate-exceptions}@anchor{c6}
@section Pragma Propagate_Exceptions
@@ -6851,7 +6994,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{c8}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-provide-shift-operators}@anchor{c7}
@section Pragma Provide_Shift_Operators
@@ -6868,10 +7011,10 @@ either an unsigned or signed type. It has the effect of providing the
five shift operators (Shift_Left, Shift_Right, Shift_Right_Arithmetic,
Rotate_Left and Rotate_Right) for the given type. It is similar to
including the function declarations for these five operators, together
-with the pragma Import (Intrinsic, ...) statements.
+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{c9}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-psect-object}@anchor{c8}
@section Pragma Psect_Object
@@ -6891,7 +7034,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{ca}@anchor{gnat_rm/implementation_defined_pragmas id31}@anchor{cb}
+@anchor{gnat_rm/implementation_defined_pragmas id31}@anchor{c9}@anchor{gnat_rm/implementation_defined_pragmas pragma-pure-function}@anchor{ca}
@section Pragma Pure_Function
@@ -6953,7 +7096,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{cc}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-rational}@anchor{cb}
@section Pragma Rational
@@ -6971,7 +7114,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{cd}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-ravenscar}@anchor{cc}
@section Pragma Ravenscar
@@ -6991,7 +7134,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{ce}@anchor{gnat_rm/implementation_defined_pragmas id32}@anchor{cf}
+@anchor{gnat_rm/implementation_defined_pragmas id32}@anchor{cd}@anchor{gnat_rm/implementation_defined_pragmas pragma-refined-depends}@anchor{ce}
@section Pragma Refined_Depends
@@ -7024,7 +7167,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{d0}@anchor{gnat_rm/implementation_defined_pragmas id33}@anchor{d1}
+@anchor{gnat_rm/implementation_defined_pragmas id33}@anchor{cf}@anchor{gnat_rm/implementation_defined_pragmas pragma-refined-global}@anchor{d0}
@section Pragma Refined_Global
@@ -7049,7 +7192,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{d2}@anchor{gnat_rm/implementation_defined_pragmas id34}@anchor{d3}
+@anchor{gnat_rm/implementation_defined_pragmas id34}@anchor{d1}@anchor{gnat_rm/implementation_defined_pragmas pragma-refined-post}@anchor{d2}
@section Pragma Refined_Post
@@ -7063,7 +7206,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{d4}@anchor{gnat_rm/implementation_defined_pragmas id35}@anchor{d5}
+@anchor{gnat_rm/implementation_defined_pragmas id35}@anchor{d3}@anchor{gnat_rm/implementation_defined_pragmas pragma-refined-state}@anchor{d4}
@section Pragma Refined_State
@@ -7089,7 +7232,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{d6}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-relative-deadline}@anchor{d5}
@section Pragma Relative_Deadline
@@ -7104,7 +7247,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{d7}@anchor{gnat_rm/implementation_defined_pragmas pragma-remote-access-type}@anchor{d8}
+@anchor{gnat_rm/implementation_defined_pragmas id36}@anchor{d6}@anchor{gnat_rm/implementation_defined_pragmas pragma-remote-access-type}@anchor{d7}
@section Pragma Remote_Access_Type
@@ -7130,7 +7273,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{d9}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-restricted-run-time}@anchor{d8}
@section Pragma Restricted_Run_Time
@@ -7151,7 +7294,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{da}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-restriction-warnings}@anchor{d9}
@section Pragma Restriction_Warnings
@@ -7189,7 +7332,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{db}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-reviewable}@anchor{da}
@section Pragma Reviewable
@@ -7293,7 +7436,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{dc}@anchor{gnat_rm/implementation_defined_pragmas pragma-secondary-stack-size}@anchor{dd}
+@anchor{gnat_rm/implementation_defined_pragmas id37}@anchor{db}@anchor{gnat_rm/implementation_defined_pragmas pragma-secondary-stack-size}@anchor{dc}
@section Pragma Secondary_Stack_Size
@@ -7320,7 +7463,7 @@ an @code{integer_EXPRESSION} of bytes is assigned from the primary stack instead
For most targets, the pragma does not apply as the secondary stack grows on
demand: allocated as a chain of blocks in the heap. The default size of these
blocks can be modified via the @code{-D} binder option as described in
-@cite{GNAT User's Guide}.
+@cite{GNAT User’s Guide}.
Note that no check is made to see if the secondary stack can fit inside the
primary stack.
@@ -7329,7 +7472,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{de}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-share-generic}@anchor{dd}
@section Pragma Share_Generic
@@ -7347,7 +7490,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{df}@anchor{gnat_rm/implementation_defined_pragmas pragma-shared}@anchor{e0}
+@anchor{gnat_rm/implementation_defined_pragmas id38}@anchor{de}@anchor{gnat_rm/implementation_defined_pragmas pragma-shared}@anchor{df}
@section Pragma Shared
@@ -7355,7 +7498,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{e1}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-short-circuit-and-or}@anchor{e0}
@section Pragma Short_Circuit_And_Or
@@ -7374,7 +7517,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{e2}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-short-descriptors}@anchor{e1}
@section Pragma Short_Descriptors
@@ -7388,7 +7531,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{e3}@anchor{gnat_rm/implementation_defined_pragmas id39}@anchor{e4}
+@anchor{gnat_rm/implementation_defined_pragmas id39}@anchor{e2}@anchor{gnat_rm/implementation_defined_pragmas pragma-simple-storage-pool-type}@anchor{e3}
@section Pragma Simple_Storage_Pool_Type
@@ -7403,7 +7546,7 @@ Syntax:
pragma Simple_Storage_Pool_Type (type_LOCAL_NAME);
@end example
-A type can be established as a 'simple storage pool type' by applying
+A type can be established as a ‘simple storage pool type’ by applying
the representation pragma @code{Simple_Storage_Pool_Type} to the type.
A type named in the pragma must be a library-level immutably limited record
type or limited tagged type declared immediately within a package declaration.
@@ -7442,7 +7585,7 @@ storage-management discipline).
An object of a simple storage pool type can be associated with an access
type by specifying the attribute
-@ref{e5,,Simple_Storage_Pool}. For example:
+@ref{e4,,Simple_Storage_Pool}. For example:
@example
My_Pool : My_Simple_Storage_Pool_Type;
@@ -7452,11 +7595,11 @@ type Acc is access My_Data_Type;
for Acc'Simple_Storage_Pool use My_Pool;
@end example
-See attribute @ref{e5,,Simple_Storage_Pool}
+See attribute @ref{e4,,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{e6}@anchor{gnat_rm/implementation_defined_pragmas id40}@anchor{e7}
+@anchor{gnat_rm/implementation_defined_pragmas id40}@anchor{e5}@anchor{gnat_rm/implementation_defined_pragmas pragma-source-file-name}@anchor{e6}
@section Pragma Source_File_Name
@@ -7548,14 +7691,14 @@ 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{e8,,Pragma Source_File_Name_Project}.
+Source_File_Name cannot appear after a @ref{e7,,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}.
+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{e8}@anchor{gnat_rm/implementation_defined_pragmas id41}@anchor{e9}
+@anchor{gnat_rm/implementation_defined_pragmas id41}@anchor{e8}@anchor{gnat_rm/implementation_defined_pragmas pragma-source-file-name-project}@anchor{e7}
@section Pragma Source_File_Name_Project
@@ -7573,7 +7716,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{ea}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-source-reference}@anchor{e9}
@section Pragma Source_Reference
@@ -7597,7 +7740,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{eb}@anchor{gnat_rm/implementation_defined_pragmas id42}@anchor{ec}
+@anchor{gnat_rm/implementation_defined_pragmas id42}@anchor{ea}@anchor{gnat_rm/implementation_defined_pragmas pragma-spark-mode}@anchor{eb}
@section Pragma SPARK_Mode
@@ -7644,7 +7787,7 @@ Normally a subprogram or package spec/body inherits the current mode
that is active at the point it is declared. But this can be overridden
by pragma within the spec or body as above.
-The basic consistency rule is that you can't turn SPARK_Mode back
+The basic consistency rule is that you can’t turn SPARK_Mode back
@code{On}, once you have explicitly (with a pragma) turned if
@code{Off}. So the following rules apply:
@@ -7679,7 +7822,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{ed}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-static-elaboration-desired}@anchor{ec}
@section Pragma Static_Elaboration_Desired
@@ -7703,7 +7846,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{ee}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-stream-convert}@anchor{ed}
@section Pragma Stream_Convert
@@ -7771,7 +7914,7 @@ The effect is that if the value of an unbounded string is written to a stream,
then the representation of the item in the stream is in the same format that
would be used for @code{Standard.String'Output}, and this same representation
is expected when a value of this type is read from the stream. Note that the
-value written always includes the bounds, even for Unbounded_String'Write,
+value written always includes the bounds, even for Unbounded_String’Write,
since Unbounded_String is not an array type.
Note that the @code{Stream_Convert} pragma is not effective in the case of
@@ -7780,7 +7923,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{ef}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-style-checks}@anchor{ee}
@section Pragma Style_Checks
@@ -7822,7 +7965,7 @@ gcc -c -gnatyl ...
The form @code{ALL_CHECKS} activates all standard checks (its use is equivalent
to the use of the @code{gnaty} switch with no options.
-See the @cite{GNAT User's Guide} for details.)
+See the @cite{GNAT User’s Guide} for details.)
Note: the behavior is slightly different in GNAT mode (@code{-gnatg} used).
In this case, @code{ALL_CHECKS} implies the standard set of GNAT mode style check
@@ -7853,7 +7996,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{f0}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-subtitle}@anchor{ef}
@section Pragma Subtitle
@@ -7867,7 +8010,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{f1}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-suppress}@anchor{f0}
@section Pragma Suppress
@@ -7933,14 +8076,14 @@ checks, but does not require the compiler to omit checks. The compiler
will generate checks if they are essentially free, even when they are
suppressed. In particular, if the compiler can prove that a certain
check will necessarily fail, it will generate code to do an
-unconditional 'raise', even if checks are suppressed. The compiler
+unconditional ‘raise’, even if checks are suppressed. The compiler
warns in this case.
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{f2}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-suppress-all}@anchor{f1}
@section Pragma Suppress_All
@@ -7959,7 +8102,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{f3}@anchor{gnat_rm/implementation_defined_pragmas id43}@anchor{f4}
+@anchor{gnat_rm/implementation_defined_pragmas id43}@anchor{f2}@anchor{gnat_rm/implementation_defined_pragmas pragma-suppress-debug-info}@anchor{f3}
@section Pragma Suppress_Debug_Info
@@ -7974,7 +8117,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{f5}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-suppress-exception-locations}@anchor{f4}
@section Pragma Suppress_Exception_Locations
@@ -7997,7 +8140,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{f6}@anchor{gnat_rm/implementation_defined_pragmas pragma-suppress-initialization}@anchor{f7}
+@anchor{gnat_rm/implementation_defined_pragmas id44}@anchor{f5}@anchor{gnat_rm/implementation_defined_pragmas pragma-suppress-initialization}@anchor{f6}
@section Pragma Suppress_Initialization
@@ -8042,7 +8185,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{f8}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-task-name}@anchor{f7}
@section Pragma Task_Name
@@ -8098,7 +8241,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{f9}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-task-storage}@anchor{f8}
@section Pragma Task_Storage
@@ -8118,7 +8261,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{fa}@anchor{gnat_rm/implementation_defined_pragmas id45}@anchor{fb}
+@anchor{gnat_rm/implementation_defined_pragmas id45}@anchor{f9}@anchor{gnat_rm/implementation_defined_pragmas pragma-test-case}@anchor{fa}
@section Pragma Test_Case
@@ -8174,7 +8317,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{fc}@anchor{gnat_rm/implementation_defined_pragmas id46}@anchor{fd}
+@anchor{gnat_rm/implementation_defined_pragmas id46}@anchor{fb}@anchor{gnat_rm/implementation_defined_pragmas pragma-thread-local-storage}@anchor{fc}
@section Pragma Thread_Local_Storage
@@ -8192,7 +8335,7 @@ pragma Thread_Local_Storage ([Entity =>] LOCAL_NAME);
This pragma specifies that the specified entity, which must be
a variable declared in a library-level package, is to be marked as
-"Thread Local Storage" (@code{TLS}). On systems supporting this (which
+“Thread Local Storage” (@code{TLS}). On systems supporting this (which
include Windows, Solaris, GNU/Linux, and VxWorks 6), this causes each
thread (and hence each Ada task) to see a distinct copy of the variable.
@@ -8212,7 +8355,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{fe}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-time-slice}@anchor{fd}
@section Pragma Time_Slice
@@ -8228,7 +8371,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{ff}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-title}@anchor{fe}
@section Pragma Title
@@ -8253,7 +8396,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{100}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-type-invariant}@anchor{ff}
@section Pragma Type_Invariant
@@ -8274,7 +8417,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{101}@anchor{gnat_rm/implementation_defined_pragmas pragma-type-invariant-class}@anchor{102}
+@anchor{gnat_rm/implementation_defined_pragmas id47}@anchor{100}@anchor{gnat_rm/implementation_defined_pragmas pragma-type-invariant-class}@anchor{101}
@section Pragma Type_Invariant_Class
@@ -8301,7 +8444,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{103}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-unchecked-union}@anchor{102}
@section Pragma Unchecked_Union
@@ -8321,7 +8464,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{104}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-unevaluated-use-of-old}@anchor{103}
@section Pragma Unevaluated_Use_Of_Old
@@ -8376,7 +8519,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{105}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-unimplemented-unit}@anchor{104}
@section Pragma Unimplemented_Unit
@@ -8395,8 +8538,8 @@ a clean manner.
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{106}@anchor{gnat_rm/implementation_defined_pragmas id48}@anchor{107}
+@node Pragma Universal_Aliasing,Pragma Unmodified,Pragma Unimplemented_Unit,Implementation Defined Pragmas
+@anchor{gnat_rm/implementation_defined_pragmas id48}@anchor{105}@anchor{gnat_rm/implementation_defined_pragmas pragma-universal-aliasing}@anchor{106}
@section Pragma Universal_Aliasing
@@ -8412,34 +8555,10 @@ optimization for the given type. In other words, the effect is as though
access types designating this type were subject to pragma No_Strict_Aliasing.
For a detailed description of the strict aliasing optimization, and the
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{108}@anchor{gnat_rm/implementation_defined_pragmas id49}@anchor{109}
-@section Pragma Universal_Data
-
-
-Syntax:
+@code{Optimization and Strict Aliasing} in the @cite{GNAT User’s Guide}.
-@example
-pragma Universal_Data [(library_unit_Name)];
-@end example
-
-This pragma is supported only for the AAMP target and is ignored for
-other targets. The pragma specifies that all library-level objects
-(Counter 0 data) associated with the library unit are to be accessed
-and updated using universal addressing (24-bit addresses for AAMP5)
-rather than the default of 16-bit Data Environment (DENV) addressing.
-Use of this pragma will generally result in less efficient code for
-references to global data associated with the library unit, but
-allows such data to be located anywhere in memory. This pragma is
-a library unit pragma, but can also be used as a configuration pragma
-(including use in the @code{gnat.adc} file). The functionality
-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{10a}@anchor{gnat_rm/implementation_defined_pragmas pragma-unmodified}@anchor{10b}
+@node Pragma Unmodified,Pragma Unreferenced,Pragma Universal_Aliasing,Implementation Defined Pragmas
+@anchor{gnat_rm/implementation_defined_pragmas id49}@anchor{107}@anchor{gnat_rm/implementation_defined_pragmas pragma-unmodified}@anchor{108}
@section Pragma Unmodified
@@ -8473,7 +8592,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{10c}@anchor{gnat_rm/implementation_defined_pragmas id51}@anchor{10d}
+@anchor{gnat_rm/implementation_defined_pragmas id50}@anchor{109}@anchor{gnat_rm/implementation_defined_pragmas pragma-unreferenced}@anchor{10a}
@section Pragma Unreferenced
@@ -8533,7 +8652,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{10e}@anchor{gnat_rm/implementation_defined_pragmas id52}@anchor{10f}
+@anchor{gnat_rm/implementation_defined_pragmas id51}@anchor{10b}@anchor{gnat_rm/implementation_defined_pragmas pragma-unreferenced-objects}@anchor{10c}
@section Pragma Unreferenced_Objects
@@ -8558,7 +8677,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{110}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-unreserve-all-interrupts}@anchor{10d}
@section Pragma Unreserve_All_Interrupts
@@ -8594,7 +8713,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{111}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-unsuppress}@anchor{10e}
@section Pragma Unsuppress
@@ -8630,7 +8749,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{112}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-use-vads-size}@anchor{10f}
@section Pragma Use_VADS_Size
@@ -8646,15 +8765,15 @@ pragma Use_VADS_Size;
@end example
This is a configuration pragma. In a unit to which it applies, any use
-of the 'Size attribute is automatically interpreted as a use of the
-'VADS_Size attribute. Note that this may result in incorrect semantic
+of the ‘Size attribute is automatically interpreted as a use of the
+‘VADS_Size attribute. Note that this may result in incorrect semantic
processing of valid Ada 95 or Ada 2005 programs. This is intended to aid in
the handling of existing code which depends on the interpretation of Size
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{113}@anchor{gnat_rm/implementation_defined_pragmas id53}@anchor{114}
+@anchor{gnat_rm/implementation_defined_pragmas id52}@anchor{110}@anchor{gnat_rm/implementation_defined_pragmas pragma-unused}@anchor{111}
@section Pragma Unused
@@ -8688,7 +8807,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{115}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-validity-checks}@anchor{112}
@section Pragma Validity_Checks
@@ -8711,7 +8830,7 @@ activated. The validity checks are first set to include only the default
reference manual settings, and then a string of letters in the string
specifies the exact set of options required. The form of this string
is exactly as described for the @emph{-gnatVx} compiler switch (see the
-GNAT User's Guide for details). For example the following two
+GNAT User’s Guide for details). For example the following two
methods can be used to enable validity checking for mode @code{in} and
@code{in out} subprogram parameters:
@@ -8744,7 +8863,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{116}@anchor{gnat_rm/implementation_defined_pragmas pragma-volatile}@anchor{117}
+@anchor{gnat_rm/implementation_defined_pragmas id53}@anchor{113}@anchor{gnat_rm/implementation_defined_pragmas pragma-volatile}@anchor{114}
@section Pragma Volatile
@@ -8762,7 +8881,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{118}@anchor{gnat_rm/implementation_defined_pragmas pragma-volatile-full-access}@anchor{119}
+@anchor{gnat_rm/implementation_defined_pragmas id54}@anchor{115}@anchor{gnat_rm/implementation_defined_pragmas pragma-volatile-full-access}@anchor{116}
@section Pragma Volatile_Full_Access
@@ -8788,7 +8907,7 @@ is not to the whole object; the compiler is allowed (and generally will)
access only part of the object in this case.
@node Pragma Volatile_Function,Pragma Warning_As_Error,Pragma Volatile_Full_Access,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas id56}@anchor{11a}@anchor{gnat_rm/implementation_defined_pragmas pragma-volatile-function}@anchor{11b}
+@anchor{gnat_rm/implementation_defined_pragmas id55}@anchor{117}@anchor{gnat_rm/implementation_defined_pragmas pragma-volatile-function}@anchor{118}
@section Pragma Volatile_Function
@@ -8802,7 +8921,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{11c}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-warning-as-error}@anchor{119}
@section Pragma Warning_As_Error
@@ -8819,7 +8938,7 @@ as an error. This gives more precise control than -gnatwe,
which treats warnings as errors.
This pragma can apply to regular warnings (messages enabled by -gnatw)
-and to style warnings (messages that start with "(style)",
+and to style warnings (messages that start with “(style)”,
enabled by -gnaty).
The pattern may contain asterisks, which match zero or more characters
@@ -8842,7 +8961,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{11d,,Pragma Warnings}.
+warnings provided by the back end and mentioned in @ref{11a,,Pragma Warnings}.
By using a single full @emph{-Wxxx} switch in the pragma, such warnings
can also be treated as errors.
@@ -8888,11 +9007,11 @@ Note that this pragma does not affect the set of warnings issued in
any way, it merely changes the effect of a matching warning if one
is produced as a result of other warnings options. As shown in this
example, if the pragma results in a warning being treated as an error,
-the tag is changed from "warning:" to "error:" and the string
-"[warning-as-error]" is appended to the end of the message.
+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{11e}@anchor{gnat_rm/implementation_defined_pragmas pragma-warnings}@anchor{11d}
+@anchor{gnat_rm/implementation_defined_pragmas id56}@anchor{11b}@anchor{gnat_rm/implementation_defined_pragmas pragma-warnings}@anchor{11a}
@section Pragma Warnings
@@ -8958,7 +9077,7 @@ line switch controlling warnings. For a brief summary, use the gnatmake
command with no arguments, which will generate usage information containing
the list of warnings switches supported. For
full details see the section on @code{Warning Message Control} in the
-@cite{GNAT User's Guide}.
+@cite{GNAT User’s Guide}.
This form can also be used as a configuration pragma.
The warnings controlled by the @code{-gnatw} switch are generated by the
@@ -8980,7 +9099,7 @@ also be used as a configuration pragma.
The fourth form, with an @code{On|Off} parameter and a string, is used to
control individual messages, based on their text. The string argument
is a pattern that is used to match against the text of individual
-warning messages (not including the initial "warning: " tag).
+warning messages (not including the initial “warning: ” tag).
The pattern may contain asterisks, which match zero or more characters in
the message. For example, you can use
@@ -9048,7 +9167,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{11f}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-weak-external}@anchor{11c}
@section Pragma Weak_External
@@ -9099,7 +9218,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{120}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-wide-character-encoding}@anchor{11d}
@section Pragma Wide_Character_Encoding
@@ -9117,7 +9236,7 @@ to appear within the same file.
However, note that the pragma cannot immediately precede the relevant
wide character, because then the previous encoding will still be in
-effect, causing "illegal character" errors.
+effect, causing “illegal character” errors.
The argument can be an identifier or a character literal. In the identifier
case, it is one of @code{HEX}, @code{UPPER}, @code{SHIFT_JIS},
@@ -9130,7 +9249,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{121}@anchor{gnat_rm/implementation_defined_aspects doc}@anchor{122}@anchor{gnat_rm/implementation_defined_aspects id1}@anchor{123}
+@anchor{gnat_rm/implementation_defined_aspects doc}@anchor{11e}@anchor{gnat_rm/implementation_defined_aspects id1}@anchor{11f}@anchor{gnat_rm/implementation_defined_aspects implementation-defined-aspects}@anchor{120}
@chapter Implementation Defined Aspects
@@ -9206,7 +9325,7 @@ or attribute definition clause.
* Aspect Initializes::
* Aspect Inline_Always::
* Aspect Invariant::
-* Aspect Invariant'Class::
+* Aspect Invariant’Class::
* Aspect Iterable::
* Aspect Linker_Section::
* Aspect Lock_Free::
@@ -9215,6 +9334,7 @@ or attribute definition clause.
* Aspect No_Elaboration_Code_All::
* Aspect No_Inline::
* Aspect No_Tagged_Streams::
+* Aspect No_Task_Parts::
* Aspect Object_Size::
* Aspect Obsolescent::
* Aspect Part_Of::
@@ -9238,7 +9358,6 @@ or attribute definition clause.
* Aspect Test_Case::
* Aspect Thread_Local_Storage::
* Aspect Universal_Aliasing::
-* Aspect Universal_Data::
* Aspect Unmodified::
* Aspect Unreferenced::
* Aspect Unreferenced_Objects::
@@ -9250,16 +9369,16 @@ 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{124}
+@anchor{gnat_rm/implementation_defined_aspects aspect-abstract-state}@anchor{121}
@section Aspect Abstract_State
@geindex Abstract_State
-This aspect is equivalent to @ref{1c,,pragma Abstract_State}.
+This aspect is equivalent to @ref{1d,,pragma Abstract_State}.
@node Aspect Annotate,Aspect Async_Readers,Aspect Abstract_State,Implementation Defined Aspects
-@anchor{gnat_rm/implementation_defined_aspects aspect-annotate}@anchor{125}
+@anchor{gnat_rm/implementation_defined_aspects aspect-annotate}@anchor{122}
@section Aspect Annotate
@@ -9267,7 +9386,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{26,,pragma Annotate}.
+corresponding to @ref{27,,pragma Annotate}.
@table @asis
@@ -9286,16 +9405,16 @@ 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{126}
+@anchor{gnat_rm/implementation_defined_aspects aspect-async-readers}@anchor{123}
@section Aspect Async_Readers
@geindex Async_Readers
-This boolean aspect is equivalent to @ref{2d,,pragma Async_Readers}.
+This boolean aspect is equivalent to @ref{2e,,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{127}
+@anchor{gnat_rm/implementation_defined_aspects aspect-async-writers}@anchor{124}
@section Aspect Async_Writers
@@ -9304,7 +9423,7 @@ This boolean aspect is equivalent to @ref{2d,,pragma Async_Readers}.
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{128}
+@anchor{gnat_rm/implementation_defined_aspects aspect-constant-after-elaboration}@anchor{125}
@section Aspect Constant_After_Elaboration
@@ -9313,7 +9432,7 @@ This boolean aspect is equivalent to @ref{30,,pragma Async_Writers}.
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{129}
+@anchor{gnat_rm/implementation_defined_aspects aspect-contract-cases}@anchor{126}
@section Aspect Contract_Cases
@@ -9324,16 +9443,16 @@ 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{12a}
+@anchor{gnat_rm/implementation_defined_aspects aspect-depends}@anchor{127}
@section Aspect Depends
@geindex Depends
-This aspect is equivalent to @ref{53,,pragma Depends}.
+This aspect is equivalent to @ref{54,,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{12b}
+@anchor{gnat_rm/implementation_defined_aspects aspect-default-initial-condition}@anchor{128}
@section Aspect Default_Initial_Condition
@@ -9342,7 +9461,7 @@ This aspect is equivalent to @ref{53,,pragma Depends}.
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{12c}
+@anchor{gnat_rm/implementation_defined_aspects aspect-dimension}@anchor{129}
@section Aspect Dimension
@@ -9378,7 +9497,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{12d}
+@anchor{gnat_rm/implementation_defined_aspects aspect-dimension-system}@anchor{12a}
@section Aspect Dimension_System
@@ -9434,11 +9553,11 @@ Note that in the above type definition, we use the @code{at} symbol (@code{@@})
represent a theta character (avoiding the use of extended Latin-1
characters in this context).
-See section 'Performing Dimensionality Analysis in GNAT' in the GNAT Users
+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{12e}
+@anchor{gnat_rm/implementation_defined_aspects aspect-disable-controlled}@anchor{12b}
@section Aspect Disable_Controlled
@@ -9451,7 +9570,7 @@ 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{12f}
+@anchor{gnat_rm/implementation_defined_aspects aspect-effective-reads}@anchor{12c}
@section Aspect Effective_Reads
@@ -9460,7 +9579,7 @@ whether some run-time check is enabled or suppressed.
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{130}
+@anchor{gnat_rm/implementation_defined_aspects aspect-effective-writes}@anchor{12d}
@section Aspect Effective_Writes
@@ -9469,25 +9588,25 @@ This aspect is equivalent to @ref{59,,pragma Effective_Reads}.
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{131}
+@anchor{gnat_rm/implementation_defined_aspects aspect-extensions-visible}@anchor{12e}
@section Aspect Extensions_Visible
@geindex Extensions_Visible
-This aspect is equivalent to @ref{67,,pragma Extensions_Visible}.
+This aspect is equivalent to @ref{66,,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{132}
+@anchor{gnat_rm/implementation_defined_aspects aspect-favor-top-level}@anchor{12f}
@section Aspect Favor_Top_Level
@geindex Favor_Top_Level
-This boolean aspect is equivalent to @ref{6c,,pragma Favor_Top_Level}.
+This boolean aspect is equivalent to @ref{6b,,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{133}
+@anchor{gnat_rm/implementation_defined_aspects aspect-ghost}@anchor{130}
@section Aspect Ghost
@@ -9496,7 +9615,7 @@ This boolean aspect is equivalent to @ref{6c,,pragma Favor_Top_Level}.
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{134}
+@anchor{gnat_rm/implementation_defined_aspects aspect-global}@anchor{131}
@section Aspect Global
@@ -9505,16 +9624,16 @@ This aspect is equivalent to @ref{6f,,pragma Ghost}.
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{135}
+@anchor{gnat_rm/implementation_defined_aspects aspect-initial-condition}@anchor{132}
@section Aspect Initial_Condition
@geindex Initial_Condition
-This aspect is equivalent to @ref{7f,,pragma Initial_Condition}.
+This aspect is equivalent to @ref{7e,,pragma Initial_Condition}.
@node Aspect Initializes,Aspect Inline_Always,Aspect Initial_Condition,Implementation Defined Aspects
-@anchor{gnat_rm/implementation_defined_aspects aspect-initializes}@anchor{136}
+@anchor{gnat_rm/implementation_defined_aspects aspect-initializes}@anchor{133}
@section Aspect Initializes
@@ -9523,38 +9642,38 @@ This aspect is equivalent to @ref{7f,,pragma Initial_Condition}.
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{137}
+@anchor{gnat_rm/implementation_defined_aspects aspect-inline-always}@anchor{134}
@section Aspect Inline_Always
@geindex Inline_Always
-This boolean aspect is equivalent to @ref{84,,pragma Inline_Always}.
+This boolean aspect is equivalent to @ref{83,,pragma Inline_Always}.
-@node Aspect Invariant,Aspect Invariant'Class,Aspect Inline_Always,Implementation Defined Aspects
-@anchor{gnat_rm/implementation_defined_aspects aspect-invariant}@anchor{138}
+@node Aspect Invariant,Aspect Invariant’Class,Aspect Inline_Always,Implementation Defined Aspects
+@anchor{gnat_rm/implementation_defined_aspects aspect-invariant}@anchor{135}
@section Aspect Invariant
@geindex Invariant
-This aspect is equivalent to @ref{8b,,pragma Invariant}. It is a
+This aspect is equivalent to @ref{8a,,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{139}
-@section Aspect Invariant'Class
+@node Aspect Invariant’Class,Aspect Iterable,Aspect Invariant,Implementation Defined Aspects
+@anchor{gnat_rm/implementation_defined_aspects aspect-invariant-class}@anchor{136}
+@section Aspect Invariant’Class
@geindex Invariant'Class
-This aspect is equivalent to @ref{102,,pragma Type_Invariant_Class}. It is a
+This aspect is equivalent to @ref{101,,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{13a}
+@node Aspect Iterable,Aspect Linker_Section,Aspect Invariant’Class,Implementation Defined Aspects
+@anchor{gnat_rm/implementation_defined_aspects aspect-iterable}@anchor{137}
@section Aspect Iterable
@@ -9634,34 +9753,34 @@ 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{13b}
+@anchor{gnat_rm/implementation_defined_aspects aspect-linker-section}@anchor{138}
@section Aspect Linker_Section
@geindex Linker_Section
-This aspect is equivalent to @ref{93,,pragma Linker_Section}.
+This aspect is equivalent to @ref{92,,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{13c}
+@anchor{gnat_rm/implementation_defined_aspects aspect-lock-free}@anchor{139}
@section Aspect Lock_Free
@geindex Lock_Free
-This boolean aspect is equivalent to @ref{95,,pragma Lock_Free}.
+This boolean aspect is equivalent to @ref{94,,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{13d}
+@anchor{gnat_rm/implementation_defined_aspects aspect-max-queue-length}@anchor{13a}
@section Aspect Max_Queue_Length
@geindex Max_Queue_Length
-This aspect is equivalent to @ref{9d,,pragma Max_Queue_Length}.
+This aspect is equivalent to @ref{9c,,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{13e}
+@anchor{gnat_rm/implementation_defined_aspects aspect-no-caching}@anchor{13b}
@section Aspect No_Caching
@@ -9670,26 +9789,26 @@ This aspect is equivalent to @ref{9d,,pragma Max_Queue_Length}.
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{13f}
+@anchor{gnat_rm/implementation_defined_aspects aspect-no-elaboration-code-all}@anchor{13c}
@section Aspect No_Elaboration_Code_All
@geindex No_Elaboration_Code_All
-This aspect is equivalent to @ref{a3,,pragma No_Elaboration_Code_All}
+This aspect is equivalent to @ref{a2,,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{140}
+@anchor{gnat_rm/implementation_defined_aspects aspect-no-inline}@anchor{13d}
@section Aspect No_Inline
@geindex No_Inline
-This boolean aspect is equivalent to @ref{a6,,pragma No_Inline}.
+This boolean aspect is equivalent to @ref{a5,,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{141}
+@node Aspect No_Tagged_Streams,Aspect No_Task_Parts,Aspect No_Inline,Implementation Defined Aspects
+@anchor{gnat_rm/implementation_defined_aspects aspect-no-tagged-streams}@anchor{13e}
@section Aspect No_Tagged_Streams
@@ -9699,17 +9818,33 @@ 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{142}
+@node Aspect No_Task_Parts,Aspect Object_Size,Aspect No_Tagged_Streams,Implementation Defined Aspects
+@anchor{gnat_rm/implementation_defined_aspects aspect-no-task-parts}@anchor{13f}
+@section Aspect No_Task_Parts
+
+
+@geindex No_Task_Parts
+
+Applies to a type. If True, requires that the type and any descendants
+do not have any task parts. The rules for this aspect are the same as
+for the language-defined No_Controlled_Parts aspect (see RM-H.4.1),
+replacing “controlled” with “task”.
+
+If No_Task_Parts is True for a type T, then the compiler can optimize
+away certain tasking-related code that would otherwise be needed
+for T’Class, because descendants of T might contain tasks.
+
+@node Aspect Object_Size,Aspect Obsolescent,Aspect No_Task_Parts,Implementation Defined Aspects
+@anchor{gnat_rm/implementation_defined_aspects aspect-object-size}@anchor{140}
@section Aspect Object_Size
@geindex Object_Size
-This aspect is equivalent to @ref{143,,attribute Object_Size}.
+This aspect is equivalent to @ref{141,,attribute Object_Size}.
@node Aspect Obsolescent,Aspect Part_Of,Aspect Object_Size,Implementation Defined Aspects
-@anchor{gnat_rm/implementation_defined_aspects aspect-obsolescent}@anchor{144}
+@anchor{gnat_rm/implementation_defined_aspects aspect-obsolescent}@anchor{142}
@section Aspect Obsolescent
@@ -9720,25 +9855,25 @@ 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{145}
+@anchor{gnat_rm/implementation_defined_aspects aspect-part-of}@anchor{143}
@section Aspect Part_Of
@geindex Part_Of
-This aspect is equivalent to @ref{b4,,pragma Part_Of}.
+This aspect is equivalent to @ref{b3,,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{146}
+@anchor{gnat_rm/implementation_defined_aspects aspect-persistent-bss}@anchor{144}
@section Aspect Persistent_BSS
@geindex Persistent_BSS
-This boolean aspect is equivalent to @ref{b7,,pragma Persistent_BSS}.
+This boolean aspect is equivalent to @ref{b6,,pragma Persistent_BSS}.
@node Aspect Predicate,Aspect Pure_Function,Aspect Persistent_BSS,Implementation Defined Aspects
-@anchor{gnat_rm/implementation_defined_aspects aspect-predicate}@anchor{147}
+@anchor{gnat_rm/implementation_defined_aspects aspect-predicate}@anchor{145}
@section Aspect Predicate
@@ -9752,7 +9887,7 @@ 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{148}
+@anchor{gnat_rm/implementation_defined_aspects aspect-pure-function}@anchor{146}
@section Aspect Pure_Function
@@ -9761,7 +9896,7 @@ expression. It is also separately controllable using pragma
This boolean aspect is equivalent to @ref{ca,,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{149}
+@anchor{gnat_rm/implementation_defined_aspects aspect-refined-depends}@anchor{147}
@section Aspect Refined_Depends
@@ -9770,7 +9905,7 @@ This boolean aspect is equivalent to @ref{ca,,pragma Pure_Function}.
This aspect is equivalent to @ref{ce,,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{14a}
+@anchor{gnat_rm/implementation_defined_aspects aspect-refined-global}@anchor{148}
@section Aspect Refined_Global
@@ -9779,7 +9914,7 @@ This aspect is equivalent to @ref{ce,,pragma Refined_Depends}.
This aspect is equivalent to @ref{d0,,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{14b}
+@anchor{gnat_rm/implementation_defined_aspects aspect-refined-post}@anchor{149}
@section Aspect Refined_Post
@@ -9788,7 +9923,7 @@ This aspect is equivalent to @ref{d0,,pragma Refined_Global}.
This aspect is equivalent to @ref{d2,,pragma Refined_Post}.
@node Aspect Refined_State,Aspect Relaxed_Initialization,Aspect Refined_Post,Implementation Defined Aspects
-@anchor{gnat_rm/implementation_defined_aspects aspect-refined-state}@anchor{14c}
+@anchor{gnat_rm/implementation_defined_aspects aspect-refined-state}@anchor{14a}
@section Aspect Refined_State
@@ -9797,7 +9932,7 @@ This aspect is equivalent to @ref{d2,,pragma Refined_Post}.
This aspect is equivalent to @ref{d4,,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{14d}
+@anchor{gnat_rm/implementation_defined_aspects aspect-relaxed-initialization}@anchor{14b}
@section Aspect Relaxed_Initialization
@@ -9807,53 +9942,53 @@ 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{14e}
+@anchor{gnat_rm/implementation_defined_aspects aspect-remote-access-type}@anchor{14c}
@section Aspect Remote_Access_Type
@geindex Remote_Access_Type
-This aspect is equivalent to @ref{d8,,pragma Remote_Access_Type}.
+This aspect is equivalent to @ref{d7,,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{14f}
+@anchor{gnat_rm/implementation_defined_aspects aspect-secondary-stack-size}@anchor{14d}
@section Aspect Secondary_Stack_Size
@geindex Secondary_Stack_Size
-This aspect is equivalent to @ref{dd,,pragma Secondary_Stack_Size}.
+This aspect is equivalent to @ref{dc,,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{150}
+@anchor{gnat_rm/implementation_defined_aspects aspect-scalar-storage-order}@anchor{14e}
@section Aspect Scalar_Storage_Order
@geindex Scalar_Storage_Order
-This aspect is equivalent to a @ref{151,,attribute Scalar_Storage_Order}.
+This aspect is equivalent to a @ref{14f,,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{152}
+@anchor{gnat_rm/implementation_defined_aspects aspect-shared}@anchor{150}
@section Aspect Shared
@geindex Shared
-This boolean aspect is equivalent to @ref{e0,,pragma Shared}
+This boolean aspect is equivalent to @ref{df,,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{153}
+@anchor{gnat_rm/implementation_defined_aspects aspect-simple-storage-pool}@anchor{151}
@section Aspect Simple_Storage_Pool
@geindex Simple_Storage_Pool
-This aspect is equivalent to @ref{e5,,attribute Simple_Storage_Pool}.
+This aspect is equivalent to @ref{e4,,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{154}
+@anchor{gnat_rm/implementation_defined_aspects aspect-simple-storage-pool-type}@anchor{152}
@section Aspect Simple_Storage_Pool_Type
@@ -9862,7 +9997,7 @@ This aspect is equivalent to @ref{e5,,attribute Simple_Storage_Pool}.
This boolean aspect is equivalent to @ref{e3,,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{155}
+@anchor{gnat_rm/implementation_defined_aspects aspect-spark-mode}@anchor{153}
@section Aspect SPARK_Mode
@@ -9873,7 +10008,7 @@ 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{156}
+@anchor{gnat_rm/implementation_defined_aspects aspect-suppress-debug-info}@anchor{154}
@section Aspect Suppress_Debug_Info
@@ -9882,16 +10017,16 @@ of a subprogram or package.
This boolean aspect is equivalent to @ref{f3,,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{157}
+@anchor{gnat_rm/implementation_defined_aspects aspect-suppress-initialization}@anchor{155}
@section Aspect Suppress_Initialization
@geindex Suppress_Initialization
-This boolean aspect is equivalent to @ref{f7,,pragma Suppress_Initialization}.
+This boolean aspect is equivalent to @ref{f6,,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{158}
+@anchor{gnat_rm/implementation_defined_aspects aspect-test-case}@anchor{156}
@section Aspect Test_Case
@@ -9900,7 +10035,7 @@ This boolean aspect is equivalent to @ref{f7,,pragma Suppress_Initialization}.
This aspect is equivalent to @ref{fa,,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{159}
+@anchor{gnat_rm/implementation_defined_aspects aspect-thread-local-storage}@anchor{157}
@section Aspect Thread_Local_Storage
@@ -9908,8 +10043,8 @@ This aspect is equivalent to @ref{fa,,pragma Test_Case}.
This boolean aspect is equivalent to @ref{fc,,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{15a}
+@node Aspect Universal_Aliasing,Aspect Unmodified,Aspect Thread_Local_Storage,Implementation Defined Aspects
+@anchor{gnat_rm/implementation_defined_aspects aspect-universal-aliasing}@anchor{158}
@section Aspect Universal_Aliasing
@@ -9917,86 +10052,77 @@ This boolean aspect is equivalent to @ref{fc,,pragma Thread_Local_Storage}.
This boolean aspect is equivalent to @ref{106,,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{15b}
-@section Aspect Universal_Data
-
-
-@geindex Universal_Data
-
-This aspect is equivalent to @ref{108,,pragma Universal_Data}.
-
-@node Aspect Unmodified,Aspect Unreferenced,Aspect Universal_Data,Implementation Defined Aspects
-@anchor{gnat_rm/implementation_defined_aspects aspect-unmodified}@anchor{15c}
+@node Aspect Unmodified,Aspect Unreferenced,Aspect Universal_Aliasing,Implementation Defined Aspects
+@anchor{gnat_rm/implementation_defined_aspects aspect-unmodified}@anchor{159}
@section Aspect Unmodified
@geindex Unmodified
-This boolean aspect is equivalent to @ref{10b,,pragma Unmodified}.
+This boolean aspect is equivalent to @ref{108,,pragma Unmodified}.
@node Aspect Unreferenced,Aspect Unreferenced_Objects,Aspect Unmodified,Implementation Defined Aspects
-@anchor{gnat_rm/implementation_defined_aspects aspect-unreferenced}@anchor{15d}
+@anchor{gnat_rm/implementation_defined_aspects aspect-unreferenced}@anchor{15a}
@section Aspect Unreferenced
@geindex Unreferenced
-This boolean aspect is equivalent to @ref{10c,,pragma Unreferenced}.
+This boolean aspect is equivalent to @ref{10a,,pragma Unreferenced}.
-When using the @code{-gnat2020} switch, this aspect is also supported on formal
+When using the @code{-gnat2022} switch, this aspect is also supported on formal
parameters, which is in particular the only form possible for expression
functions.
@node Aspect Unreferenced_Objects,Aspect Value_Size,Aspect Unreferenced,Implementation Defined Aspects
-@anchor{gnat_rm/implementation_defined_aspects aspect-unreferenced-objects}@anchor{15e}
+@anchor{gnat_rm/implementation_defined_aspects aspect-unreferenced-objects}@anchor{15b}
@section Aspect Unreferenced_Objects
@geindex Unreferenced_Objects
-This boolean aspect is equivalent to @ref{10e,,pragma Unreferenced_Objects}.
+This boolean aspect is equivalent to @ref{10c,,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{15f}
+@anchor{gnat_rm/implementation_defined_aspects aspect-value-size}@anchor{15c}
@section Aspect Value_Size
@geindex Value_Size
-This aspect is equivalent to @ref{160,,attribute Value_Size}.
+This aspect is equivalent to @ref{15d,,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{161}
+@anchor{gnat_rm/implementation_defined_aspects aspect-volatile-full-access}@anchor{15e}
@section Aspect Volatile_Full_Access
@geindex Volatile_Full_Access
-This boolean aspect is equivalent to @ref{119,,pragma Volatile_Full_Access}.
+This boolean aspect is equivalent to @ref{116,,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{162}
+@anchor{gnat_rm/implementation_defined_aspects aspect-volatile-function}@anchor{15f}
@section Aspect Volatile_Function
@geindex Volatile_Function
-This boolean aspect is equivalent to @ref{11b,,pragma Volatile_Function}.
+This boolean aspect is equivalent to @ref{118,,pragma Volatile_Function}.
@node Aspect Warnings,,Aspect Volatile_Function,Implementation Defined Aspects
-@anchor{gnat_rm/implementation_defined_aspects aspect-warnings}@anchor{163}
+@anchor{gnat_rm/implementation_defined_aspects aspect-warnings}@anchor{160}
@section Aspect Warnings
@geindex Warnings
-This aspect is equivalent to the two argument form of @ref{11d,,pragma Warnings},
+This aspect is equivalent to the two argument form of @ref{11a,,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{164}@anchor{gnat_rm/implementation_defined_attributes implementation-defined-attributes}@anchor{8}@anchor{gnat_rm/implementation_defined_attributes id1}@anchor{165}
+@anchor{gnat_rm/implementation_defined_attributes doc}@anchor{161}@anchor{gnat_rm/implementation_defined_attributes id1}@anchor{162}@anchor{gnat_rm/implementation_defined_attributes implementation-defined-attributes}@anchor{8}
@chapter Implementation Defined Attributes
@@ -10093,6 +10219,7 @@ consideration, you should minimize the use of these attributes.
* Attribute Universal_Literal_String::
* Attribute Unrestricted_Access::
* Attribute Update::
+* Attribute Valid_Image::
* Attribute Valid_Scalars::
* Attribute VADS_Size::
* Attribute Value_Size::
@@ -10102,7 +10229,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{166}
+@anchor{gnat_rm/implementation_defined_attributes attribute-abort-signal}@anchor{163}
@section Attribute Abort_Signal
@@ -10116,7 +10243,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{167}
+@anchor{gnat_rm/implementation_defined_attributes attribute-address-size}@anchor{164}
@section Attribute Address_Size
@@ -10126,13 +10253,13 @@ intercept the abort exception).
@code{Standard'Address_Size} (@code{Standard} is the only allowed
prefix) is a static constant giving the number of bits in an
-@code{Address}. It is the same value as System.Address'Size,
+@code{Address}. It is the same value as System.Address’Size,
but has the advantage of being static, while a direct
-reference to System.Address'Size is nonstatic because Address
+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{168}
+@anchor{gnat_rm/implementation_defined_attributes attribute-asm-input}@anchor{165}
@section Attribute Asm_Input
@@ -10146,10 +10273,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{169,,Machine Code Insertions}
+@ref{166,,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{16a}
+@anchor{gnat_rm/implementation_defined_attributes attribute-asm-output}@anchor{167}
@section Attribute Asm_Output
@@ -10165,10 +10292,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{169,,Machine Code Insertions}
+@ref{166,,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{16b}
+@anchor{gnat_rm/implementation_defined_attributes attribute-atomic-always-lock-free}@anchor{168}
@section Attribute Atomic_Always_Lock_Free
@@ -10180,7 +10307,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{16c}
+@anchor{gnat_rm/implementation_defined_attributes attribute-bit}@anchor{169}
@section Attribute Bit
@@ -10211,7 +10338,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{16d}
+@anchor{gnat_rm/implementation_defined_attributes attribute-bit-position}@anchor{16a}
@section Attribute Bit_Position
@@ -10226,7 +10353,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{16e}
+@anchor{gnat_rm/implementation_defined_attributes attribute-code-address}@anchor{16b}
@section Attribute Code_Address
@@ -10269,7 +10396,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{16f}
+@anchor{gnat_rm/implementation_defined_attributes attribute-compiler-version}@anchor{16c}
@section Attribute Compiler_Version
@@ -10280,7 +10407,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{170}
+@anchor{gnat_rm/implementation_defined_attributes attribute-constrained}@anchor{16d}
@section Attribute Constrained
@@ -10295,7 +10422,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{171}
+@anchor{gnat_rm/implementation_defined_attributes attribute-default-bit-order}@anchor{16e}
@section Attribute Default_Bit_Order
@@ -10306,13 +10433,13 @@ compatible with older Ada compilers, including notably DEC Ada.
@geindex Default_Bit_Order
@code{Standard'Default_Bit_Order} (@code{Standard} is the only
-permissible prefix), provides the value @code{System.Default_Bit_Order}
+allowed prefix), provides the value @code{System.Default_Bit_Order}
as a @code{Pos} value (0 for @code{High_Order_First}, 1 for
@code{Low_Order_First}). This is used to construct the definition of
@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{172}
+@anchor{gnat_rm/implementation_defined_attributes attribute-default-scalar-storage-order}@anchor{16f}
@section Attribute Default_Scalar_Storage_Order
@@ -10323,13 +10450,13 @@ as a @code{Pos} value (0 for @code{High_Order_First}, 1 for
@geindex Default_Scalar_Storage_Order
@code{Standard'Default_Scalar_Storage_Order} (@code{Standard} is the only
-permissible prefix), provides the current value of the default scalar storage
+allowed prefix), provides the current value of the default scalar storage
order (as specified using pragma @code{Default_Scalar_Storage_Order}, or
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{173}
+@anchor{gnat_rm/implementation_defined_attributes attribute-deref}@anchor{170}
@section Attribute Deref
@@ -10342,7 +10469,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{174}
+@anchor{gnat_rm/implementation_defined_attributes attribute-descriptor-size}@anchor{171}
@section Attribute Descriptor_Size
@@ -10371,7 +10498,7 @@ since @code{Positive} has an alignment of 4, the size of the descriptor is
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{175}
+@anchor{gnat_rm/implementation_defined_attributes attribute-elaborated}@anchor{172}
@section Attribute Elaborated
@@ -10386,7 +10513,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{176}
+@anchor{gnat_rm/implementation_defined_attributes attribute-elab-body}@anchor{173}
@section Attribute Elab_Body
@@ -10402,7 +10529,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{177}
+@anchor{gnat_rm/implementation_defined_attributes attribute-elab-spec}@anchor{174}
@section Attribute Elab_Spec
@@ -10418,7 +10545,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{178}
+@anchor{gnat_rm/implementation_defined_attributes attribute-elab-subp-body}@anchor{175}
@section Attribute Elab_Subp_Body
@@ -10432,7 +10559,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{179}
+@anchor{gnat_rm/implementation_defined_attributes attribute-emax}@anchor{176}
@section Attribute Emax
@@ -10445,7 +10572,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{17a}
+@anchor{gnat_rm/implementation_defined_attributes attribute-enabled}@anchor{177}
@section Attribute Enabled
@@ -10469,7 +10596,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{17b}
+@anchor{gnat_rm/implementation_defined_attributes attribute-enum-rep}@anchor{178}
@section Attribute Enum_Rep
@@ -10509,7 +10636,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{17c}
+@anchor{gnat_rm/implementation_defined_attributes attribute-enum-val}@anchor{179}
@section Attribute Enum_Val
@@ -10535,7 +10662,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{17d}
+@anchor{gnat_rm/implementation_defined_attributes attribute-epsilon}@anchor{17a}
@section Attribute Epsilon
@@ -10548,7 +10675,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{17e}
+@anchor{gnat_rm/implementation_defined_attributes attribute-fast-math}@anchor{17b}
@section Attribute Fast_Math
@@ -10559,7 +10686,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{17f}
+@anchor{gnat_rm/implementation_defined_attributes attribute-finalization-size}@anchor{17c}
@section Attribute Finalization_Size
@@ -10577,7 +10704,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{180}
+@anchor{gnat_rm/implementation_defined_attributes attribute-fixed-value}@anchor{17d}
@section Attribute Fixed_Value
@@ -10604,7 +10731,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{181}
+@anchor{gnat_rm/implementation_defined_attributes attribute-from-any}@anchor{17e}
@section Attribute From_Any
@@ -10614,7 +10741,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{182}
+@anchor{gnat_rm/implementation_defined_attributes attribute-has-access-values}@anchor{17f}
@section Attribute Has_Access_Values
@@ -10632,7 +10759,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 Has_Tagged_Values,Attribute Has_Access_Values,Implementation Defined Attributes
-@anchor{gnat_rm/implementation_defined_attributes attribute-has-discriminants}@anchor{183}
+@anchor{gnat_rm/implementation_defined_attributes attribute-has-discriminants}@anchor{180}
@section Attribute Has_Discriminants
@@ -10648,7 +10775,7 @@ definitions. If the attribute is applied to a generic private type, it
indicates whether or not the corresponding actual type has discriminants.
@node Attribute Has_Tagged_Values,Attribute Img,Attribute Has_Discriminants,Implementation Defined Attributes
-@anchor{gnat_rm/implementation_defined_attributes attribute-has-tagged-values}@anchor{184}
+@anchor{gnat_rm/implementation_defined_attributes attribute-has-tagged-values}@anchor{181}
@section Attribute Has_Tagged_Values
@@ -10665,7 +10792,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 Img,Attribute Initialized,Attribute Has_Tagged_Values,Implementation Defined Attributes
-@anchor{gnat_rm/implementation_defined_attributes attribute-img}@anchor{185}
+@anchor{gnat_rm/implementation_defined_attributes attribute-img}@anchor{182}
@section Attribute Img
@@ -10695,7 +10822,7 @@ that returns the appropriate string when called. This means that
in an instantiation as a function parameter.
@node Attribute Initialized,Attribute Integer_Value,Attribute Img,Implementation Defined Attributes
-@anchor{gnat_rm/implementation_defined_attributes attribute-initialized}@anchor{186}
+@anchor{gnat_rm/implementation_defined_attributes attribute-initialized}@anchor{183}
@section Attribute Initialized
@@ -10705,7 +10832,7 @@ 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}
+@anchor{gnat_rm/implementation_defined_attributes attribute-integer-value}@anchor{184}
@section Attribute Integer_Value
@@ -10733,13 +10860,13 @@ 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{188}
+@anchor{gnat_rm/implementation_defined_attributes attribute-invalid-value}@anchor{185}
@section Attribute Invalid_Value
@geindex Invalid_Value
-For every scalar type S, S'Invalid_Value returns an undefined value of the
+For every scalar type S, S’Invalid_Value returns an undefined value of the
type. If possible this value is an invalid representation for the type. The
value returned is identical to the value used to initialize an otherwise
uninitialized value of the type if pragma Initialize_Scalars is used,
@@ -10747,7 +10874,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{189}
+@anchor{gnat_rm/implementation_defined_attributes attribute-iterable}@anchor{186}
@section Attribute Iterable
@@ -10756,7 +10883,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{18a}
+@anchor{gnat_rm/implementation_defined_attributes attribute-large}@anchor{187}
@section Attribute Large
@@ -10769,7 +10896,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{18b}
+@anchor{gnat_rm/implementation_defined_attributes attribute-library-level}@anchor{188}
@section Attribute Library_Level
@@ -10795,7 +10922,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{18c}
+@anchor{gnat_rm/implementation_defined_attributes attribute-lock-free}@anchor{189}
@section Attribute Lock_Free
@@ -10805,7 +10932,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{18d}
+@anchor{gnat_rm/implementation_defined_attributes attribute-loop-entry}@anchor{18a}
@section Attribute Loop_Entry
@@ -10835,7 +10962,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{18e}
+@anchor{gnat_rm/implementation_defined_attributes attribute-machine-size}@anchor{18b}
@section Attribute Machine_Size
@@ -10845,7 +10972,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{18f}
+@anchor{gnat_rm/implementation_defined_attributes attribute-mantissa}@anchor{18c}
@section Attribute Mantissa
@@ -10858,7 +10985,7 @@ the Ada 83 reference manual for an exact description of the semantics of
this attribute.
@node Attribute Maximum_Alignment,Attribute Max_Integer_Size,Attribute Mantissa,Implementation Defined Attributes
-@anchor{gnat_rm/implementation_defined_attributes attribute-maximum-alignment}@anchor{190}@anchor{gnat_rm/implementation_defined_attributes id2}@anchor{191}
+@anchor{gnat_rm/implementation_defined_attributes attribute-maximum-alignment}@anchor{18d}@anchor{gnat_rm/implementation_defined_attributes id2}@anchor{18e}
@section Attribute Maximum_Alignment
@@ -10868,24 +10995,24 @@ this attribute.
@geindex Maximum_Alignment
@code{Standard'Maximum_Alignment} (@code{Standard} is the only
-permissible prefix) provides the maximum useful alignment value for the
+allowed prefix) provides the maximum useful alignment value for the
target. This is a static value that can be used to specify the alignment
for an object, guaranteeing that it is properly aligned in all
cases.
@node Attribute Max_Integer_Size,Attribute Mechanism_Code,Attribute Maximum_Alignment,Implementation Defined Attributes
-@anchor{gnat_rm/implementation_defined_attributes attribute-max-integer-size}@anchor{192}
+@anchor{gnat_rm/implementation_defined_attributes attribute-max-integer-size}@anchor{18f}
@section Attribute Max_Integer_Size
@geindex Max_Integer_Size
-@code{Standard'Max_Integer_Size} (@code{Standard} is the only permissible
+@code{Standard'Max_Integer_Size} (@code{Standard} is the only allowed
prefix) provides the size of the largest supported integer type for
the target. The result is a static constant.
@node Attribute Mechanism_Code,Attribute Null_Parameter,Attribute Max_Integer_Size,Implementation Defined Attributes
-@anchor{gnat_rm/implementation_defined_attributes attribute-mechanism-code}@anchor{193}
+@anchor{gnat_rm/implementation_defined_attributes attribute-mechanism-code}@anchor{190}
@section Attribute Mechanism_Code
@@ -10916,7 +11043,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{191}
@section Attribute Null_Parameter
@@ -10941,7 +11068,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{143}@anchor{gnat_rm/implementation_defined_attributes id3}@anchor{195}
+@anchor{gnat_rm/implementation_defined_attributes attribute-object-size}@anchor{141}@anchor{gnat_rm/implementation_defined_attributes id3}@anchor{192}
@section Attribute Object_Size
@@ -11011,7 +11138,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{193}
@section Attribute Old
@@ -11026,7 +11153,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{194}
@section Attribute Passed_By_Reference
@@ -11042,7 +11169,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{195}
@section Attribute Pool_Address
@@ -11056,7 +11183,7 @@ bounds are allocated just before the first component,
whereas @code{X'Address} returns the address of the first
component.
-Here, we are interpreting 'storage pool' broadly to mean
+Here, we are interpreting ‘storage pool’ broadly to mean
@code{wherever the object is allocated}, which could be a
user-defined storage pool,
the global heap, on the stack, or in a static memory area.
@@ -11064,7 +11191,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{196}
@section Attribute Range_Length
@@ -11077,7 +11204,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{197}
@section Attribute Restriction_Set
@@ -11088,7 +11215,7 @@ same result as @code{Length} applied to the array itself.
This attribute allows compile time testing of restrictions that
are currently in effect. It is primarily intended for specializing
code in the run-time based on restrictions that are active (e.g.
-don't need to save fpt registers if restriction No_Floating_Point
+don’t need to save fpt registers if restriction No_Floating_Point
is known to be in effect), but can be used anywhere.
There are two forms:
@@ -11147,7 +11274,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{198}
@section Attribute Result
@@ -11160,7 +11287,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{199}
@section Attribute Safe_Emax
@@ -11173,7 +11300,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{19a}
@section Attribute Safe_Large
@@ -11186,7 +11313,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{19b}
@section Attribute Safe_Small
@@ -11199,7 +11326,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{151}
+@anchor{gnat_rm/implementation_defined_attributes attribute-scalar-storage-order}@anchor{14f}@anchor{gnat_rm/implementation_defined_attributes id4}@anchor{19c}
@section Attribute Scalar_Storage_Order
@@ -11253,7 +11380,7 @@ defined by Ada RM 13.5.3(4). The default is @code{System.Default_Bit_Order}.
For a record type @code{T}, if @code{T'Scalar_Storage_Order} is
specified explicitly, it shall be equal to @code{T'Bit_Order}. Note:
this means that if a @code{Scalar_Storage_Order} attribute definition
-clause is not confirming, then the type's @code{Bit_Order} shall be
+clause is not confirming, then the type’s @code{Bit_Order} shall be
specified explicitly and set to the same value.
Derived types inherit an explicitly set scalar storage order from their parent
@@ -11314,6 +11441,46 @@ If a component of @code{T} is itself of a record or array type, the specfied
attribute definition clause must be provided for the component type as well
if desired.
+Representation changes that explicitly or implicitly toggle the scalar storage
+order are not supported and may result in erroneous execution of the program,
+except when performed by means of an instance of @code{Ada.Unchecked_Conversion}.
+
+In particular, overlays are not supported and a warning is given for them:
+
+@example
+type Rec_LE is record
+ I : Integer;
+end record;
+
+for Rec_LE use record
+ I at 0 range 0 .. 31;
+end record;
+
+for Rec_LE'Bit_Order use System.Low_Order_First;
+for Rec_LE'Scalar_Storage_Order use System.Low_Order_First;
+
+type Rec_BE is record
+ I : Integer;
+end record;
+
+for Rec_BE use record
+ I at 0 range 0 .. 31;
+end record;
+
+for Rec_BE'Bit_Order use System.High_Order_First;
+for Rec_BE'Scalar_Storage_Order use System.High_Order_First;
+
+R_LE : Rec_LE;
+
+R_BE : Rec_BE;
+for R_BE'Address use R_LE'Address;
+@end example
+
+@code{warning: overlay changes scalar storage order [enabled by default]}
+
+In most cases, such representation changes ought to be replaced by an
+instantiation of a function or procedure provided by @code{GNAT.Byte_Swapping}.
+
Note that the scalar storage order only affects the in-memory data
representation. It has no effect on the representation used by stream
attributes.
@@ -11322,7 +11489,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{e5}@anchor{gnat_rm/implementation_defined_attributes id5}@anchor{1a0}
+@anchor{gnat_rm/implementation_defined_attributes attribute-simple-storage-pool}@anchor{e4}@anchor{gnat_rm/implementation_defined_attributes id5}@anchor{19d}
@section Attribute Simple_Storage_Pool
@@ -11347,7 +11514,7 @@ for Acc'Simple_Storage_Pool use My_Pool;
The name given in an attribute_definition_clause for the
@code{Simple_Storage_Pool} attribute shall denote a variable of
-a 'simple storage pool type' (see pragma @cite{Simple_Storage_Pool_Type}).
+a ‘simple storage pool type’ (see pragma @cite{Simple_Storage_Pool_Type}).
The use of this attribute is only allowed for a prefix denoting a type
for which it has been specified. The type of the attribute is the type
@@ -11385,7 +11552,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 Small_Denominator,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{19e}
@section Attribute Small
@@ -11401,7 +11568,7 @@ the Ada 83 reference manual for an exact description of the semantics of
this attribute when applied to floating-point types.
@node Attribute Small_Denominator,Attribute Small_Numerator,Attribute Small,Implementation Defined Attributes
-@anchor{gnat_rm/implementation_defined_attributes attribute-small-denominator}@anchor{1a2}
+@anchor{gnat_rm/implementation_defined_attributes attribute-small-denominator}@anchor{19f}
@section Attribute Small_Denominator
@@ -11414,7 +11581,7 @@ denominator in the representation of @code{typ'Small} as a rational number
with coprime factors (i.e. as an irreducible fraction).
@node Attribute Small_Numerator,Attribute Storage_Unit,Attribute Small_Denominator,Implementation Defined Attributes
-@anchor{gnat_rm/implementation_defined_attributes attribute-small-numerator}@anchor{1a3}
+@anchor{gnat_rm/implementation_defined_attributes attribute-small-numerator}@anchor{1a0}
@section Attribute Small_Numerator
@@ -11427,17 +11594,17 @@ numerator in the representation of @code{typ'Small} as a rational number
with coprime factors (i.e. as an irreducible fraction).
@node Attribute Storage_Unit,Attribute Stub_Type,Attribute Small_Numerator,Implementation Defined Attributes
-@anchor{gnat_rm/implementation_defined_attributes attribute-storage-unit}@anchor{1a4}
+@anchor{gnat_rm/implementation_defined_attributes attribute-storage-unit}@anchor{1a1}
@section Attribute Storage_Unit
@geindex Storage_Unit
-@code{Standard'Storage_Unit} (@code{Standard} is the only permissible
+@code{Standard'Storage_Unit} (@code{Standard} is the only allowed
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{1a5}
+@anchor{gnat_rm/implementation_defined_attributes attribute-stub-type}@anchor{1a2}
@section Attribute Stub_Type
@@ -11446,7 +11613,7 @@ prefix) provides the same value as @code{System.Storage_Unit}.
The GNAT implementation of remote access-to-classwide types is
organized as described in AARM section E.4 (20.t): a value of an RACW type
(designating a remote object) is represented as a normal access
-value, pointing to a "stub" object which in turn contains the
+value, pointing to a “stub” object which in turn contains the
necessary information to contact the designated remote object. A
call on any dispatching operation of such a stub object does the
remote call, if necessary, using the information in the stub object
@@ -11461,7 +11628,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{1a6}
+@anchor{gnat_rm/implementation_defined_attributes attribute-system-allocator-alignment}@anchor{1a3}
@section Attribute System_Allocator_Alignment
@@ -11471,34 +11638,34 @@ an implicit dependency on this unit.
@geindex System_Allocator_Alignment
@code{Standard'System_Allocator_Alignment} (@code{Standard} is the only
-permissible prefix) provides the observable guaranted to be honored by
+allowed prefix) provides the observable guaranted to be honored by
the system allocator (malloc). This is a static value that can be used
in user storage pools based on malloc either to reject allocation
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{1a7}
+@anchor{gnat_rm/implementation_defined_attributes attribute-target-name}@anchor{1a4}
@section Attribute Target_Name
@geindex Target_Name
-@code{Standard'Target_Name} (@code{Standard} is the only permissible
+@code{Standard'Target_Name} (@code{Standard} is the only allowed
prefix) provides a static string value that identifies the target
for the current compilation. For GCC implementations, this is the
standard gcc target name without the terminating slash (for
-example, GNAT 5.0 on windows yields "i586-pc-mingw32msv").
+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{1a8}
+@anchor{gnat_rm/implementation_defined_attributes attribute-to-address}@anchor{1a5}
@section Attribute To_Address
@geindex To_Address
The @code{System'To_Address}
-(@code{System} is the only permissible prefix)
+(@code{System} is the only allowed prefix)
denotes a function identical to
@code{System.Storage_Elements.To_Address} except that
it is a static attribute. This means that if its argument is
@@ -11514,7 +11681,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{1a9}
+@anchor{gnat_rm/implementation_defined_attributes attribute-to-any}@anchor{1a6}
@section Attribute To_Any
@@ -11524,7 +11691,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{1aa}
+@anchor{gnat_rm/implementation_defined_attributes attribute-type-class}@anchor{1a7}
@section Attribute Type_Class
@@ -11554,7 +11721,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{1ab}
+@anchor{gnat_rm/implementation_defined_attributes attribute-type-key}@anchor{1a8}
@section Attribute Type_Key
@@ -11566,7 +11733,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{1ac}
+@anchor{gnat_rm/implementation_defined_attributes attribute-typecode}@anchor{1a9}
@section Attribute TypeCode
@@ -11576,7 +11743,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{1ad}
+@anchor{gnat_rm/implementation_defined_attributes attribute-unconstrained-array}@anchor{1aa}
@section Attribute Unconstrained_Array
@@ -11590,7 +11757,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{1ae}
+@anchor{gnat_rm/implementation_defined_attributes attribute-universal-literal-string}@anchor{1ab}
@section Attribute Universal_Literal_String
@@ -11618,7 +11785,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{1af}
+@anchor{gnat_rm/implementation_defined_attributes attribute-unrestricted-access}@anchor{1ac}
@section Attribute Unrestricted_Access
@@ -11682,9 +11849,9 @@ For instance, if a function uses @code{Unrestricted_Access} to create
an access-to-unconstrained-array and returns that value to the caller,
the result will involve dangling pointers. In addition, it is only
valid to create pointers to unconstrained arrays using this attribute
-if the pointer has the normal default 'fat' representation where a
+if the pointer has the normal default ‘fat’ representation where a
pointer has two components, one points to the array and one points to
-the bounds. If a size clause is used to force 'thin' representation
+the bounds. If a size clause is used to force ‘thin’ representation
for a pointer to unconstrained where there is only space for a single
pointer, then the resulting pointer is not usable.
@@ -11800,12 +11967,12 @@ begin
end;
@end example
-In general this is a risky approach. It may appear to "work" but such uses of
+In general this is a risky approach. It may appear to “work” but such uses of
@code{Unrestricted_Access} are potentially non-portable, even from one version
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{1b0}
+@node Attribute Update,Attribute Valid_Image,Attribute Unrestricted_Access,Implementation Defined Attributes
+@anchor{gnat_rm/implementation_defined_attributes attribute-update}@anchor{1ad}
@section Attribute Update
@@ -11885,8 +12052,20 @@ 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{1b1}
+@node Attribute Valid_Image,Attribute Valid_Scalars,Attribute Update,Implementation Defined Attributes
+@anchor{gnat_rm/implementation_defined_attributes attribute-valid-image}@anchor{1ae}
+@section Attribute Valid_Image
+
+
+@geindex Valid_Image
+
+The @code{'Valid_Image} attribute is defined for enumeration types other than
+those in package Standard. This attribute is a function that takes
+a String, and returns Boolean. @code{T'Valid_Image (S)} returns True
+if and only if @code{T'Value (S)} would not raise Constraint_Error.
+
+@node Attribute Valid_Scalars,Attribute VADS_Size,Attribute Valid_Image,Implementation Defined Attributes
+@anchor{gnat_rm/implementation_defined_attributes attribute-valid-scalars}@anchor{1af}
@section Attribute Valid_Scalars
@@ -11920,7 +12099,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{1b2}
+@anchor{gnat_rm/implementation_defined_attributes attribute-vads-size}@anchor{1b0}
@section Attribute VADS_Size
@@ -11940,7 +12119,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{1b3}@anchor{gnat_rm/implementation_defined_attributes attribute-value-size}@anchor{160}
+@anchor{gnat_rm/implementation_defined_attributes attribute-value-size}@anchor{15d}@anchor{gnat_rm/implementation_defined_attributes id6}@anchor{1b1}
@section Attribute Value_Size
@@ -11954,30 +12133,30 @@ 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{1b4}
+@anchor{gnat_rm/implementation_defined_attributes attribute-wchar-t-size}@anchor{1b2}
@section Attribute Wchar_T_Size
@geindex Wchar_T_Size
-@code{Standard'Wchar_T_Size} (@code{Standard} is the only permissible
+@code{Standard'Wchar_T_Size} (@code{Standard} is the only allowed
prefix) provides the size in bits of the C @code{wchar_t} type
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{1b5}
+@anchor{gnat_rm/implementation_defined_attributes attribute-word-size}@anchor{1b3}
@section Attribute Word_Size
@geindex Word_Size
-@code{Standard'Word_Size} (@code{Standard} is the only permissible
+@code{Standard'Word_Size} (@code{Standard} is the only allowed
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{1b6}@anchor{gnat_rm/standard_and_implementation_defined_restrictions id1}@anchor{1b7}
+@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}
@chapter Standard and Implementation Defined Restrictions
@@ -12006,7 +12185,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{1b8}@anchor{gnat_rm/standard_and_implementation_defined_restrictions id2}@anchor{1b9}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions id2}@anchor{1b6}@anchor{gnat_rm/standard_and_implementation_defined_restrictions partition-wide-restrictions}@anchor{1b7}
@section Partition-Wide Restrictions
@@ -12095,7 +12274,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{1ba}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions immediate-reclamation}@anchor{1b8}
@subsection Immediate_Reclamation
@@ -12107,7 +12286,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{1bb}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions max-asynchronous-select-nesting}@anchor{1b9}
@subsection Max_Asynchronous_Select_Nesting
@@ -12119,7 +12298,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{1bc}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions max-entry-queue-length}@anchor{1ba}
@subsection Max_Entry_Queue_Length
@@ -12140,7 +12319,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{1bd}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions max-protected-entries}@anchor{1bb}
@subsection Max_Protected_Entries
@@ -12151,7 +12330,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{1be}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions max-select-alternatives}@anchor{1bc}
@subsection Max_Select_Alternatives
@@ -12160,18 +12339,18 @@ 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{1bf}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions max-storage-at-blocking}@anchor{1bd}
@subsection Max_Storage_At_Blocking
@geindex Max_Storage_At_Blocking
-[RM D.7] Specifies the maximum portion (in storage elements) of a task's
+[RM D.7] Specifies the maximum portion (in storage elements) of a task’s
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{1c0}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions max-task-entries}@anchor{1be}
@subsection Max_Task_Entries
@@ -12184,7 +12363,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{1c1}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions max-tasks}@anchor{1bf}
@subsection Max_Tasks
@@ -12197,7 +12376,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{1c2}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-abort-statements}@anchor{1c0}
@subsection No_Abort_Statements
@@ -12207,7 +12386,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{1c3}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-access-parameter-allocators}@anchor{1c1}
@subsection No_Access_Parameter_Allocators
@@ -12218,7 +12397,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{1c4}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-access-subprograms}@anchor{1c2}
@subsection No_Access_Subprograms
@@ -12228,7 +12407,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{1c5}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-allocators}@anchor{1c3}
@subsection No_Allocators
@@ -12238,7 +12417,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{1c6}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-anonymous-allocators}@anchor{1c4}
@subsection No_Anonymous_Allocators
@@ -12248,7 +12427,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{1c7}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-asynchronous-control}@anchor{1c5}
@subsection No_Asynchronous_Control
@@ -12258,7 +12437,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{1c8}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-calendar}@anchor{1c6}
@subsection No_Calendar
@@ -12268,7 +12447,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{1c9}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-coextensions}@anchor{1c7}
@subsection No_Coextensions
@@ -12278,7 +12457,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{1ca}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-default-initialization}@anchor{1c8}
@subsection No_Default_Initialization
@@ -12286,7 +12465,7 @@ coextensions. See 3.10.2.
[GNAT] This restriction prohibits any instance of default initialization
of variables. The binder implements a consistency rule which prevents
-any unit compiled without the restriction from with'ing a unit with the
+any unit compiled without the restriction from with’ing a unit with the
restriction (this allows the generation of initialization procedures to
be skipped, since you can be sure that no call is ever generated to an
initialization procedure in a unit with the restriction active). If used
@@ -12295,7 +12474,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{1cb}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-delay}@anchor{1c9}
@subsection No_Delay
@@ -12305,7 +12484,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{1cc}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-dependence}@anchor{1ca}
@subsection No_Dependence
@@ -12315,7 +12494,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{1cd}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-direct-boolean-operators}@anchor{1cb}
@subsection No_Direct_Boolean_Operators
@@ -12328,7 +12507,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{1ce}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-dispatch}@anchor{1cc}
@subsection No_Dispatch
@@ -12338,7 +12517,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{1cf}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-dispatching-calls}@anchor{1cd}
@subsection No_Dispatching_Calls
@@ -12399,7 +12578,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{1d0}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-dynamic-attachment}@anchor{1ce}
@subsection No_Dynamic_Attachment
@@ -12418,7 +12597,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{1d1}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-dynamic-priorities}@anchor{1cf}
@subsection No_Dynamic_Priorities
@@ -12427,7 +12606,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{1d2}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-entry-calls-in-elaboration-code}@anchor{1d0}
@subsection No_Entry_Calls_In_Elaboration_Code
@@ -12439,7 +12618,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{1d3}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-enumeration-maps}@anchor{1d1}
@subsection No_Enumeration_Maps
@@ -12450,7 +12629,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{1d4}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-exception-handlers}@anchor{1d2}
@subsection No_Exception_Handlers
@@ -12475,7 +12654,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{1d5}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-exception-propagation}@anchor{1d3}
@subsection No_Exception_Propagation
@@ -12492,7 +12671,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{1d6}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-exception-registration}@anchor{1d4}
@subsection No_Exception_Registration
@@ -12506,7 +12685,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{1d7}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-exceptions}@anchor{1d5}
@subsection No_Exceptions
@@ -12517,7 +12696,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{1d8}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-finalization}@anchor{1d6}
@subsection No_Finalization
@@ -12558,7 +12737,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{1d9}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-fixed-point}@anchor{1d7}
@subsection No_Fixed_Point
@@ -12568,7 +12747,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{1da}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-floating-point}@anchor{1d8}
@subsection No_Floating_Point
@@ -12578,7 +12757,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{1db}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-implicit-conditionals}@anchor{1d9}
@subsection No_Implicit_Conditionals
@@ -12594,7 +12773,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{1dc}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-implicit-dynamic-code}@anchor{1da}
@subsection No_Implicit_Dynamic_Code
@@ -12602,7 +12781,7 @@ of composite objects and the Max/Min attributes.
@geindex trampoline
-[GNAT] This restriction prevents the compiler from building 'trampolines'.
+[GNAT] This restriction prevents the compiler from building ‘trampolines’.
This is a structure that is built on the stack and contains dynamic
code to be executed at run time. On some targets, a trampoline is
built for the following features: @code{Access},
@@ -12614,7 +12793,7 @@ protection) will cause trampolines to raise an exception.
Trampolines are also quite slow at run time.
On many targets, trampolines have been largely eliminated. Look at the
-version of system.ads for your target --- if it has
+version of system.ads for your target — if it has
Always_Compatible_Rep equal to False, then trampolines are largely
eliminated. In particular, a trampoline is built for the following
features: @code{Address} of a nested subprogram;
@@ -12624,7 +12803,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{1dd}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-implicit-heap-allocations}@anchor{1db}
@subsection No_Implicit_Heap_Allocations
@@ -12633,7 +12812,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{1de}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-implicit-protected-object-allocations}@anchor{1dc}
@subsection No_Implicit_Protected_Object_Allocations
@@ -12643,7 +12822,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{1df}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-implicit-task-allocations}@anchor{1dd}
@subsection No_Implicit_Task_Allocations
@@ -12652,7 +12831,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{1e0}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-initialize-scalars}@anchor{1de}
@subsection No_Initialize_Scalars
@@ -12664,7 +12843,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{1e1}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-io}@anchor{1df}
@subsection No_IO
@@ -12675,7 +12854,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{1e2}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-local-allocators}@anchor{1e0}
@subsection No_Local_Allocators
@@ -12686,7 +12865,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{1e3}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-local-protected-objects}@anchor{1e1}
@subsection No_Local_Protected_Objects
@@ -12696,7 +12875,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{1e4}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-local-timing-events}@anchor{1e2}
@subsection No_Local_Timing_Events
@@ -12706,7 +12885,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{1e5}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-long-long-integers}@anchor{1e3}
@subsection No_Long_Long_Integers
@@ -12715,10 +12894,10 @@ declared at the library level.
[GNAT] This partition-wide restriction forbids any explicit reference to
type Standard.Long_Long_Integer, and also forbids declaring range types whose
implicit base type is Long_Long_Integer, and modular types whose size exceeds
-Long_Integer'Size.
+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{1e6}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-multiple-elaboration}@anchor{1e4}
@subsection No_Multiple_Elaboration
@@ -12734,7 +12913,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{1e7}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-nested-finalization}@anchor{1e5}
@subsection No_Nested_Finalization
@@ -12743,7 +12922,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{1e8}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-protected-type-allocators}@anchor{1e6}
@subsection No_Protected_Type_Allocators
@@ -12753,7 +12932,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{1e9}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-protected-types}@anchor{1e7}
@subsection No_Protected_Types
@@ -12763,7 +12942,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{1ea}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-recursion}@anchor{1e8}
@subsection No_Recursion
@@ -12773,7 +12952,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{1eb}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-reentrancy}@anchor{1e9}
@subsection No_Reentrancy
@@ -12783,7 +12962,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{1ec}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-relative-delay}@anchor{1ea}
@subsection No_Relative_Delay
@@ -12794,7 +12973,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{1ed}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-requeue-statements}@anchor{1eb}
@subsection No_Requeue_Statements
@@ -12812,7 +12991,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{1ee}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-secondary-stack}@anchor{1ec}
@subsection No_Secondary_Stack
@@ -12825,7 +13004,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{1ef}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-select-statements}@anchor{1ed}
@subsection No_Select_Statements
@@ -12835,7 +13014,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{1f0}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-specific-termination-handlers}@anchor{1ee}
@subsection No_Specific_Termination_Handlers
@@ -12845,7 +13024,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{1f1}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-specification-of-aspect}@anchor{1ef}
@subsection No_Specification_of_Aspect
@@ -12856,7 +13035,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{1f2}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-standard-allocators-after-elaboration}@anchor{1f0}
@subsection No_Standard_Allocators_After_Elaboration
@@ -12868,7 +13047,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{1f3}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-standard-storage-pools}@anchor{1f1}
@subsection No_Standard_Storage_Pools
@@ -12880,7 +13059,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{1f4}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-stream-optimizations}@anchor{1f2}
@subsection No_Stream_Optimizations
@@ -12893,7 +13072,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{1f5}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-streams}@anchor{1f3}
@subsection No_Streams
@@ -12914,7 +13093,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{1f6}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-task-allocators}@anchor{1f4}
@subsection No_Task_Allocators
@@ -12924,7 +13103,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{1f7}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-task-at-interrupt-priority}@anchor{1f5}
@subsection No_Task_At_Interrupt_Priority
@@ -12936,7 +13115,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{1f8}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-task-attributes-package}@anchor{1f6}
@subsection No_Task_Attributes_Package
@@ -12953,7 +13132,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{1f9}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-task-hierarchy}@anchor{1f7}
@subsection No_Task_Hierarchy
@@ -12963,7 +13142,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{1fa}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-task-termination}@anchor{1f8}
@subsection No_Task_Termination
@@ -12972,7 +13151,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{1fb}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-tasking}@anchor{1f9}
@subsection No_Tasking
@@ -12985,7 +13164,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{1fc}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-terminate-alternatives}@anchor{1fa}
@subsection No_Terminate_Alternatives
@@ -12994,7 +13173,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{1fd}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-unchecked-access}@anchor{1fb}
@subsection No_Unchecked_Access
@@ -13004,7 +13183,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{1fe}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-unchecked-conversion}@anchor{1fc}
@subsection No_Unchecked_Conversion
@@ -13014,7 +13193,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{1ff}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-unchecked-deallocation}@anchor{1fd}
@subsection No_Unchecked_Deallocation
@@ -13024,7 +13203,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{200}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-use-of-entity}@anchor{1fe}
@subsection No_Use_Of_Entity
@@ -13044,7 +13223,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{201}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions pure-barriers}@anchor{1ff}
@subsection Pure_Barriers
@@ -13081,7 +13260,7 @@ character literals,
implicitly defined comparison operators,
@item
-uses of the Standard."not" operator,
+uses of the Standard.”not” operator,
@item
short-circuit operator,
@@ -13095,7 +13274,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{202}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions simple-barriers}@anchor{200}
@subsection Simple_Barriers
@@ -13114,7 +13293,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{203}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions static-priorities}@anchor{201}
@subsection Static_Priorities
@@ -13125,7 +13304,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{204}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions static-storage-size}@anchor{202}
@subsection Static_Storage_Size
@@ -13135,7 +13314,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{205}@anchor{gnat_rm/standard_and_implementation_defined_restrictions id3}@anchor{206}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions id3}@anchor{203}@anchor{gnat_rm/standard_and_implementation_defined_restrictions program-unit-level-restrictions}@anchor{204}
@section Program Unit Level Restrictions
@@ -13165,7 +13344,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{207}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-elaboration-code}@anchor{205}
@subsection No_Elaboration_Code
@@ -13211,7 +13390,7 @@ is not possible to document the precise conditions under which the
optimizer can figure this out.
Note that this the implementation of this restriction requires full
-code generation. If it is used in conjunction with "semantics only"
+code generation. If it is used in conjunction with “semantics only”
checking, then some cases of violations may be missed.
When this restriction is active, we are not requesting control-flow
@@ -13221,7 +13400,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{208}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-dynamic-sized-objects}@anchor{206}
@subsection No_Dynamic_Sized_Objects
@@ -13239,7 +13418,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{209}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-entry-queue}@anchor{207}
@subsection No_Entry_Queue
@@ -13252,7 +13431,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{20a}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-implementation-aspect-specifications}@anchor{208}
@subsection No_Implementation_Aspect_Specifications
@@ -13263,7 +13442,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{20b}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-implementation-attributes}@anchor{209}
@subsection No_Implementation_Attributes
@@ -13275,7 +13454,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{20c}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-implementation-identifiers}@anchor{20a}
@subsection No_Implementation_Identifiers
@@ -13286,7 +13465,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{20d}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-implementation-pragmas}@anchor{20b}
@subsection No_Implementation_Pragmas
@@ -13297,7 +13476,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{20e}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-implementation-restrictions}@anchor{20c}
@subsection No_Implementation_Restrictions
@@ -13309,7 +13488,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{20f}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-implementation-units}@anchor{20d}
@subsection No_Implementation_Units
@@ -13320,22 +13499,22 @@ 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{210}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-implicit-aliasing}@anchor{20e}
@subsection No_Implicit_Aliasing
@geindex No_Implicit_Aliasing
[GNAT] This restriction, which is not required to be partition-wide consistent,
-requires an explicit aliased keyword for an object to which 'Access,
-'Unchecked_Access, or 'Address is applied, and forbids entirely the use of
-the 'Unrestricted_Access attribute for objects. Note: the reason that
+requires an explicit aliased keyword for an object to which ‘Access,
+‘Unchecked_Access, or ‘Address is applied, and forbids entirely the use of
+the ‘Unrestricted_Access attribute for objects. Note: the reason that
Unrestricted_Access is forbidden is that it would require the prefix
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{211}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-implicit-loops}@anchor{20f}
@subsection No_Implicit_Loops
@@ -13352,7 +13531,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{212}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-obsolescent-features}@anchor{210}
@subsection No_Obsolescent_Features
@@ -13362,7 +13541,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{213}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-wide-characters}@anchor{211}
@subsection No_Wide_Characters
@@ -13376,7 +13555,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{214}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions static-dispatch-tables}@anchor{212}
@subsection Static_Dispatch_Tables
@@ -13386,7 +13565,7 @@ 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{215}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions spark-05}@anchor{213}
@subsection SPARK_05
@@ -13409,7 +13588,7 @@ gnatprove -P project.gpr --mode=check_all
@end example
@node Implementation Advice,Implementation Defined Characteristics,Standard and Implementation Defined Restrictions,Top
-@anchor{gnat_rm/implementation_advice doc}@anchor{216}@anchor{gnat_rm/implementation_advice implementation-advice}@anchor{a}@anchor{gnat_rm/implementation_advice id1}@anchor{217}
+@anchor{gnat_rm/implementation_advice doc}@anchor{214}@anchor{gnat_rm/implementation_advice id1}@anchor{215}@anchor{gnat_rm/implementation_advice implementation-advice}@anchor{a}
@chapter Implementation Advice
@@ -13418,7 +13597,7 @@ behavior of all Ada compilers, and the GNAT compiler conforms to
these requirements.
In addition, there are sections throughout the Ada Reference Manual headed
-by the phrase 'Implementation advice'. These sections are not normative,
+by the phrase ‘Implementation advice’. These sections are not normative,
i.e., they do not specify requirements that all compilers must
follow. Rather they provide advice on generally desirable behavior.
They are not requirements, because they describe behavior that cannot
@@ -13431,7 +13610,7 @@ RM section number and paragraph number and the subject of
the advice. The contents of each section consists of the RM text within
quotation marks,
followed by the GNAT interpretation of the advice. Most often, this simply says
-'followed', which means that GNAT follows the advice. However, in a
+‘followed’, which means that GNAT follows the advice. However, in a
number of cases, GNAT deliberately deviates from this advice, in which
case the text describes what GNAT does and why.
@@ -13449,7 +13628,7 @@ case the text describes what GNAT does and why.
* RM 3.5.5(8); Enumeration Values: RM 3 5 5 8 Enumeration Values.
* RM 3.5.7(17); Float Types: RM 3 5 7 17 Float Types.
* RM 3.6.2(11); Multidimensional Arrays: RM 3 6 2 11 Multidimensional Arrays.
-* RM 9.6(30-31); Duration'Small: RM 9 6 30-31 Duration'Small.
+* RM 9.6(30-31); Duration’Small: RM 9 6 30-31 Duration’Small.
* RM 10.2.1(12); Consistent Representation: RM 10 2 1 12 Consistent Representation.
* RM 11.4.1(19); Exception Information: RM 11 4 1 19 Exception Information.
* RM 11.5(28); Suppression of Checks: RM 11 5 28 Suppression of Checks.
@@ -13475,6 +13654,7 @@ case the text describes what GNAT does and why.
* RM A.4.4(106); Bounded-Length String Handling: RM A 4 4 106 Bounded-Length String Handling.
* RM A.5.2(46-47); Random Number Generation: RM A 5 2 46-47 Random Number Generation.
* RM A.10.7(23); Get_Immediate: RM A 10 7 23 Get_Immediate.
+* RM A.18; Containers: RM A 18 Containers.
* RM B.1(39-41); Pragma Export: RM B 1 39-41 Pragma Export.
* RM B.2(12-13); Package Interfaces: RM B 2 12-13 Package Interfaces.
* RM B.3(63-71); Interfacing with C: RM B 3 63-71 Interfacing with C.
@@ -13506,15 +13686,15 @@ 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{218}
+@anchor{gnat_rm/implementation_advice rm-1-1-3-20-error-detection}@anchor{216}
@section RM 1.1.3(20): Error Detection
@quotation
-"If an implementation detects the use of an unsupported Specialized Needs
+“If an implementation detects the use of an unsupported Specialized Needs
Annex feature at run time, it should raise @code{Program_Error} if
-feasible."
+feasible.”
@end quotation
Not relevant. All specialized needs annex features are either supported,
@@ -13523,15 +13703,15 @@ 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{219}
+@anchor{gnat_rm/implementation_advice rm-1-1-3-31-child-units}@anchor{217}
@section RM 1.1.3(31): Child Units
@quotation
-"If an implementation wishes to provide implementation-defined
+“If an implementation wishes to provide implementation-defined
extensions to the functionality of a language-defined library unit, it
-should normally do so by adding children to the library unit."
+should normally do so by adding children to the library unit.”
@end quotation
Followed.
@@ -13539,14 +13719,14 @@ 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{21a}
+@anchor{gnat_rm/implementation_advice rm-1-1-5-12-bounded-errors}@anchor{218}
@section RM 1.1.5(12): Bounded Errors
@quotation
-"If an implementation detects a bounded error or erroneous
-execution, it should raise @code{Program_Error}."
+“If an implementation detects a bounded error or erroneous
+execution, it should raise @code{Program_Error}.”
@end quotation
Followed in all cases in which the implementation detects a bounded
@@ -13556,16 +13736,16 @@ 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{21b}@anchor{gnat_rm/implementation_advice rm-2-8-16-pragmas}@anchor{21c}
+@anchor{gnat_rm/implementation_advice id2}@anchor{219}@anchor{gnat_rm/implementation_advice rm-2-8-16-pragmas}@anchor{21a}
@section RM 2.8(16): Pragmas
@quotation
-"Normally, implementation-defined pragmas should have no semantic effect
+“Normally, implementation-defined pragmas should have no semantic effect
for error-free programs; that is, if the implementation-defined pragmas
are removed from a working program, the program should still be legal,
-and should still have the same semantics."
+and should still have the same semantics.”
@end quotation
The following implementation defined pragmas are exceptions to this
@@ -13669,13 +13849,13 @@ 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{21d}
+@anchor{gnat_rm/implementation_advice rm-2-8-17-19-pragmas}@anchor{21b}
@section RM 2.8(17-19): Pragmas
@quotation
-"Normally, an implementation should not define pragmas that can
+“Normally, an implementation should not define pragmas that can
make an illegal program legal, except as follows:
@@ -13686,33 +13866,33 @@ A pragma used to complete a declaration, such as a pragma @code{Import};
@item
A pragma used to configure the environment by adding, removing, or
-replacing @code{library_items}."
+replacing @code{library_items}.”
@end itemize
@end quotation
-See @ref{21c,,RM 2.8(16); Pragmas}.
+See @ref{21a,,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{21e}
+@anchor{gnat_rm/implementation_advice rm-3-5-2-5-alternative-character-sets}@anchor{21c}
@section RM 3.5.2(5): Alternative Character Sets
@quotation
-"If an implementation supports a mode with alternative interpretations
+“If an implementation supports a mode with alternative interpretations
for @code{Character} and @code{Wide_Character}, the set of graphic
characters of @code{Character} should nevertheless remain a proper
subset of the set of graphic characters of @code{Wide_Character}. Any
-character set 'localizations' should be reflected in the results of
+character set ‘localizations’ should be reflected in the results of
the subprograms defined in the language-defined package
@code{Characters.Handling} (see A.3) available in such a mode. In a mode with
an alternative interpretation of @code{Character}, the implementation should
also support a corresponding change in what is a legal
-@code{identifier_letter}."
+@code{identifier_letter}.”
@end quotation
Not all wide character modes follow this advice, in particular the JIS
@@ -13725,17 +13905,17 @@ 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{21f}
+@anchor{gnat_rm/implementation_advice rm-3-5-4-28-integer-types}@anchor{21d}
@section RM 3.5.4(28): Integer Types
@quotation
-"An implementation should support @code{Long_Integer} in addition to
+“An implementation should support @code{Long_Integer} in addition to
@code{Integer} if the target machine supports 32-bit (or longer)
arithmetic. No other named integer subtypes are recommended for package
@code{Standard}. Instead, appropriate named integer subtypes should be
-provided in the library package @code{Interfaces} (see B.2)."
+provided in the library package @code{Interfaces} (see B.2).”
@end quotation
@code{Long_Integer} is supported. Other standard integer types are supported
@@ -13744,15 +13924,15 @@ 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{220}
+@anchor{gnat_rm/implementation_advice rm-3-5-4-29-integer-types}@anchor{21e}
@section RM 3.5.4(29): Integer Types
@quotation
-"An implementation for a two's complement machine should support
+“An implementation for a two’s complement machine should support
modular types with a binary modulus up to @code{System.Max_Int*2+2}. An
-implementation should support a non-binary modules up to @code{Integer'Last}."
+implementation should support a non-binary modules up to @code{Integer'Last}.”
@end quotation
Followed.
@@ -13760,19 +13940,19 @@ 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{221}
+@anchor{gnat_rm/implementation_advice rm-3-5-5-8-enumeration-values}@anchor{21f}
@section RM 3.5.5(8): Enumeration Values
@quotation
-"For the evaluation of a call on @code{S'Pos} for an enumeration
+“For the evaluation of a call on @code{S'Pos} for an enumeration
subtype, if the value of the operand does not correspond to the internal
code for any enumeration literal of its type (perhaps due to an
un-initialized variable), then the implementation should raise
@code{Program_Error}. This is particularly important for enumeration
types with noncontiguous internal codes specified by an
-enumeration_representation_clause."
+enumeration_representation_clause.”
@end quotation
Followed.
@@ -13780,17 +13960,17 @@ 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{222}
+@anchor{gnat_rm/implementation_advice rm-3-5-7-17-float-types}@anchor{220}
@section RM 3.5.7(17): Float Types
@quotation
-"An implementation should support @code{Long_Float} in addition to
+“An implementation should support @code{Long_Float} in addition to
@code{Float} if the target machine supports 11 or more digits of
precision. No other named floating point subtypes are recommended for
package @code{Standard}. Instead, appropriate named floating point subtypes
-should be provided in the library package @code{Interfaces} (see B.2)."
+should be provided in the library package @code{Interfaces} (see B.2).”
@end quotation
@code{Short_Float} and @code{Long_Long_Float} are also provided. The
@@ -13809,57 +13989,57 @@ is a software rather than a hardware format.
@geindex Arrays
@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{223}
+@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}
@section RM 3.6.2(11): Multidimensional Arrays
@quotation
-"An implementation should normally represent multidimensional arrays in
+“An implementation should normally represent multidimensional arrays in
row-major order, consistent with the notation used for multidimensional
array aggregates (see 4.3.3). However, if a pragma @code{Convention}
-(@code{Fortran}, ...) applies to a multidimensional array type, then
-column-major order should be used instead (see B.5, @emph{Interfacing with Fortran})."
+(@code{Fortran}, …) applies to a multidimensional array type, then
+column-major order should be used instead (see B.5, @emph{Interfacing with Fortran}).”
@end quotation
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{224}
-@section RM 9.6(30-31): 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}
+@section RM 9.6(30-31): Duration’Small
@quotation
-"Whenever possible in an implementation, the value of @code{Duration'Small}
-should be no greater than 100 microseconds."
+“Whenever possible in an implementation, the value of @code{Duration'Small}
+should be no greater than 100 microseconds.”
@end quotation
Followed. (@code{Duration'Small} = 10**(-9)).
@quotation
-"The time base for @code{delay_relative_statements} should be monotonic;
-it need not be the same time base as used for @code{Calendar.Clock}."
+“The time base for @code{delay_relative_statements} should be monotonic;
+it need not be the same time base as used for @code{Calendar.Clock}.”
@end quotation
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{225}
+@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}
@section RM 10.2.1(12): Consistent Representation
@quotation
-"In an implementation, a type declared in a pre-elaborated package should
+“In an implementation, a type declared in a pre-elaborated package should
have the same representation in every elaboration of a given version of
the package, whether the elaborations occur in distinct executions of
the same program, or in executions of distinct programs or partitions
-that include the given version."
+that include the given version.”
@end quotation
Followed, except in the case of tagged types. Tagged types involve
@@ -13871,24 +14051,24 @@ 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{226}
+@anchor{gnat_rm/implementation_advice rm-11-4-1-19-exception-information}@anchor{224}
@section RM 11.4.1(19): Exception Information
@quotation
-"@code{Exception_Message} by default and @code{Exception_Information}
+“@code{Exception_Message} by default and @code{Exception_Information}
should produce information useful for
debugging. @code{Exception_Message} should be short, about one
line. @code{Exception_Information} can be long. @code{Exception_Message}
should not include the
@code{Exception_Name}. @code{Exception_Information} should include both
-the @code{Exception_Name} and the @code{Exception_Message}."
+the @code{Exception_Name} and the @code{Exception_Message}.”
@end quotation
-Followed. For each exception that doesn't have a specified
+Followed. For each exception that doesn’t have a specified
@code{Exception_Message}, the compiler generates one containing the location
-of the raise statement. This location has the form 'file_name:line', where
+of the raise statement. This location has the form ‘file_name:line’, where
file_name is the short file name (without path information) and line is the line
number in the file. Note that in the case of the Zero Cost Exception
mechanism, these messages become redundant with the Exception_Information that
@@ -13902,14 +14082,14 @@ 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{227}
+@anchor{gnat_rm/implementation_advice rm-11-5-28-suppression-of-checks}@anchor{225}
@section RM 11.5(28): Suppression of Checks
@quotation
-"The implementation should minimize the code executed for checks that
-have been suppressed."
+“The implementation should minimize the code executed for checks that
+have been suppressed.”
@end quotation
Followed.
@@ -13917,20 +14097,20 @@ 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{228}
+@anchor{gnat_rm/implementation_advice rm-13-1-21-24-representation-clauses}@anchor{226}
@section RM 13.1 (21-24): Representation Clauses
@quotation
-"The recommended level of support for all representation items is
+“The recommended level of support for all representation items is
qualified as follows:
An implementation need not support representation items containing
nonstatic expressions, except that an implementation should support a
representation item for a given entity if each nonstatic expression in
the representation item is a name that statically denotes a constant
-declared before the entity."
+declared before the entity.”
@end quotation
Followed. In fact, GNAT goes beyond the recommended level of support
@@ -13957,8 +14137,8 @@ described above.
@quotation
-"An aliased component, or a component whose type is by-reference, should
-always be allocated at an addressable location."
+“An aliased component, or a component whose type is by-reference, should
+always be allocated at an addressable location.”
@end quotation
Followed.
@@ -13966,13 +14146,13 @@ 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{229}
+@anchor{gnat_rm/implementation_advice rm-13-2-6-8-packed-types}@anchor{227}
@section RM 13.2(6-8): Packed Types
@quotation
-"If a type is packed, then the implementation should try to minimize
+“If a type is packed, then the implementation should try to minimize
storage allocated to objects of the type, possibly at the expense of
speed of accessing components, subject to reasonable complexity in
addressing calculations.
@@ -13984,7 +14164,7 @@ possible subject to the Sizes of the component subtypes, and subject to
any @emph{record_representation_clause} that applies to the type; the
implementation may, but need not, reorder components or cross aligned
word boundaries to improve the packing. A component whose @code{Size} is
-greater than the word size may be allocated an integral number of words."
+greater than the word size may be allocated an integral number of words.”
@end quotation
Followed. Tight packing of arrays is supported for all component sizes
@@ -13996,8 +14176,8 @@ subcomponent of the packed type.
@quotation
-"An implementation should support Address clauses for imported
-subprograms."
+“An implementation should support Address clauses for imported
+subprograms.”
@end quotation
Followed.
@@ -14005,25 +14185,25 @@ 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{22a}
+@anchor{gnat_rm/implementation_advice rm-13-3-14-19-address-clauses}@anchor{228}
@section RM 13.3(14-19): Address Clauses
@quotation
-"For an array @code{X}, @code{X'Address} should point at the first
-component of the array, and not at the array bounds."
+“For an array @code{X}, @code{X'Address} should point at the first
+component of the array, and not at the array bounds.”
@end quotation
Followed.
@quotation
-"The recommended level of support for the @code{Address} attribute is:
+“The recommended level of support for the @code{Address} attribute is:
@code{X'Address} should produce a useful result if @code{X} is an
object that is aliased or of a by-reference type, or is an entity whose
-@code{Address} has been specified."
+@code{Address} has been specified.”
@end quotation
Followed. A valid address will be produced even if none of those
@@ -14032,25 +14212,25 @@ memory to ensure the address is valid.
@quotation
-"An implementation should support @code{Address} clauses for imported
-subprograms."
+“An implementation should support @code{Address} clauses for imported
+subprograms.”
@end quotation
Followed.
@quotation
-"Objects (including subcomponents) that are aliased or of a by-reference
-type should be allocated on storage element boundaries."
+“Objects (including subcomponents) that are aliased or of a by-reference
+type should be allocated on storage element boundaries.”
@end quotation
Followed.
@quotation
-"If the @code{Address} of an object is specified, or it is imported or exported,
+“If the @code{Address} of an object is specified, or it is imported or exported,
then the implementation should not perform optimizations based on
-assumptions of no aliases."
+assumptions of no aliases.”
@end quotation
Followed.
@@ -14058,56 +14238,56 @@ 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{22b}
+@anchor{gnat_rm/implementation_advice rm-13-3-29-35-alignment-clauses}@anchor{229}
@section RM 13.3(29-35): Alignment Clauses
@quotation
-"The recommended level of support for the @code{Alignment} attribute for
+“The recommended level of support for the @code{Alignment} attribute for
subtypes is:
An implementation should support specified Alignments that are factors
and multiples of the number of storage elements per word, subject to the
-following:"
+following:”
@end quotation
Followed.
@quotation
-"An implementation need not support specified Alignments for
+“An implementation need not support specified Alignments for
combinations of Sizes and Alignments that cannot be easily
-loaded and stored by available machine instructions."
+loaded and stored by available machine instructions.”
@end quotation
Followed.
@quotation
-"An implementation need not support specified Alignments that are
+“An implementation need not support specified Alignments that are
greater than the maximum @code{Alignment} the implementation ever returns by
-default."
+default.”
@end quotation
Followed.
@quotation
-"The recommended level of support for the @code{Alignment} attribute for
+“The recommended level of support for the @code{Alignment} attribute for
objects is:
-Same as above, for subtypes, but in addition:"
+Same as above, for subtypes, but in addition:”
@end quotation
Followed.
@quotation
-"For stand-alone library-level objects of statically constrained
+“For stand-alone library-level objects of statically constrained
subtypes, the implementation should support all alignments
supported by the target linker. For example, page alignment is likely to
-be supported for such objects, but not for subtypes."
+be supported for such objects, but not for subtypes.”
@end quotation
Followed.
@@ -14115,44 +14295,44 @@ 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{22c}
+@anchor{gnat_rm/implementation_advice rm-13-3-42-43-size-clauses}@anchor{22a}
@section RM 13.3(42-43): Size Clauses
@quotation
-"The recommended level of support for the @code{Size} attribute of
+“The recommended level of support for the @code{Size} attribute of
objects is:
A @code{Size} clause should be supported for an object if the specified
-@code{Size} is at least as large as its subtype's @code{Size}, and
+@code{Size} is at least as large as its subtype’s @code{Size}, and
corresponds to a size in storage elements that is a multiple of the
-object's @code{Alignment} (if the @code{Alignment} is nonzero)."
+object’s @code{Alignment} (if the @code{Alignment} is nonzero).”
@end quotation
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{22d}
+@anchor{gnat_rm/implementation_advice rm-13-3-50-56-size-clauses}@anchor{22b}
@section RM 13.3(50-56): Size Clauses
@quotation
-"If the @code{Size} of a subtype is specified, and allows for efficient
+“If the @code{Size} of a subtype is specified, and allows for efficient
independent addressability (see 9.10) on the target architecture, then
the @code{Size} of the following objects of the subtype should equal the
@code{Size} of the subtype:
-Aliased objects (including components)."
+Aliased objects (including components).”
@end quotation
Followed.
@quotation
-"@cite{Size} clause on a composite subtype should not affect the
-internal layout of components."
+“@cite{Size} clause on a composite subtype should not affect the
+internal layout of components.”
@end quotation
Followed. But note that this can be overridden by use of the implementation
@@ -14160,23 +14340,23 @@ pragma Implicit_Packing in the case of packed arrays.
@quotation
-"The recommended level of support for the @code{Size} attribute of subtypes is:
+“The recommended level of support for the @code{Size} attribute of subtypes is:
The @code{Size} (if not specified) of a static discrete or fixed point
subtype should be the number of bits needed to represent each value
belonging to the subtype using an unbiased representation, leaving space
for a sign bit only if the subtype contains negative values. If such a
subtype is a first subtype, then an implementation should support a
-specified @code{Size} for it that reflects this representation."
+specified @code{Size} for it that reflects this representation.”
@end quotation
Followed.
@quotation
-"For a subtype implemented with levels of indirection, the @code{Size}
+“For a subtype implemented with levels of indirection, the @code{Size}
should include the size of the pointers, but not the size of what they
-point at."
+point at.”
@end quotation
Followed.
@@ -14184,30 +14364,30 @@ 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{22e}
+@anchor{gnat_rm/implementation_advice rm-13-3-71-73-component-size-clauses}@anchor{22c}
@section RM 13.3(71-73): Component Size Clauses
@quotation
-"The recommended level of support for the @code{Component_Size}
+“The recommended level of support for the @code{Component_Size}
attribute is:
An implementation need not support specified @code{Component_Sizes} that are
-less than the @code{Size} of the component subtype."
+less than the @code{Size} of the component subtype.”
@end quotation
Followed.
@quotation
-"An implementation should support specified Component_Sizes that
+“An implementation should support specified Component_Sizes that
are factors and multiples of the word size. For such
Component_Sizes, the array should contain no gaps between
components. For other Component_Sizes (if supported), the array
should contain no gaps between components when packing is also
specified; the implementation should forbid this combination in cases
-where it cannot support a no-gaps representation."
+where it cannot support a no-gaps representation.”
@end quotation
Followed.
@@ -14218,18 +14398,18 @@ 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{22f}
+@anchor{gnat_rm/implementation_advice rm-13-4-9-10-enumeration-representation-clauses}@anchor{22d}
@section RM 13.4(9-10): Enumeration Representation Clauses
@quotation
-"The recommended level of support for enumeration representation clauses
+“The recommended level of support for enumeration representation clauses
is:
An implementation need not support enumeration representation clauses
for boolean types, but should at minimum support the internal codes in
-the range @code{System.Min_Int .. System.Max_Int}."
+the range @code{System.Min_Int .. System.Max_Int}.”
@end quotation
Followed.
@@ -14240,58 +14420,58 @@ 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{230}
+@anchor{gnat_rm/implementation_advice rm-13-5-1-17-22-record-representation-clauses}@anchor{22e}
@section RM 13.5.1(17-22): Record Representation Clauses
@quotation
-"The recommended level of support for
+“The recommended level of support for
@emph{record_representation_clause}s is:
An implementation should support storage places that can be extracted
with a load, mask, shift sequence of machine code, and set with a load,
shift, mask, store sequence, given the available machine instructions
-and run-time model."
+and run-time model.”
@end quotation
Followed.
@quotation
-"A storage place should be supported if its size is equal to the
+“A storage place should be supported if its size is equal to the
@code{Size} of the component subtype, and it starts and ends on a
-boundary that obeys the @code{Alignment} of the component subtype."
+boundary that obeys the @code{Alignment} of the component subtype.”
@end quotation
Followed.
@quotation
-"If the default bit ordering applies to the declaration of a given type,
-then for a component whose subtype's @code{Size} is less than the word
+“If the default bit ordering applies to the declaration of a given type,
+then for a component whose subtype’s @code{Size} is less than the word
size, any storage place that does not cross an aligned word boundary
-should be supported."
+should be supported.”
@end quotation
Followed.
@quotation
-"An implementation may reserve a storage place for the tag field of a
-tagged type, and disallow other components from overlapping that place."
+“An implementation may reserve a storage place for the tag field of a
+tagged type, and disallow other components from overlapping that place.”
@end quotation
Followed. The storage place for the tag field is the beginning of the tagged
-record, and its size is Address'Size. GNAT will reject an explicit component
+record, and its size is Address’Size. GNAT will reject an explicit component
clause for the tag field.
@quotation
-"An implementation need not support a @emph{component_clause} for a
+“An implementation need not support a @emph{component_clause} for a
component of an extension part if the storage place is not after the
storage places of all components of the parent type, whether or not
-those storage places had been specified."
+those storage places had been specified.”
@end quotation
Followed. The above advice on record representation clauses is followed,
@@ -14300,19 +14480,19 @@ 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{231}
+@anchor{gnat_rm/implementation_advice rm-13-5-2-5-storage-place-attributes}@anchor{22f}
@section RM 13.5.2(5): Storage Place Attributes
@quotation
-"If a component is represented using some form of pointer (such as an
+“If a component is represented using some form of pointer (such as an
offset) to the actual data of the component, and this data is contiguous
with the rest of the object, then the storage place attributes should
reflect the place of the actual data, not the pointer. If a component is
allocated discontinuously from the rest of the object, then a warning
should be generated upon reference to one of its storage place
-attributes."
+attributes.”
@end quotation
Followed. There are no such components in GNAT.
@@ -14320,17 +14500,17 @@ 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{232}
+@anchor{gnat_rm/implementation_advice rm-13-5-3-7-8-bit-ordering}@anchor{230}
@section RM 13.5.3(7-8): Bit Ordering
@quotation
-"The recommended level of support for the non-default bit ordering is:
+“The recommended level of support for the non-default bit ordering is:
If @code{Word_Size} = @code{Storage_Unit}, then the implementation
should support the non-default bit ordering in addition to the default
-bit ordering."
+bit ordering.”
@end quotation
Followed. Word size does not equal storage size in this implementation.
@@ -14340,13 +14520,13 @@ 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{233}
+@anchor{gnat_rm/implementation_advice rm-13-7-37-address-as-private}@anchor{231}
@section RM 13.7(37): Address as Private
@quotation
-"@cite{Address} should be of a private type."
+“@cite{Address} should be of a private type.”
@end quotation
Followed.
@@ -14358,16 +14538,16 @@ 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{234}
+@anchor{gnat_rm/implementation_advice rm-13-7-1-16-address-operations}@anchor{232}
@section RM 13.7.1(16): Address Operations
@quotation
-"Operations in @code{System} and its children should reflect the target
+“Operations in @code{System} and its children should reflect the target
environment semantics as closely as is reasonable. For example, on most
-machines, it makes sense for address arithmetic to 'wrap around'.
-Operations that do not make sense should raise @code{Program_Error}."
+machines, it makes sense for address arithmetic to ‘wrap around’.
+Operations that do not make sense should raise @code{Program_Error}.”
@end quotation
Followed. Address arithmetic is modular arithmetic that wraps around. No
@@ -14376,25 +14556,25 @@ 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{235}
+@anchor{gnat_rm/implementation_advice rm-13-9-14-17-unchecked-conversion}@anchor{233}
@section RM 13.9(14-17): Unchecked Conversion
@quotation
-"The @code{Size} of an array object should not include its bounds; hence,
-the bounds should not be part of the converted data."
+“The @code{Size} of an array object should not include its bounds; hence,
+the bounds should not be part of the converted data.”
@end quotation
Followed.
@quotation
-"The implementation should not generate unnecessary run-time checks to
+“The implementation should not generate unnecessary run-time checks to
ensure that the representation of @code{S} is a representation of the
target type. It should take advantage of the permission to return by
reference when possible. Restrictions on unchecked conversions should be
-avoided unless required by the target environment."
+avoided unless required by the target environment.”
@end quotation
Followed. There are no restrictions on unchecked conversion. A warning is
@@ -14403,7 +14583,7 @@ the semantics in this case may be target dependent.
@quotation
-"The recommended level of support for unchecked conversions is:
+“The recommended level of support for unchecked conversions is:
Unchecked conversions should be supported and should be reversible in
the cases where this clause defines the result. To enable meaningful use
@@ -14411,7 +14591,7 @@ of unchecked conversion, a contiguous representation should be used for
elementary subtypes, for statically constrained array subtypes whose
component subtype is one of the subtypes described in this paragraph,
and for record subtypes without discriminants whose component subtypes
-are described in this paragraph."
+are described in this paragraph.”
@end quotation
Followed.
@@ -14420,15 +14600,15 @@ 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{236}
+@anchor{gnat_rm/implementation_advice rm-13-11-23-25-implicit-heap-usage}@anchor{234}
@section RM 13.11(23-25): Implicit Heap Usage
@quotation
-"An implementation should document any cases in which it dynamically
+“An implementation should document any cases in which it dynamically
allocates heap storage for a purpose other than the evaluation of an
-allocator."
+allocator.”
@end quotation
Followed, the only other points at which heap storage is dynamically
@@ -14452,18 +14632,18 @@ stack is used for returning variable length results.
@quotation
-"A default (implementation-provided) storage pool for an
+“A default (implementation-provided) storage pool for an
access-to-constant type should not have overhead to support deallocation of
-individual objects."
+individual objects.”
@end quotation
Followed.
@quotation
-"A storage pool for an anonymous access type should be created at the
+“A storage pool for an anonymous access type should be created at the
point of an allocator for the type, and be reclaimed when the designated
-object becomes inaccessible."
+object becomes inaccessible.”
@end quotation
Followed.
@@ -14471,14 +14651,14 @@ 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{237}
+@anchor{gnat_rm/implementation_advice rm-13-11-2-17-unchecked-deallocation}@anchor{235}
@section RM 13.11.2(17): Unchecked Deallocation
@quotation
-"For a standard storage pool, @code{Free} should actually reclaim the
-storage."
+“For a standard storage pool, @code{Free} should actually reclaim the
+storage.”
@end quotation
Followed.
@@ -14486,17 +14666,17 @@ 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{238}
+@anchor{gnat_rm/implementation_advice rm-13-13-2-1-6-stream-oriented-attributes}@anchor{236}
@section RM 13.13.2(1.6): Stream Oriented Attributes
@quotation
-"If not specified, the value of Stream_Size for an elementary type
+“If not specified, the value of Stream_Size for an elementary type
should be the number of bits that corresponds to the minimum number of
stream elements required by the first subtype of the type, rounded up
to the nearest factor or multiple of the word size that is also a
-multiple of the stream element size."
+multiple of the stream element size.”
@end quotation
Followed, except that the number of stream elements is 1, 2, 3, 4 or 8.
@@ -14517,17 +14697,17 @@ scalar types. This XDR alternative can be enabled via the binder switch -xdr.
@geindex Stream oriented attributes
@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{239}
+@anchor{gnat_rm/implementation_advice rm-a-1-52-names-of-predefined-numeric-types}@anchor{237}
@section RM A.1(52): Names of Predefined Numeric Types
@quotation
-"If an implementation provides additional named predefined integer types,
+“If an implementation provides additional named predefined integer types,
then the names should end with @code{Integer} as in
@code{Long_Integer}. If an implementation provides additional named
predefined floating point types, then the names should end with
-@code{Float} as in @code{Long_Float}."
+@code{Float} as in @code{Long_Float}.”
@end quotation
Followed.
@@ -14535,16 +14715,16 @@ 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{23a}
+@anchor{gnat_rm/implementation_advice rm-a-3-2-49-ada-characters-handling}@anchor{238}
@section RM A.3.2(49): @code{Ada.Characters.Handling}
@quotation
-"If an implementation provides a localized definition of @code{Character}
+“If an implementation provides a localized definition of @code{Character}
or @code{Wide_Character}, then the effects of the subprograms in
@code{Characters.Handling} should reflect the localizations.
-See also 3.5.2."
+See also 3.5.2.”
@end quotation
Followed. GNAT provides no such localized definitions.
@@ -14552,14 +14732,14 @@ 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{23b}
+@anchor{gnat_rm/implementation_advice rm-a-4-4-106-bounded-length-string-handling}@anchor{239}
@section RM A.4.4(106): Bounded-Length String Handling
@quotation
-"Bounded string objects should not be implemented by implicit pointers
-and dynamic allocation."
+“Bounded string objects should not be implemented by implicit pointers
+and dynamic allocation.”
@end quotation
Followed. No implicit pointers or dynamic allocation are used.
@@ -14567,27 +14747,27 @@ 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{23c}
+@anchor{gnat_rm/implementation_advice rm-a-5-2-46-47-random-number-generation}@anchor{23a}
@section RM A.5.2(46-47): Random Number Generation
@quotation
-"Any storage associated with an object of type @code{Generator} should be
-reclaimed on exit from the scope of the object."
+“Any storage associated with an object of type @code{Generator} should be
+reclaimed on exit from the scope of the object.”
@end quotation
Followed.
@quotation
-"If the generator period is sufficiently long in relation to the number
+“If the generator period is sufficiently long in relation to the number
of distinct initiator values, then each possible value of
@code{Initiator} passed to @code{Reset} should initiate a sequence of
random numbers that does not, in a practical sense, overlap the sequence
initiated by any other value. If this is not possible, then the mapping
between initiator values and generator states should be a rapidly
-varying function of the initiator value."
+varying function of the initiator value.”
@end quotation
Followed. The generator period is sufficiently long for the first
@@ -14595,20 +14775,20 @@ 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{23d}
+@node RM A 10 7 23 Get_Immediate,RM A 18 Containers,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}
@section RM A.10.7(23): @code{Get_Immediate}
@quotation
-"The @code{Get_Immediate} procedures should be implemented with
+“The @code{Get_Immediate} procedures should be implemented with
unbuffered input. For a device such as a keyboard, input should be
available if a key has already been typed, whereas for a disk
file, input should always be available except at end of file. For a file
associated with a keyboard-like device, any line-editing features of the
underlying operating system should be disabled during the execution of
-@code{Get_Immediate}."
+@code{Get_Immediate}.”
@end quotation
Followed on all targets except VxWorks. For VxWorks, there is no way to
@@ -14617,16 +14797,37 @@ flushed before the @code{Get_Immediate} call. A special unit
@code{Interfaces.Vxworks.IO} is provided that contains routines to enable
this functionality.
+@geindex Containers
+
+@node RM A 18 Containers,RM B 1 39-41 Pragma Export,RM A 10 7 23 Get_Immediate,Implementation Advice
+@anchor{gnat_rm/implementation_advice rm-a-18-containers}@anchor{23c}
+@section RM A.18: @code{Containers}
+
+
+All implementation advice pertaining to Ada.Containers and its
+child units (that is, all implementation advice occurring within
+section A.18 and its subsections) is followed except for A.18.24(17):
+
+@quotation
+
+“Bounded ordered set objects should be implemented without implicit pointers or dynamic allocation. “
+@end quotation
+
+The implementations of the two Reference_Preserving_Key functions of
+the generic package Ada.Containers.Bounded_Ordered_Sets each currently make
+use of dynamic allocation; other operations on bounded ordered set objects
+follow the implementation advice.
+
@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{23e}
+@node RM B 1 39-41 Pragma Export,RM B 2 12-13 Package Interfaces,RM A 18 Containers,Implementation Advice
+@anchor{gnat_rm/implementation_advice rm-b-1-39-41-pragma-export}@anchor{23d}
@section RM B.1(39-41): Pragma @code{Export}
@quotation
-"If an implementation supports pragma @code{Export} to a given language,
+“If an implementation supports pragma @code{Export} to a given language,
then it should also allow the main subprogram to be written in that
language. It should support some mechanism for invoking the elaboration
of the Ada library units included in the system, and for invoking the
@@ -14635,15 +14836,15 @@ recommended mechanism is to provide two subprograms whose link names are
@code{adainit} and @code{adafinal}. @code{adainit} should contain the
elaboration code for library units. @code{adafinal} should contain the
finalization code. These subprograms should have no effect the second
-and subsequent time they are called."
+and subsequent time they are called.”
@end quotation
Followed.
@quotation
-"Automatic elaboration of pre-elaborated packages should be
-provided when pragma @code{Export} is supported."
+“Automatic elaboration of pre-elaborated packages should be
+provided when pragma @code{Export} is supported.”
@end quotation
Followed when the main program is in Ada. If the main program is in a
@@ -14653,12 +14854,12 @@ packages.
@quotation
-"For each supported convention @emph{L} other than @code{Intrinsic}, an
+“For each supported convention @emph{L} other than @code{Intrinsic}, an
implementation should support @code{Import} and @code{Export} pragmas
for objects of @emph{L}-compatible types and for subprograms, and pragma
@cite{Convention} for @emph{L}-eligible types and for subprograms,
presuming the other language has corresponding features. Pragma
-@code{Convention} need not be supported for scalar types."
+@code{Convention} need not be supported for scalar types.”
@end quotation
Followed.
@@ -14668,28 +14869,28 @@ 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{23f}
+@anchor{gnat_rm/implementation_advice rm-b-2-12-13-package-interfaces}@anchor{23e}
@section RM B.2(12-13): Package @code{Interfaces}
@quotation
-"For each implementation-defined convention identifier, there should be a
+“For each implementation-defined convention identifier, there should be a
child package of package Interfaces with the corresponding name. This
package should contain any declarations that would be useful for
interfacing to the language (implementation) represented by the
convention. Any declarations useful for interfacing to any language on
the given hardware architecture should be provided directly in
-@code{Interfaces}."
+@code{Interfaces}.”
@end quotation
Followed.
@quotation
-"An implementation supporting an interface to C, COBOL, or Fortran should
+“An implementation supporting an interface to C, COBOL, or Fortran should
provide the corresponding package or packages described in the following
-clauses."
+clauses.”
@end quotation
Followed. GNAT provides all the packages described in this section.
@@ -14698,66 +14899,66 @@ 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{240}
+@anchor{gnat_rm/implementation_advice rm-b-3-63-71-interfacing-with-c}@anchor{23f}
@section RM B.3(63-71): Interfacing with C
@quotation
-"An implementation should support the following interface correspondences
-between Ada and C."
+“An implementation should support the following interface correspondences
+between Ada and C.”
@end quotation
Followed.
@quotation
-"An Ada procedure corresponds to a void-returning C function."
+“An Ada procedure corresponds to a void-returning C function.”
@end quotation
Followed.
@quotation
-"An Ada function corresponds to a non-void C function."
+“An Ada function corresponds to a non-void C function.”
@end quotation
Followed.
@quotation
-"An Ada @code{in} scalar parameter is passed as a scalar argument to a C
-function."
+“An Ada @code{in} scalar parameter is passed as a scalar argument to a C
+function.”
@end quotation
Followed.
@quotation
-"An Ada @code{in} parameter of an access-to-object type with designated
+“An Ada @code{in} parameter of an access-to-object type with designated
type @code{T} is passed as a @code{t*} argument to a C function,
-where @code{t} is the C type corresponding to the Ada type @code{T}."
+where @code{t} is the C type corresponding to the Ada type @code{T}.”
@end quotation
Followed.
@quotation
-"An Ada access @code{T} parameter, or an Ada @code{out} or @code{in out}
+“An Ada access @code{T} parameter, or an Ada @code{out} or @code{in out}
parameter of an elementary type @code{T}, is passed as a @code{t*}
argument to a C function, where @code{t} is the C type corresponding to
the Ada type @code{T}. In the case of an elementary @code{out} or
@code{in out} parameter, a pointer to a temporary copy is used to
-preserve by-copy semantics."
+preserve by-copy semantics.”
@end quotation
Followed.
@quotation
-"An Ada parameter of a record type @code{T}, of any mode, is passed as a
+“An Ada parameter of a record type @code{T}, of any mode, is passed as a
@code{t*} argument to a C function, where @code{t} is the C
-structure corresponding to the Ada type @code{T}."
+structure corresponding to the Ada type @code{T}.”
@end quotation
Followed. This convention may be overridden by the use of the C_Pass_By_Copy
@@ -14766,18 +14967,18 @@ call using an extended import or export pragma.
@quotation
-"An Ada parameter of an array type with component type @code{T}, of any
+“An Ada parameter of an array type with component type @code{T}, of any
mode, is passed as a @code{t*} argument to a C function, where
-@code{t} is the C type corresponding to the Ada type @code{T}."
+@code{t} is the C type corresponding to the Ada type @code{T}.”
@end quotation
Followed.
@quotation
-"An Ada parameter of an access-to-subprogram type is passed as a pointer
+“An Ada parameter of an access-to-subprogram type is passed as a pointer
to a C function whose prototype corresponds to the designated
-subprogram's specification."
+subprogram’s specification.”
@end quotation
Followed.
@@ -14786,39 +14987,39 @@ 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{241}
+@anchor{gnat_rm/implementation_advice rm-b-4-95-98-interfacing-with-cobol}@anchor{240}
@section RM B.4(95-98): Interfacing with COBOL
@quotation
-"An Ada implementation should support the following interface
-correspondences between Ada and COBOL."
+“An Ada implementation should support the following interface
+correspondences between Ada and COBOL.”
@end quotation
Followed.
@quotation
-"An Ada access @code{T} parameter is passed as a @code{BY REFERENCE} data item of
-the COBOL type corresponding to @code{T}."
+“An Ada access @code{T} parameter is passed as a @code{BY REFERENCE} data item of
+the COBOL type corresponding to @code{T}.”
@end quotation
Followed.
@quotation
-"An Ada in scalar parameter is passed as a @code{BY CONTENT} data item of
-the corresponding COBOL type."
+“An Ada in scalar parameter is passed as a @code{BY CONTENT} data item of
+the corresponding COBOL type.”
@end quotation
Followed.
@quotation
-"Any other Ada parameter is passed as a @code{BY REFERENCE} data item of the
+“Any other Ada parameter is passed as a @code{BY REFERENCE} data item of the
COBOL type corresponding to the Ada parameter type; for scalars, a local
-copy is used if necessary to ensure by-copy semantics."
+copy is used if necessary to ensure by-copy semantics.”
@end quotation
Followed.
@@ -14827,50 +15028,50 @@ 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{242}
+@anchor{gnat_rm/implementation_advice rm-b-5-22-26-interfacing-with-fortran}@anchor{241}
@section RM B.5(22-26): Interfacing with Fortran
@quotation
-"An Ada implementation should support the following interface
-correspondences between Ada and Fortran:"
+“An Ada implementation should support the following interface
+correspondences between Ada and Fortran:”
@end quotation
Followed.
@quotation
-"An Ada procedure corresponds to a Fortran subroutine."
+“An Ada procedure corresponds to a Fortran subroutine.”
@end quotation
Followed.
@quotation
-"An Ada function corresponds to a Fortran function."
+“An Ada function corresponds to a Fortran function.”
@end quotation
Followed.
@quotation
-"An Ada parameter of an elementary, array, or record type @code{T} is
+“An Ada parameter of an elementary, array, or record type @code{T} is
passed as a @code{T} argument to a Fortran procedure, where @code{T} is
the Fortran type corresponding to the Ada type @code{T}, and where the
INTENT attribute of the corresponding dummy argument matches the Ada
-formal parameter mode; the Fortran implementation's parameter passing
+formal parameter mode; the Fortran implementation’s parameter passing
conventions are used. For elementary types, a local copy is used if
-necessary to ensure by-copy semantics."
+necessary to ensure by-copy semantics.”
@end quotation
Followed.
@quotation
-"An Ada parameter of an access-to-subprogram type is passed as a
+“An Ada parameter of an access-to-subprogram type is passed as a
reference to a Fortran procedure whose interface corresponds to the
-designated subprogram's specification."
+designated subprogram’s specification.”
@end quotation
Followed.
@@ -14878,95 +15079,95 @@ 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{243}
+@anchor{gnat_rm/implementation_advice rm-c-1-3-5-access-to-machine-operations}@anchor{242}
@section RM C.1(3-5): Access to Machine Operations
@quotation
-"The machine code or intrinsic support should allow access to all
+“The machine code or intrinsic support should allow access to all
operations normally available to assembly language programmers for the
-target environment, including privileged instructions, if any."
+target environment, including privileged instructions, if any.”
@end quotation
Followed.
@quotation
-"The interfacing pragmas (see Annex B) should support interface to
+“The interfacing pragmas (see Annex B) should support interface to
assembler; the default assembler should be associated with the
-convention identifier @code{Assembler}."
+convention identifier @code{Assembler}.”
@end quotation
Followed.
@quotation
-"If an entity is exported to assembly language, then the implementation
+“If an entity is exported to assembly language, then the implementation
should allocate it at an addressable location, and should ensure that it
is retained by the linking process, even if not otherwise referenced
from the Ada code. The implementation should assume that any call to a
machine code or assembler subprogram is allowed to read or update every
-object that is specified as exported."
+object that is specified as exported.”
@end quotation
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{244}
+@anchor{gnat_rm/implementation_advice rm-c-1-10-16-access-to-machine-operations}@anchor{243}
@section RM C.1(10-16): Access to Machine Operations
@quotation
-"The implementation should ensure that little or no overhead is
-associated with calling intrinsic and machine-code subprograms."
+“The implementation should ensure that little or no overhead is
+associated with calling intrinsic and machine-code subprograms.”
@end quotation
Followed for both intrinsics and machine-code subprograms.
@quotation
-"It is recommended that intrinsic subprograms be provided for convenient
+“It is recommended that intrinsic subprograms be provided for convenient
access to any machine operations that provide special capabilities or
efficiency and that are not otherwise available through the language
-constructs."
+constructs.”
@end quotation
Followed. A full set of machine operation intrinsic subprograms is provided.
@quotation
-"Atomic read-modify-write operations---e.g., test and set, compare and
-swap, decrement and test, enqueue/dequeue."
+“Atomic read-modify-write operations—e.g., test and set, compare and
+swap, decrement and test, enqueue/dequeue.”
@end quotation
Followed on any target supporting such operations.
@quotation
-"Standard numeric functions---e.g.:, sin, log."
+“Standard numeric functions—e.g.:, sin, log.”
@end quotation
Followed on any target supporting such operations.
@quotation
-"String manipulation operations---e.g.:, translate and test."
+“String manipulation operations—e.g.:, translate and test.”
@end quotation
Followed on any target supporting such operations.
@quotation
-"Vector operations---e.g.:, compare vector against thresholds."
+“Vector operations—e.g.:, compare vector against thresholds.”
@end quotation
Followed on any target supporting such operations.
@quotation
-"Direct operations on I/O ports."
+“Direct operations on I/O ports.”
@end quotation
Followed on any target supporting such operations.
@@ -14974,16 +15175,16 @@ 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{245}
+@anchor{gnat_rm/implementation_advice rm-c-3-28-interrupt-support}@anchor{244}
@section RM C.3(28): Interrupt Support
@quotation
-"If the @code{Ceiling_Locking} policy is not in effect, the
+“If the @code{Ceiling_Locking} policy is not in effect, the
implementation should provide means for the application to specify which
interrupts are to be blocked during protected actions, if the underlying
-system allows for a finer-grain control of interrupt blocking."
+system allows for a finer-grain control of interrupt blocking.”
@end quotation
Followed. The underlying system does not allow for finer-grain control
@@ -14992,14 +15193,14 @@ 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{246}
+@anchor{gnat_rm/implementation_advice rm-c-3-1-20-21-protected-procedure-handlers}@anchor{245}
@section RM C.3.1(20-21): Protected Procedure Handlers
@quotation
-"Whenever possible, the implementation should allow interrupt handlers to
-be called directly by the hardware."
+“Whenever possible, the implementation should allow interrupt handlers to
+be called directly by the hardware.”
@end quotation
Followed on any target where the underlying operating system permits
@@ -15007,8 +15208,8 @@ such direct calls.
@quotation
-"Whenever practical, violations of any
-implementation-defined restrictions should be detected before run time."
+“Whenever practical, violations of any
+implementation-defined restrictions should be detected before run time.”
@end quotation
Followed. Compile time warnings are given when possible.
@@ -15018,17 +15219,17 @@ 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{247}
+@anchor{gnat_rm/implementation_advice rm-c-3-2-25-package-interrupts}@anchor{246}
@section RM C.3.2(25): Package @code{Interrupts}
@quotation
-"If implementation-defined forms of interrupt handler procedures are
+“If implementation-defined forms of interrupt handler procedures are
supported, such as protected procedures with parameters, then for each
such form of a handler, a type analogous to @code{Parameterless_Handler}
should be specified in a child package of @code{Interrupts}, with the
-same operations as in the predefined package Interrupts."
+same operations as in the predefined package Interrupts.”
@end quotation
Followed.
@@ -15036,31 +15237,31 @@ 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{248}
+@anchor{gnat_rm/implementation_advice rm-c-4-14-pre-elaboration-requirements}@anchor{247}
@section RM C.4(14): Pre-elaboration Requirements
@quotation
-"It is recommended that pre-elaborated packages be implemented in such a
+“It is recommended that pre-elaborated packages be implemented in such a
way that there should be little or no code executed at run time for the
elaboration of entities not already covered by the Implementation
-Requirements."
+Requirements.”
@end quotation
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{249}
+@anchor{gnat_rm/implementation_advice rm-c-5-8-pragma-discard-names}@anchor{248}
@section RM C.5(8): Pragma @code{Discard_Names}
@quotation
-"If the pragma applies to an entity, then the implementation should
+“If the pragma applies to an entity, then the implementation should
reduce the amount of storage used for storing names associated with that
-entity."
+entity.”
@end quotation
Followed.
@@ -15070,20 +15271,20 @@ 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{24a}
+@anchor{gnat_rm/implementation_advice rm-c-7-2-30-the-package-task-attributes}@anchor{249}
@section RM C.7.2(30): The Package Task_Attributes
@quotation
-"Some implementations are targeted to domains in which memory use at run
+“Some implementations are targeted to domains in which memory use at run
time must be completely deterministic. For such implementations, it is
recommended that the storage for task attributes will be pre-allocated
statically and not from the heap. This can be accomplished by either
-placing restrictions on the number and the size of the task's
+placing restrictions on the number and the size of the task’s
attributes, or by using the pre-allocated storage for the first @code{N}
attribute objects, and the heap for the others. In the latter case,
-@code{N} should be documented."
+@code{N} should be documented.”
@end quotation
Not followed. This implementation is not targeted to such a domain.
@@ -15091,14 +15292,14 @@ 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{24b}
+@anchor{gnat_rm/implementation_advice rm-d-3-17-locking-policies}@anchor{24a}
@section RM D.3(17): Locking Policies
@quotation
-"The implementation should use names that end with @code{_Locking} for
-locking policies defined by the implementation."
+“The implementation should use names that end with @code{_Locking} for
+locking policies defined by the implementation.”
@end quotation
Followed. Two implementation-defined locking policies are defined,
@@ -15108,14 +15309,14 @@ 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{24c}
+@anchor{gnat_rm/implementation_advice rm-d-4-16-entry-queuing-policies}@anchor{24b}
@section RM D.4(16): Entry Queuing Policies
@quotation
-"Names that end with @code{_Queuing} should be used
-for all implementation-defined queuing policies."
+“Names that end with @code{_Queuing} should be used
+for all implementation-defined queuing policies.”
@end quotation
Followed. No such implementation-defined queuing policies exist.
@@ -15123,25 +15324,25 @@ 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{24d}
+@anchor{gnat_rm/implementation_advice rm-d-6-9-10-preemptive-abort}@anchor{24c}
@section RM D.6(9-10): Preemptive Abort
@quotation
-"Even though the @emph{abort_statement} is included in the list of
+“Even though the @emph{abort_statement} is included in the list of
potentially blocking operations (see 9.5.1), it is recommended that this
statement be implemented in a way that never requires the task executing
-the @emph{abort_statement} to block."
+the @emph{abort_statement} to block.”
@end quotation
Followed.
@quotation
-"On a multi-processor, the delay associated with aborting a task on
+“On a multi-processor, the delay associated with aborting a task on
another processor should be bounded; the implementation should use
-periodic polling, if necessary, to achieve this."
+periodic polling, if necessary, to achieve this.”
@end quotation
Followed.
@@ -15149,14 +15350,14 @@ 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{24e}
+@anchor{gnat_rm/implementation_advice rm-d-7-21-tasking-restrictions}@anchor{24d}
@section RM D.7(21): Tasking Restrictions
@quotation
-"When feasible, the implementation should take advantage of the specified
-restrictions to produce a more efficient implementation."
+“When feasible, the implementation should take advantage of the specified
+restrictions to produce a more efficient implementation.”
@end quotation
GNAT currently takes advantage of these restrictions by providing an optimized
@@ -15168,14 +15369,14 @@ 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{24f}
+@anchor{gnat_rm/implementation_advice rm-d-8-47-49-monotonic-time}@anchor{24e}
@section RM D.8(47-49): Monotonic Time
@quotation
-"When appropriate, implementations should provide configuration
-mechanisms to change the value of @code{Tick}."
+“When appropriate, implementations should provide configuration
+mechanisms to change the value of @code{Tick}.”
@end quotation
Such configuration mechanisms are not appropriate to this implementation
@@ -15183,17 +15384,17 @@ and are thus not supported.
@quotation
-"It is recommended that @code{Calendar.Clock} and @code{Real_Time.Clock}
-be implemented as transformations of the same time base."
+“It is recommended that @code{Calendar.Clock} and @code{Real_Time.Clock}
+be implemented as transformations of the same time base.”
@end quotation
Followed.
@quotation
-"It is recommended that the best time base which exists in
+“It is recommended that the best time base which exists in
the underlying system be available to the application through
-@code{Clock}. @cite{Best} may mean highest accuracy or largest range."
+@code{Clock}. @cite{Best} may mean highest accuracy or largest range.”
@end quotation
Followed.
@@ -15203,16 +15404,16 @@ 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{250}
+@anchor{gnat_rm/implementation_advice rm-e-5-28-29-partition-communication-subsystem}@anchor{24f}
@section RM E.5(28-29): Partition Communication Subsystem
@quotation
-"Whenever possible, the PCS on the called partition should allow for
+“Whenever possible, the PCS on the called partition should allow for
multiple tasks to call the RPC-receiver with different messages and
should allow them to block until the corresponding subprogram body
-returns."
+returns.”
@end quotation
Followed by GLADE, a separately supplied PCS that can be used with
@@ -15220,9 +15421,9 @@ GNAT.
@quotation
-"The @code{Write} operation on a stream of type @code{Params_Stream_Type}
+“The @code{Write} operation on a stream of type @code{Params_Stream_Type}
should raise @code{Storage_Error} if it runs out of space trying to
-write the @code{Item} into the stream."
+write the @code{Item} into the stream.”
@end quotation
Followed by GLADE, a separately supplied PCS that can be used with
@@ -15231,19 +15432,19 @@ 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{251}
+@anchor{gnat_rm/implementation_advice rm-f-7-cobol-support}@anchor{250}
@section RM F(7): COBOL Support
@quotation
-"If COBOL (respectively, C) is widely supported in the target
+“If COBOL (respectively, C) is widely supported in the target
environment, implementations supporting the Information Systems Annex
should provide the child package @code{Interfaces.COBOL} (respectively,
@code{Interfaces.C}) specified in Annex B and should support a
@code{convention_identifier} of COBOL (respectively, C) in the interfacing
pragmas (see Annex B), thus allowing Ada programs to interface with
-programs written in that language."
+programs written in that language.”
@end quotation
Followed.
@@ -15251,35 +15452,35 @@ 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{252}
+@anchor{gnat_rm/implementation_advice rm-f-1-2-decimal-radix-support}@anchor{251}
@section RM F.1(2): Decimal Radix Support
@quotation
-"Packed decimal should be used as the internal representation for objects
-of subtype @code{S} when @code{S}'Machine_Radix = 10."
+“Packed decimal should be used as the internal representation for objects
+of subtype @code{S} when @code{S}’Machine_Radix = 10.”
@end quotation
-Not followed. GNAT ignores @code{S}'Machine_Radix and always uses binary
+Not followed. GNAT ignores @code{S}’Machine_Radix and always uses binary
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{253}
+@anchor{gnat_rm/implementation_advice rm-g-numerics}@anchor{252}
@section RM G: Numerics
@quotation
-"If Fortran (respectively, C) is widely supported in the target
+“If Fortran (respectively, C) is widely supported in the target
environment, implementations supporting the Numerics Annex
should provide the child package @code{Interfaces.Fortran} (respectively,
@code{Interfaces.C}) specified in Annex B and should support a
@code{convention_identifier} of Fortran (respectively, C) in the interfacing
pragmas (see Annex B), thus allowing Ada programs to interface with
-programs written in that language."
+programs written in that language.”
@end quotation
Followed.
@@ -15287,13 +15488,13 @@ 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{254}
+@anchor{gnat_rm/implementation_advice rm-g-1-1-56-58-complex-types}@anchor{253}
@section RM G.1.1(56-58): Complex Types
@quotation
-"Because the usual mathematical meaning of multiplication of a complex
+“Because the usual mathematical meaning of multiplication of a complex
operand and a real operand is that of the scaling of both components of
the former by the latter, an implementation should not perform this
operation by first promoting the real operand to complex type and then
@@ -15305,14 +15506,14 @@ component by the zero component obtained during promotion yields a NaN
that propagates into the final result.) Analogous advice applies in the
case of multiplication of a complex operand and a pure-imaginary
operand, and in the case of division of a complex operand by a real or
-pure-imaginary operand."
+pure-imaginary operand.”
@end quotation
Not followed.
@quotation
-"Similarly, because the usual mathematical meaning of addition of a
+“Similarly, because the usual mathematical meaning of addition of a
complex operand and a real operand is that the imaginary operand remains
unchanged, an implementation should not perform this operation by first
promoting the real operand to complex type and then performing a full
@@ -15325,14 +15526,14 @@ operand is a negatively signed zero. (Explicit addition of the negative
zero to the zero obtained during promotion yields a positive zero.)
Analogous advice applies in the case of addition of a complex operand
and a pure-imaginary operand, and in the case of subtraction of a
-complex operand and a real or pure-imaginary operand."
+complex operand and a real or pure-imaginary operand.”
@end quotation
Not followed.
@quotation
-"Implementations in which @code{Real'Signed_Zeros} is @code{True} should
+“Implementations in which @code{Real'Signed_Zeros} is @code{True} should
attempt to provide a rational treatment of the signs of zero results and
result components. As one example, the result of the @code{Argument}
function should have the sign of the imaginary component of the
@@ -15341,7 +15542,7 @@ the positive real axis; as another, the sign of the imaginary component
of the @code{Compose_From_Polar} function should be the same as
(respectively, the opposite of) that of the @code{Argument} parameter when that
parameter has a value of zero and the @code{Modulus} parameter has a
-nonnegative (respectively, negative) value."
+nonnegative (respectively, negative) value.”
@end quotation
Followed.
@@ -15349,13 +15550,13 @@ 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{255}
+@anchor{gnat_rm/implementation_advice rm-g-1-2-49-complex-elementary-functions}@anchor{254}
@section RM G.1.2(49): Complex Elementary Functions
@quotation
-"Implementations in which @code{Complex_Types.Real'Signed_Zeros} is
+“Implementations in which @code{Complex_Types.Real'Signed_Zeros} is
@code{True} should attempt to provide a rational treatment of the signs
of zero results and result components. For example, many of the complex
elementary functions have components that are odd functions of one of
@@ -15363,7 +15564,7 @@ the parameter components; in these cases, the result component should
have the sign of the parameter component at the origin. Other complex
elementary functions have zero components whose sign is opposite that of
a parameter component at the origin, or is always positive or always
-negative."
+negative.”
@end quotation
Followed.
@@ -15371,20 +15572,20 @@ 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{256}
+@anchor{gnat_rm/implementation_advice rm-g-2-4-19-accuracy-requirements}@anchor{255}
@section RM G.2.4(19): Accuracy Requirements
@quotation
-"The versions of the forward trigonometric functions without a
+“The versions of the forward trigonometric functions without a
@code{Cycle} parameter should not be implemented by calling the
corresponding version with a @code{Cycle} parameter of
@code{2.0*Numerics.Pi}, since this will not provide the required
accuracy in some portions of the domain. For the same reason, the
version of @code{Log} without a @code{Base} parameter should not be
implemented by calling the corresponding version with a @code{Base}
-parameter of @code{Numerics.e}."
+parameter of @code{Numerics.e}.”
@end quotation
Followed.
@@ -15395,17 +15596,17 @@ 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{257}
+@anchor{gnat_rm/implementation_advice rm-g-2-6-15-complex-arithmetic-accuracy}@anchor{256}
@section RM G.2.6(15): Complex Arithmetic Accuracy
@quotation
-"The version of the @code{Compose_From_Polar} function without a
+“The version of the @code{Compose_From_Polar} function without a
@code{Cycle} parameter should not be implemented by calling the
corresponding version with a @code{Cycle} parameter of
@code{2.0*Numerics.Pi}, since this will not provide the required
-accuracy in some portions of the domain."
+accuracy in some portions of the domain.”
@end quotation
Followed.
@@ -15413,22 +15614,22 @@ 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{258}
+@anchor{gnat_rm/implementation_advice rm-h-6-15-2-pragma-partition-elaboration-policy}@anchor{257}
@section RM H.6(15/2): Pragma Partition_Elaboration_Policy
@quotation
-"If the partition elaboration policy is @code{Sequential} and the
+“If the partition elaboration policy is @code{Sequential} and the
Environment task becomes permanently blocked during elaboration then the
partition is deadlocked and it is recommended that the partition be
-immediately terminated."
+immediately terminated.”
@end quotation
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{259}@anchor{gnat_rm/implementation_defined_characteristics id1}@anchor{25a}
+@anchor{gnat_rm/implementation_defined_characteristics doc}@anchor{258}@anchor{gnat_rm/implementation_defined_characteristics id1}@anchor{259}@anchor{gnat_rm/implementation_defined_characteristics implementation-defined-characteristics}@anchor{b}
@chapter Implementation Defined Characteristics
@@ -15453,8 +15654,8 @@ Reference Manual.
@itemize *
@item
-"Whether or not each recommendation given in Implementation
-Advice is followed. See 1.1.2(37)."
+“Whether or not each recommendation given in Implementation
+Advice is followed. See 1.1.2(37).”
@end itemize
See @ref{a,,Implementation Advice}.
@@ -15463,7 +15664,7 @@ See @ref{a,,Implementation Advice}.
@itemize *
@item
-"Capacity limitations of the implementation. See 1.1.3(3)."
+“Capacity limitations of the implementation. See 1.1.3(3).”
@end itemize
The complexity of programs that can be processed is limited only by the
@@ -15474,8 +15675,8 @@ generated object files.
@itemize *
@item
-"Variations from the standard that are impractical to avoid
-given the implementation's execution environment. See 1.1.3(6)."
+“Variations from the standard that are impractical to avoid
+given the implementation’s execution environment. See 1.1.3(6).”
@end itemize
There are no variations from the standard.
@@ -15484,8 +15685,8 @@ There are no variations from the standard.
@itemize *
@item
-"Which code_statements cause external
-interactions. See 1.1.3(10)."
+“Which code_statements cause external
+interactions. See 1.1.3(10).”
@end itemize
Any @emph{code_statement} can potentially cause external interactions.
@@ -15494,8 +15695,8 @@ Any @emph{code_statement} can potentially cause external interactions.
@itemize *
@item
-"The coded representation for the text of an Ada
-program. See 2.1(4)."
+“The coded representation for the text of an Ada
+program. See 2.1(4).”
@end itemize
See separate section on source representation.
@@ -15504,7 +15705,7 @@ See separate section on source representation.
@itemize *
@item
-"The control functions allowed in comments. See 2.1(14)."
+“The control functions allowed in comments. See 2.1(14).”
@end itemize
See separate section on source representation.
@@ -15513,7 +15714,7 @@ See separate section on source representation.
@itemize *
@item
-"The representation for an end of line. See 2.2(2)."
+“The representation for an end of line. See 2.2(2).”
@end itemize
See separate section on source representation.
@@ -15522,8 +15723,8 @@ See separate section on source representation.
@itemize *
@item
-"Maximum supported line length and lexical element
-length. See 2.2(15)."
+“Maximum supported line length and lexical element
+length. See 2.2(15).”
@end itemize
The maximum line length is 255 characters and the maximum length of
@@ -15537,7 +15738,7 @@ length of a lexical element is the same as the maximum line length.
@itemize *
@item
-"Implementation defined pragmas. See 2.8(14)."
+“Implementation defined pragmas. See 2.8(14).”
@end itemize
See @ref{7,,Implementation Defined Pragmas}.
@@ -15546,7 +15747,7 @@ See @ref{7,,Implementation Defined Pragmas}.
@itemize *
@item
-"Effect of pragma @code{Optimize}. See 2.8(27)."
+“Effect of pragma @code{Optimize}. See 2.8(27).”
@end itemize
Pragma @code{Optimize}, if given with a @code{Time} or @code{Space}
@@ -15557,10 +15758,10 @@ not.
@itemize *
@item
-"The sequence of characters of the value returned by
+“The sequence of characters of the value returned by
@code{S'Image} when some of the graphic characters of
@code{S'Wide_Image} are not defined in @code{Character}. See
-3.5(37)."
+3.5(37).”
@end itemize
The sequence of characters is as defined by the wide character encoding
@@ -15571,8 +15772,8 @@ further details.
@itemize *
@item
-"The predefined integer types declared in
-@code{Standard}. See 3.5.4(25)."
+“The predefined integer types declared in
+@code{Standard}. See 3.5.4(25).”
@end itemize
@@ -15643,8 +15844,8 @@ depending on the C definition of long)
@itemize *
@item
-"Any nonstandard integer types and the operators defined
-for them. See 3.5.4(26)."
+“Any nonstandard integer types and the operators defined
+for them. See 3.5.4(26).”
@end itemize
There are no nonstandard integer types.
@@ -15653,8 +15854,8 @@ There are no nonstandard integer types.
@itemize *
@item
-"Any nonstandard real types and the operators defined for
-them. See 3.5.6(8)."
+“Any nonstandard real types and the operators defined for
+them. See 3.5.6(8).”
@end itemize
There are no nonstandard real types.
@@ -15663,22 +15864,23 @@ There are no nonstandard real types.
@itemize *
@item
-"What combinations of requested decimal precision and range
-are supported for floating point types. See 3.5.7(7)."
+“What combinations of requested decimal precision and range
+are supported for floating point types. See 3.5.7(7).”
@end itemize
-The precision and range is as defined by the IEEE standard.
+The precision and range are defined by the IEEE Standard for Floating-Point
+Arithmetic (IEEE 754-2019).
@itemize *
@item
-"The predefined floating point types declared in
-@code{Standard}. See 3.5.7(16)."
+“The predefined floating point types declared in
+@code{Standard}. See 3.5.7(16).”
@end itemize
-@multitable {xxxxxxxxxxxxxxxxxxxxxxxx} {xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx}
+@multitable {xxxxxxxxxxxxxxxxxxxxxxxx} {xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx}
@headitem
Type
@@ -15693,7 +15895,7 @@ Representation
@tab
-32 bit IEEE short
+IEEE Binary32 (Single)
@item
@@ -15701,7 +15903,7 @@ Representation
@tab
-(Short) 32 bit IEEE short
+IEEE Binary32 (Single)
@item
@@ -15709,7 +15911,7 @@ Representation
@tab
-64 bit IEEE long
+IEEE Binary64 (Double)
@item
@@ -15717,16 +15919,24 @@ Representation
@tab
-64 bit IEEE long (80 bit IEEE long on x86 processors)
+IEEE Binary64 (Double) on non-x86 architectures
+IEEE 80-bit Extended on x86 architecture
@end multitable
+The default rounding mode specified by the IEEE 754 Standard is assumed for
+static computations, i.e. round to nearest, ties to even. The input routines
+yield correctly rounded values for Short_Float, Float and Long_Float at least.
+The output routines can compute up to twice as many exact digits as the value
+of @code{T'Digits} for any type, for example 30 digits for Long_Float; if more
+digits are requested, zeros are printed.
+
@itemize *
@item
-"The small of an ordinary fixed point type. See 3.5.9(8)."
+“The small of an ordinary fixed point type. See 3.5.9(8).”
@end itemize
The small is the largest power of two that does not exceed the delta.
@@ -15735,8 +15945,8 @@ The small is the largest power of two that does not exceed the delta.
@itemize *
@item
-"What combinations of small, range, and digits are
-supported for fixed point types. See 3.5.9(10)."
+“What combinations of small, range, and digits are
+supported for fixed point types. See 3.5.9(10).”
@end itemize
For an ordinary fixed point type, on 32-bit platforms, the small must lie in
@@ -15765,8 +15975,8 @@ small must lie in 1.0E-38 .. 1.0E+38 and the digits in 1 .. 38.
@itemize *
@item
-"The result of @code{Tags.Expanded_Name} for types declared
-within an unnamed @emph{block_statement}. See 3.9(10)."
+“The result of @code{Tags.Expanded_Name} for types declared
+within an unnamed @emph{block_statement}. See 3.9(10).”
@end itemize
Block numbers of the form @code{B@emph{nnn}}, where @emph{nnn} is a
@@ -15776,7 +15986,7 @@ decimal integer are allocated.
@itemize *
@item
-"Implementation-defined attributes. See 4.1.4(12)."
+“Implementation-defined attributes. See 4.1.4(12).”
@end itemize
See @ref{8,,Implementation Defined Attributes}.
@@ -15785,7 +15995,7 @@ See @ref{8,,Implementation Defined Attributes}.
@itemize *
@item
-"Any implementation-defined time types. See 9.6(6)."
+“Any implementation-defined time types. See 9.6(6).”
@end itemize
There are no implementation-defined time types.
@@ -15794,7 +16004,7 @@ There are no implementation-defined time types.
@itemize *
@item
-"The time base associated with relative delays."
+“The time base associated with relative delays.”
@end itemize
See 9.6(20). The time base used is that provided by the C library
@@ -15804,8 +16014,8 @@ function @code{gettimeofday}.
@itemize *
@item
-"The time base of the type @code{Calendar.Time}. See
-9.6(23)."
+“The time base of the type @code{Calendar.Time}. See
+9.6(23).”
@end itemize
The time base used is that provided by the C library function
@@ -15815,8 +16025,8 @@ The time base used is that provided by the C library function
@itemize *
@item
-"The time zone used for package @code{Calendar}
-operations. See 9.6(24)."
+“The time zone used for package @code{Calendar}
+operations. See 9.6(24).”
@end itemize
The time zone used by package @code{Calendar} is the current system time zone
@@ -15827,8 +16037,8 @@ setting for local time, as accessed by the C library function
@itemize *
@item
-"Any limit on @emph{delay_until_statements} of
-@emph{select_statements}. See 9.6(29)."
+“Any limit on @emph{delay_until_statements} of
+@emph{select_statements}. See 9.6(29).”
@end itemize
There are no such limits.
@@ -15837,10 +16047,10 @@ There are no such limits.
@itemize *
@item
-"Whether or not two non-overlapping parts of a composite
+“Whether or not two non-overlapping parts of a composite
object are independently addressable, in the case where packing, record
layout, or @code{Component_Size} is specified for the object. See
-9.10(1)."
+9.10(1).”
@end itemize
Separate components are independently addressable if they do not share
@@ -15850,7 +16060,7 @@ overlapping storage units.
@itemize *
@item
-"The representation for a compilation. See 10.1(2)."
+“The representation for a compilation. See 10.1(2).”
@end itemize
A compilation is represented by a sequence of files presented to the
@@ -15860,8 +16070,8 @@ compiler in a single invocation of the @emph{gcc} command.
@itemize *
@item
-"Any restrictions on compilations that contain multiple
-compilation_units. See 10.1(4)."
+“Any restrictions on compilations that contain multiple
+compilation_units. See 10.1(4).”
@end itemize
No single file can contain more than one compilation unit, but any
@@ -15872,8 +16082,8 @@ compilation.
@itemize *
@item
-"The mechanisms for creating an environment and for adding
-and replacing compilation units. See 10.1.4(3)."
+“The mechanisms for creating an environment and for adding
+and replacing compilation units. See 10.1.4(3).”
@end itemize
See separate section on compilation model.
@@ -15882,8 +16092,8 @@ See separate section on compilation model.
@itemize *
@item
-"The manner of explicitly assigning library units to a
-partition. See 10.2(2)."
+“The manner of explicitly assigning library units to a
+partition. See 10.2(2).”
@end itemize
If a unit contains an Ada main program, then the Ada units for the partition
@@ -15903,15 +16113,15 @@ this case a list of units can be explicitly supplied to the binder for
inclusion in the partition (all units needed by these units will also
be included automatically). For full details on the use of these
options, refer to @emph{GNAT Make Program gnatmake} in the
-@cite{GNAT User's Guide}.
+@cite{GNAT User’s Guide}.
@itemize *
@item
-"The implementation-defined means, if any, of specifying
+“The implementation-defined means, if any, of specifying
which compilation units are needed by a given compilation unit. See
-10.2(2)."
+10.2(2).”
@end itemize
The units needed by a given compilation unit are as defined in
@@ -15923,8 +16133,8 @@ means for specifying needed units.
@itemize *
@item
-"The manner of designating the main subprogram of a
-partition. See 10.2(7)."
+“The manner of designating the main subprogram of a
+partition. See 10.2(7).”
@end itemize
The main program is designated by providing the name of the
@@ -15934,8 +16144,8 @@ corresponding @code{ALI} file as the input parameter to the binder.
@itemize *
@item
-"The order of elaboration of @emph{library_items}. See
-10.2(18)."
+“The order of elaboration of @emph{library_items}. See
+10.2(18).”
@end itemize
The first constraint on ordering is that it meets the requirements of
@@ -15951,8 +16161,8 @@ where a choice still remains.
@itemize *
@item
-"Parameter passing and function return for the main
-subprogram. See 10.2(21)."
+“Parameter passing and function return for the main
+subprogram. See 10.2(21).”
@end itemize
The main program has no parameters. It may be a procedure, or a function
@@ -15964,8 +16174,8 @@ may have been set by a call to @code{Ada.Command_Line.Set_Exit_Status}).
@itemize *
@item
-"The mechanisms for building and running partitions. See
-10.2(24)."
+“The mechanisms for building and running partitions. See
+10.2(24).”
@end itemize
GNAT itself supports programs with only a single partition. The GNATDIST
@@ -15978,8 +16188,8 @@ for details.
@itemize *
@item
-"The details of program execution, including program
-termination. See 10.2(25)."
+“The details of program execution, including program
+termination. See 10.2(25).”
@end itemize
See separate section on compilation model.
@@ -15988,8 +16198,8 @@ See separate section on compilation model.
@itemize *
@item
-"The semantics of any non-active partitions supported by the
-implementation. See 10.2(28)."
+“The semantics of any non-active partitions supported by the
+implementation. See 10.2(28).”
@end itemize
Passive partitions are supported on targets where shared memory is
@@ -16000,8 +16210,8 @@ further details.
@itemize *
@item
-"The information returned by @code{Exception_Message}. See
-11.4.1(10)."
+“The information returned by @code{Exception_Message}. See
+11.4.1(10).”
@end itemize
Exception message returns the null string unless a specific message has
@@ -16011,8 +16221,8 @@ been passed by the program.
@itemize *
@item
-"The result of @code{Exceptions.Exception_Name} for types
-declared within an unnamed @emph{block_statement}. See 11.4.1(12)."
+“The result of @code{Exceptions.Exception_Name} for types
+declared within an unnamed @emph{block_statement}. See 11.4.1(12).”
@end itemize
Blocks have implementation defined names of the form @code{B@emph{nnn}}
@@ -16022,8 +16232,8 @@ where @emph{nnn} is an integer.
@itemize *
@item
-"The information returned by
-@code{Exception_Information}. See 11.4.1(13)."
+“The information returned by
+@code{Exception_Information}. See 11.4.1(13).”
@end itemize
@code{Exception_Information} returns a string in the following format:
@@ -16060,7 +16270,7 @@ not making use of this field.
The Load address line, the Call stack traceback locations line and the
following values are present only if at least one traceback location was
recorded. The Load address indicates the address at which the main executable
-was loaded; this line may not be present if operating system hasn't relocated
+was loaded; this line may not be present if operating system hasn’t relocated
the main executable. The values are given in C style format, with lower case
letters for a-f, and only as many digits present as are necessary.
The line terminator sequence at the end of each line, including
@@ -16072,7 +16282,7 @@ the last line is a single @code{LF} character (@code{16#0A#}).
@itemize *
@item
-"Implementation-defined check names. See 11.5(27)."
+“Implementation-defined check names. See 11.5(27).”
@end itemize
The implementation defined check names include Alignment_Check,
@@ -16085,8 +16295,8 @@ Check_Name. See the description of pragma @code{Suppress} for full details.
@itemize *
@item
-"The interpretation of each aspect of representation. See
-13.1(20)."
+“The interpretation of each aspect of representation. See
+13.1(20).”
@end itemize
See separate section on data representations.
@@ -16095,8 +16305,8 @@ See separate section on data representations.
@itemize *
@item
-"Any restrictions placed upon representation items. See
-13.1(20)."
+“Any restrictions placed upon representation items. See
+13.1(20).”
@end itemize
See separate section on data representations.
@@ -16105,8 +16315,8 @@ See separate section on data representations.
@itemize *
@item
-"The meaning of @code{Size} for indefinite subtypes. See
-13.3(48)."
+“The meaning of @code{Size} for indefinite subtypes. See
+13.3(48).”
@end itemize
Size for an indefinite subtype is the maximum possible size, except that
@@ -16117,8 +16327,8 @@ is the actual size.
@itemize *
@item
-"The default external representation for a type tag. See
-13.3(75)."
+“The default external representation for a type tag. See
+13.3(75).”
@end itemize
The default external representation for a type tag is the fully expanded
@@ -16128,8 +16338,8 @@ name of the type in upper case letters.
@itemize *
@item
-"What determines whether a compilation unit is the same in
-two different partitions. See 13.3(76)."
+“What determines whether a compilation unit is the same in
+two different partitions. See 13.3(76).”
@end itemize
A compilation unit is the same in two different partitions if and only
@@ -16139,7 +16349,7 @@ if it derives from the same source file.
@itemize *
@item
-"Implementation-defined components. See 13.5.1(15)."
+“Implementation-defined components. See 13.5.1(15).”
@end itemize
The only implementation defined component is the tag for a tagged type,
@@ -16149,8 +16359,8 @@ which contains a pointer to the dispatching table.
@itemize *
@item
-"If @code{Word_Size} = @code{Storage_Unit}, the default bit
-ordering. See 13.5.3(5)."
+“If @code{Word_Size} = @code{Storage_Unit}, the default bit
+ordering. See 13.5.3(5).”
@end itemize
@code{Word_Size} (32) is not the same as @code{Storage_Unit} (8) for this
@@ -16161,8 +16371,8 @@ bit ordering corresponds to the natural endianness of the target architecture.
@itemize *
@item
-"The contents of the visible part of package @code{System}
-and its language-defined children. See 13.7(2)."
+“The contents of the visible part of package @code{System}
+and its language-defined children. See 13.7(2).”
@end itemize
See the definition of these packages in files @code{system.ads} and
@@ -16178,9 +16388,9 @@ Max_Interrupt_Priority : constant Positive := Interrupt_Priority'Last;
@itemize *
@item
-"The contents of the visible part of package
+“The contents of the visible part of package
@code{System.Machine_Code}, and the meaning of
-@emph{code_statements}. See 13.8(7)."
+@emph{code_statements}. See 13.8(7).”
@end itemize
See the definition and documentation in file @code{s-maccod.ads}.
@@ -16189,7 +16399,7 @@ See the definition and documentation in file @code{s-maccod.ads}.
@itemize *
@item
-"The effect of unchecked conversion. See 13.9(11)."
+“The effect of unchecked conversion. See 13.9(11).”
@end itemize
Unchecked conversion between types of the same size
@@ -16210,8 +16420,8 @@ made with appropriate alignment
@itemize *
@item
-"The semantics of operations on invalid representations.
-See 13.9.2(10-11)."
+“The semantics of operations on invalid representations.
+See 13.9.2(10-11).”
@end itemize
For assignments and other operations where the use of invalid values cannot
@@ -16239,8 +16449,8 @@ on the simple assignment of the invalid negative value from Y to Z.
@itemize *
@item
-"The manner of choosing a storage pool for an access type
-when @code{Storage_Pool} is not specified for the type. See 13.11(17)."
+“The manner of choosing a storage pool for an access type
+when @code{Storage_Pool} is not specified for the type. See 13.11(17).”
@end itemize
There are 3 different standard pools used by the compiler when
@@ -16256,8 +16466,8 @@ default pools used.
@itemize *
@item
-"Whether or not the implementation provides user-accessible
-names for the standard pool type(s). See 13.11(17)."
+“Whether or not the implementation provides user-accessible
+names for the standard pool type(s). See 13.11(17).”
@end itemize
See documentation in the sources of the run time mentioned in the previous
@@ -16268,7 +16478,7 @@ these units.
@itemize *
@item
-"The meaning of @code{Storage_Size}. See 13.11(18)."
+“The meaning of @code{Storage_Size}. See 13.11(18).”
@end itemize
@code{Storage_Size} is measured in storage units, and refers to the
@@ -16279,8 +16489,8 @@ stack space for a task.
@itemize *
@item
-"Implementation-defined aspects of storage pools. See
-13.11(22)."
+“Implementation-defined aspects of storage pools. See
+13.11(22).”
@end itemize
See documentation in the sources of the run time mentioned in the
@@ -16291,8 +16501,8 @@ for details on GNAT-defined aspects of storage pools.
@itemize *
@item
-"The set of restrictions allowed in a pragma
-@code{Restrictions}. See 13.12(7)."
+“The set of restrictions allowed in a pragma
+@code{Restrictions}. See 13.12(7).”
@end itemize
See @ref{9,,Standard and Implementation Defined Restrictions}.
@@ -16301,8 +16511,8 @@ See @ref{9,,Standard and Implementation Defined Restrictions}.
@itemize *
@item
-"The consequences of violating limitations on
-@code{Restrictions} pragmas. See 13.12(9)."
+“The consequences of violating limitations on
+@code{Restrictions} pragmas. See 13.12(9).”
@end itemize
Restrictions that can be checked at compile time result in illegalities
@@ -16313,9 +16523,9 @@ restrictions.
@itemize *
@item
-"The representation used by the @code{Read} and
+“The representation used by the @code{Read} and
@code{Write} attributes of elementary types in terms of stream
-elements. See 13.13.2(9)."
+elements. See 13.13.2(9).”
@end itemize
The representation is the in-memory representation of the base type of
@@ -16326,8 +16536,8 @@ the type, using the number of bits corresponding to the
@itemize *
@item
-"The names and characteristics of the numeric subtypes
-declared in the visible part of package @code{Standard}. See A.1(3)."
+“The names and characteristics of the numeric subtypes
+declared in the visible part of package @code{Standard}. See A.1(3).”
@end itemize
See items describing the integer and floating-point types supported.
@@ -16336,20 +16546,20 @@ See items describing the integer and floating-point types supported.
@itemize *
@item
-"The string returned by @code{Character_Set_Version}.
-See A.3.5(3)."
+“The string returned by @code{Character_Set_Version}.
+See A.3.5(3).”
@end itemize
@code{Ada.Wide_Characters.Handling.Character_Set_Version} returns
-the string "Unicode 4.0", referring to version 4.0 of the
+the string “Unicode 4.0”, referring to version 4.0 of the
Unicode specification.
@itemize *
@item
-"The accuracy actually achieved by the elementary
-functions. See A.5.1(1)."
+“The accuracy actually achieved by the elementary
+functions. See A.5.1(1).”
@end itemize
The elementary functions correspond to the functions available in the C
@@ -16359,9 +16569,9 @@ library. Only fast math mode is implemented.
@itemize *
@item
-"The sign of a zero result from some of the operators or
+“The sign of a zero result from some of the operators or
functions in @code{Numerics.Generic_Elementary_Functions}, when
-@code{Float_Type'Signed_Zeros} is @code{True}. See A.5.1(46)."
+@code{Float_Type'Signed_Zeros} is @code{True}. See A.5.1(46).”
@end itemize
The sign of zeroes follows the requirements of the IEEE 754 standard on
@@ -16371,8 +16581,8 @@ floating-point.
@itemize *
@item
-"The value of
-@code{Numerics.Float_Random.Max_Image_Width}. See A.5.2(27)."
+“The value of
+@code{Numerics.Float_Random.Max_Image_Width}. See A.5.2(27).”
@end itemize
Maximum image width is 6864, see library file @code{s-rannum.ads}.
@@ -16381,8 +16591,8 @@ Maximum image width is 6864, see library file @code{s-rannum.ads}.
@itemize *
@item
-"The value of
-@code{Numerics.Discrete_Random.Max_Image_Width}. See A.5.2(27)."
+“The value of
+@code{Numerics.Discrete_Random.Max_Image_Width}. See A.5.2(27).”
@end itemize
Maximum image width is 6864, see library file @code{s-rannum.ads}.
@@ -16391,8 +16601,8 @@ Maximum image width is 6864, see library file @code{s-rannum.ads}.
@itemize *
@item
-"The algorithms for random number generation. See
-A.5.2(32)."
+“The algorithms for random number generation. See
+A.5.2(32).”
@end itemize
The algorithm is the Mersenne Twister, as documented in the source file
@@ -16403,8 +16613,8 @@ The algorithm is the Mersenne Twister, as documented in the source file
@itemize *
@item
-"The string representation of a random number generator's
-state. See A.5.2(38)."
+“The string representation of a random number generator’s
+state. See A.5.2(38).”
@end itemize
The value returned by the Image function is the concatenation of
@@ -16415,9 +16625,9 @@ of the state vector.
@itemize *
@item
-"The minimum time interval between calls to the
+“The minimum time interval between calls to the
time-dependent Reset procedure that are guaranteed to initiate different
-random number sequences. See A.5.2(45)."
+random number sequences. See A.5.2(45).”
@end itemize
The minimum period between reset calls to guarantee distinct series of
@@ -16427,10 +16637,10 @@ random numbers is one microsecond.
@itemize *
@item
-"The values of the @code{Model_Mantissa},
+“The values of the @code{Model_Mantissa},
@code{Model_Emin}, @code{Model_Epsilon}, @code{Model},
@code{Safe_First}, and @code{Safe_Last} attributes, if the Numerics
-Annex is not supported. See A.5.3(72)."
+Annex is not supported. See A.5.3(72).”
@end itemize
Run the compiler with @emph{-gnatS} to produce a listing of package
@@ -16440,8 +16650,8 @@ Run the compiler with @emph{-gnatS} to produce a listing of package
@itemize *
@item
-"Any implementation-defined characteristics of the
-input-output packages. See A.7(14)."
+“Any implementation-defined characteristics of the
+input-output packages. See A.7(14).”
@end itemize
There are no special implementation defined characteristics for these
@@ -16451,8 +16661,8 @@ packages.
@itemize *
@item
-"The value of @code{Buffer_Size} in @code{Storage_IO}. See
-A.9(10)."
+“The value of @code{Buffer_Size} in @code{Storage_IO}. See
+A.9(10).”
@end itemize
All type representations are contiguous, and the @code{Buffer_Size} is
@@ -16463,8 +16673,8 @@ boundary.
@itemize *
@item
-"External files for standard input, standard output, and
-standard error See A.10(5)."
+“External files for standard input, standard output, and
+standard error See A.10(5).”
@end itemize
These files are mapped onto the files provided by the C streams
@@ -16474,8 +16684,8 @@ libraries. See source file @code{i-cstrea.ads} for further details.
@itemize *
@item
-"The accuracy of the value produced by @code{Put}. See
-A.10.9(36)."
+“The accuracy of the value produced by @code{Put}. See
+A.10.9(36).”
@end itemize
If more digits are requested in the output than are represented by the
@@ -16486,8 +16696,8 @@ significant digit positions.
@itemize *
@item
-"The meaning of @code{Argument_Count}, @code{Argument}, and
-@code{Command_Name}. See A.15(1)."
+“The meaning of @code{Argument_Count}, @code{Argument}, and
+@code{Command_Name}. See A.15(1).”
@end itemize
These are mapped onto the @code{argv} and @code{argc} parameters of the
@@ -16497,8 +16707,8 @@ main program in the natural manner.
@itemize *
@item
-"The interpretation of the @code{Form} parameter in procedure
-@code{Create_Directory}. See A.16(56)."
+“The interpretation of the @code{Form} parameter in procedure
+@code{Create_Directory}. See A.16(56).”
@end itemize
The @code{Form} parameter is not used.
@@ -16507,8 +16717,8 @@ The @code{Form} parameter is not used.
@itemize *
@item
-"The interpretation of the @code{Form} parameter in procedure
-@code{Create_Path}. See A.16(60)."
+“The interpretation of the @code{Form} parameter in procedure
+@code{Create_Path}. See A.16(60).”
@end itemize
The @code{Form} parameter is not used.
@@ -16517,8 +16727,8 @@ The @code{Form} parameter is not used.
@itemize *
@item
-"The interpretation of the @code{Form} parameter in procedure
-@code{Copy_File}. See A.16(68)."
+“The interpretation of the @code{Form} parameter in procedure
+@code{Copy_File}. See A.16(68).”
@end itemize
The @code{Form} parameter is case-insensitive.
@@ -16529,8 +16739,8 @@ Two fields are recognized in the @code{Form} parameter:
*mode=<value>*
@end example
-<value> starts immediately after the character '=' and ends with the
-character immediately preceding the next comma (',') or with the last
+<value> starts immediately after the character ‘=’ and ends with the
+character immediately preceding the next comma (‘,’) or with the last
character of the parameter.
The only possible values for preserve= are:
@@ -16638,22 +16848,22 @@ Form => "mode=internal, preserve=timestamps"
@itemize *
@item
-"The interpretation of the @code{Pattern} parameter, when not the null string,
+“The interpretation of the @code{Pattern} parameter, when not the null string,
in the @code{Start_Search} and @code{Search} procedures.
-See A.16(104) and A.16(112)."
+See A.16(104) and A.16(112).”
@end itemize
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{25b,,GNAT.Regexp (g-regexp.ads)}.
+See @ref{25a,,GNAT.Regexp (g-regexp.ads)}.
@itemize *
@item
-"Implementation-defined convention names. See B.1(11)."
+“Implementation-defined convention names. See B.1(11).”
@end itemize
The following convention names are supported
@@ -16836,7 +17046,7 @@ use of such other names results in a warning.
@itemize *
@item
-"The meaning of link names. See B.1(36)."
+“The meaning of link names. See B.1(36).”
@end itemize
Link names are the actual names used by the linker.
@@ -16845,9 +17055,9 @@ Link names are the actual names used by the linker.
@itemize *
@item
-"The manner of choosing link names when neither the link
+“The manner of choosing link names when neither the link
name nor the address of an imported or exported entity is specified. See
-B.1(36)."
+B.1(36).”
@end itemize
The default linker name is that which would be assigned by the relevant
@@ -16858,7 +17068,7 @@ letters.
@itemize *
@item
-"The effect of pragma @code{Linker_Options}. See B.1(37)."
+“The effect of pragma @code{Linker_Options}. See B.1(37).”
@end itemize
The string passed to @code{Linker_Options} is presented uninterpreted as
@@ -16879,8 +17089,8 @@ from the corresponding package spec.
@itemize *
@item
-"The contents of the visible part of package
-@code{Interfaces} and its language-defined descendants. See B.2(1)."
+“The contents of the visible part of package
+@code{Interfaces} and its language-defined descendants. See B.2(1).”
@end itemize
See files with prefix @code{i-} in the distributed library.
@@ -16889,9 +17099,9 @@ See files with prefix @code{i-} in the distributed library.
@itemize *
@item
-"Implementation-defined children of package
+“Implementation-defined children of package
@code{Interfaces}. The contents of the visible part of package
-@code{Interfaces}. See B.2(11)."
+@code{Interfaces}. See B.2(11).”
@end itemize
See files with prefix @code{i-} in the distributed library.
@@ -16900,11 +17110,11 @@ See files with prefix @code{i-} in the distributed library.
@itemize *
@item
-"The types @code{Floating}, @code{Long_Floating},
+“The types @code{Floating}, @code{Long_Floating},
@code{Binary}, @code{Long_Binary}, @code{Decimal_ Element}, and
@code{COBOL_Character}; and the initialization of the variables
@code{Ada_To_COBOL} and @code{COBOL_To_Ada}, in
-@code{Interfaces.COBOL}. See B.4(50)."
+@code{Interfaces.COBOL}. See B.4(50).”
@end itemize
@@ -16974,7 +17184,7 @@ For initialization, see the file @code{i-cobol.ads} in the distributed library.
@itemize *
@item
-"Support for access to machine instructions. See C.1(1)."
+“Support for access to machine instructions. See C.1(1).”
@end itemize
See documentation in file @code{s-maccod.ads} in the distributed library.
@@ -16983,8 +17193,8 @@ See documentation in file @code{s-maccod.ads} in the distributed library.
@itemize *
@item
-"Implementation-defined aspects of access to machine
-operations. See C.1(9)."
+“Implementation-defined aspects of access to machine
+operations. See C.1(9).”
@end itemize
See documentation in file @code{s-maccod.ads} in the distributed library.
@@ -16993,7 +17203,7 @@ See documentation in file @code{s-maccod.ads} in the distributed library.
@itemize *
@item
-"Implementation-defined aspects of interrupts. See C.3(2)."
+“Implementation-defined aspects of interrupts. See C.3(2).”
@end itemize
Interrupts are mapped to signals or conditions as appropriate. See
@@ -17005,8 +17215,8 @@ on the interrupts supported on a particular target.
@itemize *
@item
-"Implementation-defined aspects of pre-elaboration. See
-C.4(13)."
+“Implementation-defined aspects of pre-elaboration. See
+C.4(13).”
@end itemize
GNAT does not permit a partition to be restarted without reloading,
@@ -17016,7 +17226,7 @@ except under control of the debugger.
@itemize *
@item
-"The semantics of pragma @code{Discard_Names}. See C.5(7)."
+“The semantics of pragma @code{Discard_Names}. See C.5(7).”
@end itemize
Pragma @code{Discard_Names} causes names of enumeration literals to
@@ -17033,8 +17243,8 @@ level.
@itemize *
@item
-"The result of the @code{Task_Identification.Image}
-attribute. See C.7.1(7)."
+“The result of the @code{Task_Identification.Image}
+attribute. See C.7.1(7).”
@end itemize
The result of this attribute is a string that identifies
@@ -17065,8 +17275,8 @@ virtual address of the control block of the task.
@itemize *
@item
-"The value of @code{Current_Task} when in a protected entry
-or interrupt handler. See C.7.1(17)."
+“The value of @code{Current_Task} when in a protected entry
+or interrupt handler. See C.7.1(17).”
@end itemize
Protected entries or interrupt handlers can be executed by any
@@ -17076,8 +17286,8 @@ convenient thread, so the value of @code{Current_Task} is undefined.
@itemize *
@item
-"The effect of calling @code{Current_Task} from an entry
-body or interrupt handler. See C.7.1(19)."
+“The effect of calling @code{Current_Task} from an entry
+body or interrupt handler. See C.7.1(19).”
@end itemize
When GNAT can determine statically that @code{Current_Task} is called directly in
@@ -17090,8 +17300,8 @@ currently executing the code.
@itemize *
@item
-"Implementation-defined aspects of
-@code{Task_Attributes}. See C.7.2(19)."
+“Implementation-defined aspects of
+@code{Task_Attributes}. See C.7.2(19).”
@end itemize
There are no implementation-defined aspects of @code{Task_Attributes}.
@@ -17100,7 +17310,7 @@ There are no implementation-defined aspects of @code{Task_Attributes}.
@itemize *
@item
-"Values of all @code{Metrics}. See D(2)."
+“Values of all @code{Metrics}. See D(2).”
@end itemize
The metrics information for GNAT depends on the performance of the
@@ -17116,8 +17326,8 @@ the required metrics.
@itemize *
@item
-"The declarations of @code{Any_Priority} and
-@code{Priority}. See D.1(11)."
+“The declarations of @code{Any_Priority} and
+@code{Priority}. See D.1(11).”
@end itemize
See declarations in file @code{system.ads}.
@@ -17126,7 +17336,7 @@ See declarations in file @code{system.ads}.
@itemize *
@item
-"Implementation-defined execution resources. See D.1(15)."
+“Implementation-defined execution resources. See D.1(15).”
@end itemize
There are no implementation-defined execution resources.
@@ -17135,8 +17345,8 @@ There are no implementation-defined execution resources.
@itemize *
@item
-"Whether, on a multiprocessor, a task that is waiting for
-access to a protected object keeps its processor busy. See D.2.1(3)."
+“Whether, on a multiprocessor, a task that is waiting for
+access to a protected object keeps its processor busy. See D.2.1(3).”
@end itemize
On a multi-processor, a task that is waiting for access to a protected
@@ -17146,8 +17356,8 @@ object does not keep its processor busy.
@itemize *
@item
-"The affect of implementation defined execution resources
-on task dispatching. See D.2.1(9)."
+“The affect of implementation defined execution resources
+on task dispatching. See D.2.1(9).”
@end itemize
Tasks map to threads in the threads package used by GNAT. Where possible
@@ -17158,8 +17368,8 @@ underlying operating system.
@itemize *
@item
-"Implementation-defined @emph{policy_identifiers} allowed
-in a pragma @code{Task_Dispatching_Policy}. See D.2.2(3)."
+“Implementation-defined @emph{policy_identifiers} allowed
+in a pragma @code{Task_Dispatching_Policy}. See D.2.2(3).”
@end itemize
There are no implementation-defined policy-identifiers allowed in this
@@ -17169,8 +17379,8 @@ pragma.
@itemize *
@item
-"Implementation-defined aspects of priority inversion. See
-D.2.2(16)."
+“Implementation-defined aspects of priority inversion. See
+D.2.2(16).”
@end itemize
Execution of a task cannot be preempted by the implementation processing
@@ -17180,7 +17390,7 @@ of delay expirations for lower priority tasks.
@itemize *
@item
-"Implementation-defined task dispatching. See D.2.2(18)."
+“Implementation-defined task dispatching. See D.2.2(18).”
@end itemize
The policy is the same as that of the underlying threads implementation.
@@ -17189,8 +17399,8 @@ The policy is the same as that of the underlying threads implementation.
@itemize *
@item
-"Implementation-defined @emph{policy_identifiers} allowed
-in a pragma @code{Locking_Policy}. See D.3(4)."
+“Implementation-defined @emph{policy_identifiers} allowed
+in a pragma @code{Locking_Policy}. See D.3(4).”
@end itemize
The two implementation defined policies permitted in GNAT are
@@ -17207,7 +17417,7 @@ concurrently.
@itemize *
@item
-"Default ceiling priorities. See D.3(10)."
+“Default ceiling priorities. See D.3(10).”
@end itemize
The ceiling priority of protected objects of the type
@@ -17218,8 +17428,8 @@ Reference Manual D.3(10),
@itemize *
@item
-"The ceiling of any protected object used internally by
-the implementation. See D.3(16)."
+“The ceiling of any protected object used internally by
+the implementation. See D.3(16).”
@end itemize
The ceiling priority of internal protected objects is
@@ -17229,7 +17439,7 @@ The ceiling priority of internal protected objects is
@itemize *
@item
-"Implementation-defined queuing policies. See D.4(1)."
+“Implementation-defined queuing policies. See D.4(1).”
@end itemize
There are no implementation-defined queuing policies.
@@ -17238,9 +17448,9 @@ There are no implementation-defined queuing policies.
@itemize *
@item
-"On a multiprocessor, any conditions that cause the
+“On a multiprocessor, any conditions that cause the
completion of an aborted construct to be delayed later than what is
-specified for a single processor. See D.6(3)."
+specified for a single processor. See D.6(3).”
@end itemize
The semantics for abort on a multi-processor is the same as on a single
@@ -17250,8 +17460,8 @@ processor, there are no further delays.
@itemize *
@item
-"Any operations that implicitly require heap storage
-allocation. See D.7(8)."
+“Any operations that implicitly require heap storage
+allocation. See D.7(8).”
@end itemize
The only operation that implicitly requires heap storage allocation is
@@ -17261,8 +17471,8 @@ task creation.
@itemize *
@item
-"What happens when a task terminates in the presence of
-pragma @code{No_Task_Termination}. See D.7(15)."
+“What happens when a task terminates in the presence of
+pragma @code{No_Task_Termination}. See D.7(15).”
@end itemize
Execution is erroneous in that case.
@@ -17271,8 +17481,8 @@ Execution is erroneous in that case.
@itemize *
@item
-"Implementation-defined aspects of pragma
-@code{Restrictions}. See D.7(20)."
+“Implementation-defined aspects of pragma
+@code{Restrictions}. See D.7(20).”
@end itemize
There are no such implementation-defined aspects.
@@ -17281,8 +17491,8 @@ There are no such implementation-defined aspects.
@itemize *
@item
-"Implementation-defined aspects of package
-@code{Real_Time}. See D.8(17)."
+“Implementation-defined aspects of package
+@code{Real_Time}. See D.8(17).”
@end itemize
There are no implementation defined aspects of package @code{Real_Time}.
@@ -17291,8 +17501,8 @@ There are no implementation defined aspects of package @code{Real_Time}.
@itemize *
@item
-"Implementation-defined aspects of
-@emph{delay_statements}. See D.9(8)."
+“Implementation-defined aspects of
+@emph{delay_statements}. See D.9(8).”
@end itemize
Any difference greater than one microsecond will cause the task to be
@@ -17302,8 +17512,8 @@ delayed (see D.9(7)).
@itemize *
@item
-"The upper bound on the duration of interrupt blocking
-caused by the implementation. See D.12(5)."
+“The upper bound on the duration of interrupt blocking
+caused by the implementation. See D.12(5).”
@end itemize
The upper bound is determined by the underlying operating system. In
@@ -17313,8 +17523,8 @@ no cases is it more than 10 milliseconds.
@itemize *
@item
-"The means for creating and executing distributed
-programs. See E(5)."
+“The means for creating and executing distributed
+programs. See E(5).”
@end itemize
The GLADE package provides a utility GNATDIST for creating and executing
@@ -17324,8 +17534,8 @@ distributed programs. See the GLADE reference manual for further details.
@itemize *
@item
-"Any events that can result in a partition becoming
-inaccessible. See E.1(7)."
+“Any events that can result in a partition becoming
+inaccessible. See E.1(7).”
@end itemize
See the GLADE reference manual for full details on such events.
@@ -17334,9 +17544,9 @@ See the GLADE reference manual for full details on such events.
@itemize *
@item
-"The scheduling policies, treatment of priorities, and
+“The scheduling policies, treatment of priorities, and
management of shared resources between partitions in certain cases. See
-E.1(11)."
+E.1(11).”
@end itemize
See the GLADE reference manual for full details on these aspects of
@@ -17346,8 +17556,8 @@ multi-partition execution.
@itemize *
@item
-"Events that cause the version of a compilation unit to
-change. See E.3(5)."
+“Events that cause the version of a compilation unit to
+change. See E.3(5).”
@end itemize
Editing the source file of a compilation unit, or the source files of
@@ -17360,8 +17570,8 @@ comments.
@itemize *
@item
-"Whether the execution of the remote subprogram is
-immediately aborted as a result of cancellation. See E.4(13)."
+“Whether the execution of the remote subprogram is
+immediately aborted as a result of cancellation. See E.4(13).”
@end itemize
See the GLADE reference manual for details on the effect of abort in
@@ -17371,7 +17581,7 @@ a distributed application.
@itemize *
@item
-"Implementation-defined aspects of the PCS. See E.5(25)."
+“Implementation-defined aspects of the PCS. See E.5(25).”
@end itemize
See the GLADE reference manual for a full description of all implementation
@@ -17381,8 +17591,8 @@ defined aspects of the PCS.
@itemize *
@item
-"Implementation-defined interfaces in the PCS. See
-E.5(26)."
+“Implementation-defined interfaces in the PCS. See
+E.5(26).”
@end itemize
See the GLADE reference manual for a full description of all
@@ -17392,8 +17602,8 @@ implementation defined interfaces.
@itemize *
@item
-"The values of named numbers in the package
-@code{Decimal}. See F.2(7)."
+“The values of named numbers in the package
+@code{Decimal}. See F.2(7).”
@end itemize
@@ -17453,8 +17663,8 @@ Value
@itemize *
@item
-"The value of @code{Max_Picture_Length} in the package
-@code{Text_IO.Editing}. See F.3.3(16)."
+“The value of @code{Max_Picture_Length} in the package
+@code{Text_IO.Editing}. See F.3.3(16).”
@end itemize
64
@@ -17463,8 +17673,8 @@ Value
@itemize *
@item
-"The value of @code{Max_Picture_Length} in the package
-@code{Wide_Text_IO.Editing}. See F.3.4(5)."
+“The value of @code{Max_Picture_Length} in the package
+@code{Wide_Text_IO.Editing}. See F.3.4(5).”
@end itemize
64
@@ -17473,8 +17683,8 @@ Value
@itemize *
@item
-"The accuracy actually achieved by the complex elementary
-functions and by other complex arithmetic operations. See G.1(1)."
+“The accuracy actually achieved by the complex elementary
+functions and by other complex arithmetic operations. See G.1(1).”
@end itemize
Standard library functions are used for the complex arithmetic
@@ -17484,9 +17694,9 @@ operations. Only fast math mode is currently supported.
@itemize *
@item
-"The sign of a zero result (or a component thereof) from
+“The sign of a zero result (or a component thereof) from
any operator or function in @code{Numerics.Generic_Complex_Types}, when
-@code{Real'Signed_Zeros} is True. See G.1.1(53)."
+@code{Real'Signed_Zeros} is True. See G.1.1(53).”
@end itemize
The signs of zero values are as recommended by the relevant
@@ -17496,10 +17706,10 @@ implementation advice.
@itemize *
@item
-"The sign of a zero result (or a component thereof) from
+“The sign of a zero result (or a component thereof) from
any operator or function in
@code{Numerics.Generic_Complex_Elementary_Functions}, when
-@code{Real'Signed_Zeros} is @code{True}. See G.1.2(45)."
+@code{Real'Signed_Zeros} is @code{True}. See G.1.2(45).”
@end itemize
The signs of zero values are as recommended by the relevant
@@ -17509,8 +17719,8 @@ implementation advice.
@itemize *
@item
-"Whether the strict mode or the relaxed mode is the
-default. See G.2(2)."
+“Whether the strict mode or the relaxed mode is the
+default. See G.2(2).”
@end itemize
The strict mode is the default. There is no separate relaxed mode. GNAT
@@ -17520,8 +17730,8 @@ provides a highly efficient implementation of strict mode.
@itemize *
@item
-"The result interval in certain cases of fixed-to-float
-conversion. See G.2.1(10)."
+“The result interval in certain cases of fixed-to-float
+conversion. See G.2.1(10).”
@end itemize
For cases where the result interval is implementation dependent, the
@@ -17532,9 +17742,9 @@ floating-point format.
@itemize *
@item
-"The result of a floating point arithmetic operation in
+“The result of a floating point arithmetic operation in
overflow situations, when the @code{Machine_Overflows} attribute of the
-result type is @code{False}. See G.2.1(13)."
+result type is @code{False}. See G.2.1(13).”
@end itemize
Infinite and NaN values are produced as dictated by the IEEE
@@ -17549,9 +17759,9 @@ properly generated.
@itemize *
@item
-"The result interval for division (or exponentiation by a
+“The result interval for division (or exponentiation by a
negative exponent), when the floating point hardware implements division
-as multiplication by a reciprocal. See G.2.1(16)."
+as multiplication by a reciprocal. See G.2.1(16).”
@end itemize
Not relevant, division is IEEE exact.
@@ -17560,9 +17770,9 @@ Not relevant, division is IEEE exact.
@itemize *
@item
-"The definition of close result set, which determines the
+“The definition of close result set, which determines the
accuracy of certain fixed point multiplications and divisions. See
-G.2.3(5)."
+G.2.3(5).”
@end itemize
Operations in the close result set are performed using IEEE long format
@@ -17574,9 +17784,9 @@ is converted to the target type.
@itemize *
@item
-"Conditions on a @emph{universal_real} operand of a fixed
+“Conditions on a @emph{universal_real} operand of a fixed
point multiplication or division for which the result shall be in the
-perfect result set. See G.2.3(22)."
+perfect result set. See G.2.3(22).”
@end itemize
The result is only defined to be in the perfect result set if the result
@@ -17587,9 +17797,9 @@ representable in 64 bits.
@itemize *
@item
-"The result of a fixed point arithmetic operation in
+“The result of a fixed point arithmetic operation in
overflow situations, when the @code{Machine_Overflows} attribute of the
-result type is @code{False}. See G.2.3(27)."
+result type is @code{False}. See G.2.3(27).”
@end itemize
Not relevant, @code{Machine_Overflows} is @code{True} for fixed-point
@@ -17599,9 +17809,9 @@ types.
@itemize *
@item
-"The result of an elementary function reference in
+“The result of an elementary function reference in
overflow situations, when the @code{Machine_Overflows} attribute of the
-result type is @code{False}. See G.2.4(4)."
+result type is @code{False}. See G.2.4(4).”
@end itemize
IEEE infinite and Nan values are produced as appropriate.
@@ -17610,10 +17820,10 @@ IEEE infinite and Nan values are produced as appropriate.
@itemize *
@item
-"The value of the angle threshold, within which certain
+“The value of the angle threshold, within which certain
elementary functions, complex arithmetic operations, and complex
elementary functions yield results conforming to a maximum relative
-error bound. See G.2.4(10)."
+error bound. See G.2.4(10).”
@end itemize
Information on this subject is not yet available.
@@ -17622,8 +17832,8 @@ Information on this subject is not yet available.
@itemize *
@item
-"The accuracy of certain elementary functions for
-parameters beyond the angle threshold. See G.2.4(10)."
+“The accuracy of certain elementary functions for
+parameters beyond the angle threshold. See G.2.4(10).”
@end itemize
Information on this subject is not yet available.
@@ -17632,10 +17842,10 @@ Information on this subject is not yet available.
@itemize *
@item
-"The result of a complex arithmetic operation or complex
+“The result of a complex arithmetic operation or complex
elementary function reference in overflow situations, when the
@code{Machine_Overflows} attribute of the corresponding real type is
-@code{False}. See G.2.6(5)."
+@code{False}. See G.2.6(5).”
@end itemize
IEEE infinite and Nan values are produced as appropriate.
@@ -17644,9 +17854,9 @@ IEEE infinite and Nan values are produced as appropriate.
@itemize *
@item
-"The accuracy of certain complex arithmetic operations and
+“The accuracy of certain complex arithmetic operations and
certain complex elementary functions for parameters (or components
-thereof) beyond the angle threshold. See G.2.6(8)."
+thereof) beyond the angle threshold. See G.2.6(8).”
@end itemize
Information on those subjects is not yet available.
@@ -17655,8 +17865,8 @@ Information on those subjects is not yet available.
@itemize *
@item
-"Information regarding bounded errors and erroneous
-execution. See H.2(1)."
+“Information regarding bounded errors and erroneous
+execution. See H.2(1).”
@end itemize
Information on this subject is not yet available.
@@ -17665,8 +17875,8 @@ Information on this subject is not yet available.
@itemize *
@item
-"Implementation-defined aspects of pragma
-@code{Inspection_Point}. See H.3.2(8)."
+“Implementation-defined aspects of pragma
+@code{Inspection_Point}. See H.3.2(8).”
@end itemize
Pragma @code{Inspection_Point} ensures that the variable is live and can
@@ -17676,8 +17886,8 @@ be examined by the debugger at the inspection point.
@itemize *
@item
-"Implementation-defined aspects of pragma
-@code{Restrictions}. See H.4(25)."
+“Implementation-defined aspects of pragma
+@code{Restrictions}. See H.4(25).”
@end itemize
There are no implementation-defined aspects of pragma @code{Restrictions}. The
@@ -17688,14 +17898,14 @@ generated code. Checks must suppressed by use of pragma @code{Suppress}.
@itemize *
@item
-"Any restrictions on pragma @code{Restrictions}. See
-H.4(27)."
+“Any restrictions on pragma @code{Restrictions}. See
+H.4(27).”
@end itemize
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{25c}@anchor{gnat_rm/intrinsic_subprograms intrinsic-subprograms}@anchor{c}@anchor{gnat_rm/intrinsic_subprograms id1}@anchor{25d}
+@anchor{gnat_rm/intrinsic_subprograms doc}@anchor{25b}@anchor{gnat_rm/intrinsic_subprograms id1}@anchor{25c}@anchor{gnat_rm/intrinsic_subprograms intrinsic-subprograms}@anchor{c}
@chapter Intrinsic Subprograms
@@ -17733,7 +17943,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{25e}@anchor{gnat_rm/intrinsic_subprograms intrinsic-operators}@anchor{25f}
+@anchor{gnat_rm/intrinsic_subprograms id2}@anchor{25d}@anchor{gnat_rm/intrinsic_subprograms intrinsic-operators}@anchor{25e}
@section Intrinsic Operators
@@ -17758,13 +17968,13 @@ function "+" (X1 : Int1; X2 : Int2) return Int2;
pragma Import (Intrinsic, "+");
@end example
-This declaration would permit 'mixed mode' arithmetic on items
+This declaration would permit ‘mixed mode’ arithmetic on items
of the differing types @code{Int1} and @code{Int2}.
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{260}@anchor{gnat_rm/intrinsic_subprograms compilation-iso-date}@anchor{261}
+@anchor{gnat_rm/intrinsic_subprograms compilation-iso-date}@anchor{25f}@anchor{gnat_rm/intrinsic_subprograms id3}@anchor{260}
@section Compilation_ISO_Date
@@ -17778,7 +17988,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{262}@anchor{gnat_rm/intrinsic_subprograms id4}@anchor{263}
+@anchor{gnat_rm/intrinsic_subprograms compilation-date}@anchor{261}@anchor{gnat_rm/intrinsic_subprograms id4}@anchor{262}
@section Compilation_Date
@@ -17788,7 +17998,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{264}@anchor{gnat_rm/intrinsic_subprograms id5}@anchor{265}
+@anchor{gnat_rm/intrinsic_subprograms compilation-time}@anchor{263}@anchor{gnat_rm/intrinsic_subprograms id5}@anchor{264}
@section Compilation_Time
@@ -17802,7 +18012,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{266}@anchor{gnat_rm/intrinsic_subprograms enclosing-entity}@anchor{267}
+@anchor{gnat_rm/intrinsic_subprograms enclosing-entity}@anchor{265}@anchor{gnat_rm/intrinsic_subprograms id6}@anchor{266}
@section Enclosing_Entity
@@ -17816,7 +18026,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{268}@anchor{gnat_rm/intrinsic_subprograms exception-information}@anchor{269}
+@anchor{gnat_rm/intrinsic_subprograms exception-information}@anchor{267}@anchor{gnat_rm/intrinsic_subprograms id7}@anchor{268}
@section Exception_Information
@@ -17830,7 +18040,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{26a}@anchor{gnat_rm/intrinsic_subprograms id8}@anchor{26b}
+@anchor{gnat_rm/intrinsic_subprograms exception-message}@anchor{269}@anchor{gnat_rm/intrinsic_subprograms id8}@anchor{26a}
@section Exception_Message
@@ -17844,7 +18054,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{26c}@anchor{gnat_rm/intrinsic_subprograms id9}@anchor{26d}
+@anchor{gnat_rm/intrinsic_subprograms exception-name}@anchor{26b}@anchor{gnat_rm/intrinsic_subprograms id9}@anchor{26c}
@section Exception_Name
@@ -17858,7 +18068,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{26e}@anchor{gnat_rm/intrinsic_subprograms file}@anchor{26f}
+@anchor{gnat_rm/intrinsic_subprograms file}@anchor{26d}@anchor{gnat_rm/intrinsic_subprograms id10}@anchor{26e}
@section File
@@ -17872,7 +18082,7 @@ application program should simply call the function
file.
@node Line,Shifts and Rotates,File,Intrinsic Subprograms
-@anchor{gnat_rm/intrinsic_subprograms id11}@anchor{270}@anchor{gnat_rm/intrinsic_subprograms line}@anchor{271}
+@anchor{gnat_rm/intrinsic_subprograms id11}@anchor{26f}@anchor{gnat_rm/intrinsic_subprograms line}@anchor{270}
@section Line
@@ -17886,7 +18096,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{272}@anchor{gnat_rm/intrinsic_subprograms id12}@anchor{273}
+@anchor{gnat_rm/intrinsic_subprograms id12}@anchor{271}@anchor{gnat_rm/intrinsic_subprograms shifts-and-rotates}@anchor{272}
@section Shifts and Rotates
@@ -17908,26 +18118,28 @@ type (signed or modular), as in this example:
@example
function Shift_Left
(Value : T;
- Amount : Natural) return T;
+ Amount : Natural) return T
+with Import, Convention => Intrinsic;
@end example
The function name must be one of
Shift_Left, Shift_Right, Shift_Right_Arithmetic, Rotate_Left, or
-Rotate_Right. T must be an integer type. T'Size must be
+Rotate_Right. T must be an integer type. T’Size must be
8, 16, 32 or 64 bits; if T is modular, the modulus
must be 2**8, 2**16, 2**32 or 2**64.
The result type must be the same as the type of @code{Value}.
The shift amount must be Natural.
The formal parameter names can be anything.
-A more convenient way of providing these shift operators is to use
-the Provide_Shift_Operators pragma, which provides the function declarations
-and corresponding pragma Import's for all five shift functions. Note that in
-using these provided shift operations, shifts performed on negative numbers
-will result in modification of the sign bit.
+A more convenient way of providing these shift operators is to use the
+Provide_Shift_Operators pragma, which provides the function declarations and
+corresponding pragma Import’s for all five shift functions. For signed types
+the semantics of these operators is to interpret the bitwise result of the
+corresponding operator for modular type. In particular, shifting a negative
+number may change its sign bit to positive.
@node Source_Location,,Shifts and Rotates,Intrinsic Subprograms
-@anchor{gnat_rm/intrinsic_subprograms source-location}@anchor{274}@anchor{gnat_rm/intrinsic_subprograms id13}@anchor{275}
+@anchor{gnat_rm/intrinsic_subprograms id13}@anchor{273}@anchor{gnat_rm/intrinsic_subprograms source-location}@anchor{274}
@section Source_Location
@@ -17941,7 +18153,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{276}@anchor{gnat_rm/representation_clauses_and_pragmas id1}@anchor{277}
+@anchor{gnat_rm/representation_clauses_and_pragmas doc}@anchor{275}@anchor{gnat_rm/representation_clauses_and_pragmas id1}@anchor{276}@anchor{gnat_rm/representation_clauses_and_pragmas representation-clauses-and-pragmas}@anchor{d}
@chapter Representation Clauses and Pragmas
@@ -17987,7 +18199,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{278}@anchor{gnat_rm/representation_clauses_and_pragmas alignment-clauses}@anchor{279}
+@anchor{gnat_rm/representation_clauses_and_pragmas alignment-clauses}@anchor{277}@anchor{gnat_rm/representation_clauses_and_pragmas id2}@anchor{278}
@section Alignment Clauses
@@ -18009,7 +18221,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{190,,Attribute Maximum_Alignment}.)
+@code{Standard'Maximum_Alignment}; see @ref{18d,,Attribute Maximum_Alignment}.)
@geindex Maximum_Alignment attribute
@@ -18118,7 +18330,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{27a}@anchor{gnat_rm/representation_clauses_and_pragmas size-clauses}@anchor{27b}
+@anchor{gnat_rm/representation_clauses_and_pragmas id3}@anchor{279}@anchor{gnat_rm/representation_clauses_and_pragmas size-clauses}@anchor{27a}
@section Size Clauses
@@ -18162,10 +18374,10 @@ in accordance with the specific Implementation Advice in RM 13.3(43):
@quotation
-"A @code{Size} clause should be supported for an object if the specified
-@code{Size} is at least as large as its subtype's @code{Size}, and corresponds
-to a size in storage elements that is a multiple of the object's
-@code{Alignment} (if the @code{Alignment} is nonzero)."
+“A @code{Size} clause should be supported for an object if the specified
+@code{Size} is at least as large as its subtype’s @code{Size}, and corresponds
+to a size in storage elements that is a multiple of the object’s
+@code{Alignment} (if the @code{Alignment} is nonzero).”
@end quotation
An explicit size clause may be used to override the default size by
@@ -18195,7 +18407,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{27c}@anchor{gnat_rm/representation_clauses_and_pragmas id4}@anchor{27d}
+@anchor{gnat_rm/representation_clauses_and_pragmas id4}@anchor{27b}@anchor{gnat_rm/representation_clauses_and_pragmas storage-size-clauses}@anchor{27c}
@section Storage_Size Clauses
@@ -18268,7 +18480,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{27e}@anchor{gnat_rm/representation_clauses_and_pragmas size-of-variant-record-objects}@anchor{27f}
+@anchor{gnat_rm/representation_clauses_and_pragmas id5}@anchor{27d}@anchor{gnat_rm/representation_clauses_and_pragmas size-of-variant-record-objects}@anchor{27e}
@section Size of Variant Record Objects
@@ -18378,7 +18590,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{280}@anchor{gnat_rm/representation_clauses_and_pragmas biased-representation}@anchor{281}
+@anchor{gnat_rm/representation_clauses_and_pragmas biased-representation}@anchor{27f}@anchor{gnat_rm/representation_clauses_and_pragmas id6}@anchor{280}
@section Biased Representation
@@ -18416,7 +18628,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{282}@anchor{gnat_rm/representation_clauses_and_pragmas value-size-and-object-size-clauses}@anchor{283}
+@anchor{gnat_rm/representation_clauses_and_pragmas id7}@anchor{281}@anchor{gnat_rm/representation_clauses_and_pragmas value-size-and-object-size-clauses}@anchor{282}
@section Value_Size and Object_Size Clauses
@@ -18463,7 +18675,7 @@ objects of the type respectively.
The @code{Object_Size} is used for determining the default size of
objects and components. This size value can be referred to using the
-@code{Object_Size} attribute. The phrase 'is used' here means that it is
+@code{Object_Size} attribute. The phrase ‘is used’ here means that it is
the basis of the determination of the size. The backend is free to
pad this up if necessary for efficiency, e.g., an 8-bit stand-alone
character might be stored in 32 bits on a machine with no efficient
@@ -18515,8 +18727,8 @@ only if negative values are possible).
@item
If a subtype statically matches the first subtype of a given type, then it has
by default the same @code{Value_Size} as the first subtype. This is a
-consequence of RM 13.1(14): "if two subtypes statically match,
-then their subtype-specific aspects are the same".)
+consequence of RM 13.1(14): “if two subtypes statically match,
+then their subtype-specific aspects are the same”.)
@item
All other subtypes have a @code{Value_Size} corresponding to the minimum
@@ -18649,7 +18861,7 @@ Value_Size
@end multitable
-Note: the entries marked '*' are not actually specified by the Ada
+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 accommodate any
possible dynamic values for the bounds at run-time.
@@ -18695,7 +18907,7 @@ the alignment requirement for objects of the record type. The X
component will require four-byte alignment because that is what type
Integer requires, whereas the Y component, a Character, will only
require 1-byte alignment. Since the alignment required for X is the
-greatest of all the components' alignments, that is the alignment
+greatest of all the components’ alignments, that is the alignment
required for the enclosing record type, i.e., 4 bytes or 32 bits. As
indicated above, the actual object size must be rounded up so that it is
a multiple of the alignment value. Therefore, 40 bits rounded up to the
@@ -18732,7 +18944,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{284}@anchor{gnat_rm/representation_clauses_and_pragmas component-size-clauses}@anchor{285}
+@anchor{gnat_rm/representation_clauses_and_pragmas component-size-clauses}@anchor{283}@anchor{gnat_rm/representation_clauses_and_pragmas id8}@anchor{284}
@section Component_Size Clauses
@@ -18780,7 +18992,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{286}@anchor{gnat_rm/representation_clauses_and_pragmas id9}@anchor{287}
+@anchor{gnat_rm/representation_clauses_and_pragmas bit-order-clauses}@anchor{285}@anchor{gnat_rm/representation_clauses_and_pragmas id9}@anchor{286}
@section Bit_Order Clauses
@@ -18886,7 +19098,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{288}@anchor{gnat_rm/representation_clauses_and_pragmas effect-of-bit-order-on-byte-ordering}@anchor{289}
+@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{288}
@section Effect of Bit_Order on Byte Ordering
@@ -18905,8 +19117,8 @@ Reference Manual:
@quotation
-"2 A bit ordering is a method of interpreting the meaning of
-the storage place attributes."
+“2 A bit ordering is a method of interpreting the meaning of
+the storage place attributes.”
@end quotation
To understand the precise definition of storage place attributes in
@@ -18914,11 +19126,11 @@ this context, we visit section 13.5.1 of the manual:
@quotation
-"13 A record_representation_clause (without the mod_clause)
+“13 A record_representation_clause (without the mod_clause)
specifies the layout. The storage place attributes (see 13.5.2)
are taken from the values of the position, first_bit, and last_bit
expressions after normalizing those values so that first_bit is
-less than Storage_Unit."
+less than Storage_Unit.”
@end quotation
The critical point here is that storage places are taken from
@@ -18928,14 +19140,14 @@ is described in the later part of the 13.5.3 paragraph:
@quotation
-"2 A bit ordering is a method of interpreting the meaning of
+“2 A bit ordering is a method of interpreting the meaning of
the storage place attributes. High_Order_First (known in the
-vernacular as 'big endian') means that the first bit of a
+vernacular as ‘big endian’) means that the first bit of a
storage element (bit 0) is the most significant bit (interpreting
the sequence of bits that represent a component as an unsigned
integer value). Low_Order_First (known in the vernacular as
-'little endian') means the opposite: the first bit is the
-least significant."
+‘little endian’) means the opposite: the first bit is the
+least significant.”
@end quotation
Note that the numbering is with respect to the bits of a storage
@@ -18949,7 +19161,7 @@ byte presented, which is the first (low addressed byte) of the two byte
record is called Master, and the second byte is called Slave.
The left most (most significant bit is called Control for each byte, and
-the remaining 7 bits are called V1, V2, ... V7, where V7 is the rightmost
+the remaining 7 bits are called V1, V2, … V7, where V7 is the rightmost
(least significant) bit.
On a big-endian machine, we can write the following representation clause
@@ -19143,7 +19355,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{28a}@anchor{gnat_rm/representation_clauses_and_pragmas id11}@anchor{28b}
+@anchor{gnat_rm/representation_clauses_and_pragmas id11}@anchor{289}@anchor{gnat_rm/representation_clauses_and_pragmas pragma-pack-for-arrays}@anchor{28a}
@section Pragma Pack for Arrays
@@ -19263,7 +19475,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{28c}@anchor{gnat_rm/representation_clauses_and_pragmas id12}@anchor{28d}
+@anchor{gnat_rm/representation_clauses_and_pragmas id12}@anchor{28b}@anchor{gnat_rm/representation_clauses_and_pragmas pragma-pack-for-records}@anchor{28c}
@section Pragma Pack for Records
@@ -19347,7 +19559,7 @@ array that is longer than 64 bits, so it is itself non-packable on
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{28e}@anchor{gnat_rm/representation_clauses_and_pragmas record-representation-clauses}@anchor{28f}
+@anchor{gnat_rm/representation_clauses_and_pragmas id13}@anchor{28d}@anchor{gnat_rm/representation_clauses_and_pragmas record-representation-clauses}@anchor{28e}
@section Record Representation Clauses
@@ -19426,13 +19638,13 @@ 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{290}@anchor{gnat_rm/representation_clauses_and_pragmas id14}@anchor{291}
+@anchor{gnat_rm/representation_clauses_and_pragmas handling-of-records-with-holes}@anchor{28f}@anchor{gnat_rm/representation_clauses_and_pragmas id14}@anchor{290}
@section Handling of Records with Holes
@geindex Handling of Records with Holes
-As a result of alignment considerations, records may contain "holes"
+As a result of alignment considerations, records may contain “holes”
or gaps which do not correspond to the data bits of any of the components.
Record representation clauses can also result in holes in records.
@@ -19502,7 +19714,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{292}@anchor{gnat_rm/representation_clauses_and_pragmas id15}@anchor{293}
+@anchor{gnat_rm/representation_clauses_and_pragmas enumeration-clauses}@anchor{291}@anchor{gnat_rm/representation_clauses_and_pragmas id15}@anchor{292}
@section Enumeration Clauses
@@ -19545,7 +19757,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{294}@anchor{gnat_rm/representation_clauses_and_pragmas address-clauses}@anchor{295}
+@anchor{gnat_rm/representation_clauses_and_pragmas address-clauses}@anchor{293}@anchor{gnat_rm/representation_clauses_and_pragmas id16}@anchor{294}
@section Address Clauses
@@ -19556,12 +19768,12 @@ as found in RM 13.1(22):
@quotation
-"An implementation need not support representation
+“An implementation need not support representation
items containing nonstatic expressions, except that
an implementation should support a representation item
for a given entity if each nonstatic expression in the
representation item is a name that statically denotes
-a constant declared before the entity."
+a constant declared before the entity.”
@end quotation
In practice this is applicable only to address clauses, since this is the
@@ -19572,9 +19784,9 @@ the AARM notes in sections 13.1 (22.a-22.h):
22.a Reason: This is to avoid the following sort of thing:
-22.b X : Integer := F(...);
-Y : Address := G(...);
-for X'Address use Y;
+22.b X : Integer := F(…);
+Y : Address := G(…);
+for X’Address use Y;
22.c In the above, we have to evaluate the
initialization expression for X before we
@@ -19584,11 +19796,11 @@ like an unreasonable implementation burden.
22.d The above code should instead be written
like this:
-22.e Y : constant Address := G(...);
-X : Integer := F(...);
-for X'Address use Y;
+22.e Y : constant Address := G(…);
+X : Integer := F(…);
+for X’Address use Y;
-22.f This allows the expression 'Y' to be safely
+22.f This allows the expression ‘Y’ to be safely
evaluated before X is created.
22.g The constant could be a formal parameter of mode in.
@@ -19635,7 +19847,7 @@ a component of a discriminated record.
As noted above in section 22.h, address values are typically nonstatic. In
particular the To_Address function, even if applied to a literal value, is
a nonstatic function call. To avoid this minor annoyance, GNAT provides
-the implementation defined attribute 'To_Address. The following two
+the implementation defined attribute ‘To_Address. The following two
expressions have identical values:
@geindex Attribute
@@ -19765,14 +19977,14 @@ implementation advice (RM 13.3(19)):
@quotation
-"19 If the Address of an object is specified, or it is imported
+“19 If the Address of an object is specified, or it is imported
or exported, then the implementation should not perform
-optimizations based on assumptions of no aliases."
+optimizations based on assumptions of no aliases.”
@end quotation
GNAT follows this recommendation, and goes further by also applying
this recommendation to the overlaid variable (@code{A} in the above example)
-in this case. This means that the overlay works "as expected", in that
+in this case. This means that the overlay works “as expected”, in that
a modification to one of the variables will affect the value of the other.
More generally, GNAT interprets this recommendation conservatively for
@@ -19824,7 +20036,7 @@ of the use of this pragma. This may cause an overlay to have this
unintended clobbering effect. The compiler avoids this for scalar
types, but not for composite objects (where in general the effect
of @code{Initialize_Scalars} is part of the initialization routine
-for the composite object:
+for the composite object):
@example
pragma Initialize_Scalars;
@@ -19874,7 +20086,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{296}@anchor{gnat_rm/representation_clauses_and_pragmas use-of-address-clauses-for-memory-mapped-i-o}@anchor{297}
+@anchor{gnat_rm/representation_clauses_and_pragmas id17}@anchor{295}@anchor{gnat_rm/representation_clauses_and_pragmas use-of-address-clauses-for-memory-mapped-i-o}@anchor{296}
@section Use of Address Clauses for Memory-Mapped I/O
@@ -19932,7 +20144,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{298}@anchor{gnat_rm/representation_clauses_and_pragmas effect-of-convention-on-representation}@anchor{299}
+@anchor{gnat_rm/representation_clauses_and_pragmas effect-of-convention-on-representation}@anchor{297}@anchor{gnat_rm/representation_clauses_and_pragmas id18}@anchor{298}
@section Effect of Convention on Representation
@@ -20010,7 +20222,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{29a}@anchor{gnat_rm/representation_clauses_and_pragmas id19}@anchor{29b}
+@anchor{gnat_rm/representation_clauses_and_pragmas conventions-and-anonymous-access-types}@anchor{299}@anchor{gnat_rm/representation_clauses_and_pragmas id19}@anchor{29a}
@section Conventions and Anonymous Access Types
@@ -20029,7 +20241,7 @@ then the convention will apply to this anonymous type as well. This
seems to make sense since it is anomolous in any case to have a
different convention for an object and its type, and there is clearly
no way to explicitly specify a convention for an anonymous type, since
-it doesn't have a name to specify!
+it doesn’t have a name to specify!
Furthermore, we decide that if a convention is applied to a record type,
then this convention is inherited by any of its components that are of an
@@ -20086,7 +20298,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{29c}@anchor{gnat_rm/representation_clauses_and_pragmas determining-the-representations-chosen-by-gnat}@anchor{29d}
+@anchor{gnat_rm/representation_clauses_and_pragmas determining-the-representations-chosen-by-gnat}@anchor{29b}@anchor{gnat_rm/representation_clauses_and_pragmas id20}@anchor{29c}
@section Determining the Representations chosen by GNAT
@@ -20238,7 +20450,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{29e}@anchor{gnat_rm/standard_library_routines id1}@anchor{29f}
+@anchor{gnat_rm/standard_library_routines doc}@anchor{29d}@anchor{gnat_rm/standard_library_routines id1}@anchor{29e}@anchor{gnat_rm/standard_library_routines standard-library-routines}@anchor{e}
@chapter Standard Library Routines
@@ -20413,7 +20625,7 @@ operations, which is not implemented in GNAT.
This package provides constants describing the range of decimal numbers
implemented, and also a decimal divide routine (analogous to the COBOL
-verb DIVIDE ... GIVING ... REMAINDER ...)
+verb DIVIDE … GIVING … REMAINDER …)
@item @code{Ada.Direct_IO} @emph{(A.8.4)}
@@ -20461,7 +20673,7 @@ all targets (see package spec for details).
Not implemented in GNAT.
-@item @code{Ada.Execution_Time.Timers} @emph{(D.14.1)'}
+@item @code{Ada.Execution_Time.Timers} @emph{(D.14.1)’}
Not implemented in GNAT.
@@ -21062,7 +21274,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{2a0}@anchor{gnat_rm/the_implementation_of_standard_i_o id1}@anchor{2a1}
+@anchor{gnat_rm/the_implementation_of_standard_i_o doc}@anchor{29f}@anchor{gnat_rm/the_implementation_of_standard_i_o id1}@anchor{2a0}@anchor{gnat_rm/the_implementation_of_standard_i_o the-implementation-of-standard-i-o}@anchor{f}
@chapter The Implementation of Standard I/O
@@ -21114,7 +21326,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{2a2}@anchor{gnat_rm/the_implementation_of_standard_i_o id2}@anchor{2a3}
+@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{2a2}
@section Standard I/O Packages
@@ -21185,7 +21397,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{2a4}@anchor{gnat_rm/the_implementation_of_standard_i_o id3}@anchor{2a5}
+@anchor{gnat_rm/the_implementation_of_standard_i_o form-strings}@anchor{2a3}@anchor{gnat_rm/the_implementation_of_standard_i_o id3}@anchor{2a4}
@section FORM Strings
@@ -21211,7 +21423,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{2a6}@anchor{gnat_rm/the_implementation_of_standard_i_o id4}@anchor{2a7}
+@anchor{gnat_rm/the_implementation_of_standard_i_o direct-io}@anchor{2a5}@anchor{gnat_rm/the_implementation_of_standard_i_o id4}@anchor{2a6}
@section Direct_IO
@@ -21231,7 +21443,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{2a8}@anchor{gnat_rm/the_implementation_of_standard_i_o id5}@anchor{2a9}
+@anchor{gnat_rm/the_implementation_of_standard_i_o id5}@anchor{2a7}@anchor{gnat_rm/the_implementation_of_standard_i_o sequential-io}@anchor{2a8}
@section Sequential_IO
@@ -21278,7 +21490,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{2aa}@anchor{gnat_rm/the_implementation_of_standard_i_o text-io}@anchor{2ab}
+@anchor{gnat_rm/the_implementation_of_standard_i_o id6}@anchor{2a9}@anchor{gnat_rm/the_implementation_of_standard_i_o text-io}@anchor{2aa}
@section Text_IO
@@ -21361,7 +21573,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{2ac}@anchor{gnat_rm/the_implementation_of_standard_i_o stream-pointer-positioning}@anchor{2ad}
+@anchor{gnat_rm/the_implementation_of_standard_i_o id7}@anchor{2ab}@anchor{gnat_rm/the_implementation_of_standard_i_o stream-pointer-positioning}@anchor{2ac}
@subsection Stream Pointer Positioning
@@ -21397,7 +21609,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{2ae}@anchor{gnat_rm/the_implementation_of_standard_i_o id8}@anchor{2af}
+@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{2ae}
@subsection Reading and Writing Non-Regular Files
@@ -21438,7 +21650,7 @@ above they will not be treated as page marks on input if the output is
piped to another Ada program.
Another important discrepancy when reading non-regular files is that the end
-of file indication is not 'sticky'. If an end of file is entered, e.g., by
+of file indication is not ‘sticky’. If an end of file is entered, e.g., by
pressing the @code{EOT} key,
then end of file
is signaled once (i.e., the test @code{End_Of_File}
@@ -21448,7 +21660,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{2b0}@anchor{gnat_rm/the_implementation_of_standard_i_o id9}@anchor{2b1}
+@anchor{gnat_rm/the_implementation_of_standard_i_o get-immediate}@anchor{2af}@anchor{gnat_rm/the_implementation_of_standard_i_o id9}@anchor{2b0}
@subsection Get_Immediate
@@ -21466,7 +21678,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{2b2}@anchor{gnat_rm/the_implementation_of_standard_i_o treating-text-io-files-as-streams}@anchor{2b3}
+@anchor{gnat_rm/the_implementation_of_standard_i_o id10}@anchor{2b1}@anchor{gnat_rm/the_implementation_of_standard_i_o treating-text-io-files-as-streams}@anchor{2b2}
@subsection Treating Text_IO Files as Streams
@@ -21482,7 +21694,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{2b4}@anchor{gnat_rm/the_implementation_of_standard_i_o text-io-extensions}@anchor{2b5}
+@anchor{gnat_rm/the_implementation_of_standard_i_o id11}@anchor{2b3}@anchor{gnat_rm/the_implementation_of_standard_i_o text-io-extensions}@anchor{2b4}
@subsection Text_IO Extensions
@@ -21510,7 +21722,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{2b6}@anchor{gnat_rm/the_implementation_of_standard_i_o id12}@anchor{2b7}
+@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{2b6}
@subsection Text_IO Facilities for Unbounded Strings
@@ -21558,7 +21770,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{2b8}@anchor{gnat_rm/the_implementation_of_standard_i_o id13}@anchor{2b9}
+@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{2b8}
@section Wide_Text_IO
@@ -21761,11 +21973,11 @@ as UTF-8 will be used for text input output.
If brackets notation is used, then any occurrence of a left bracket
in the input file which is not the start of a valid wide character
sequence will cause Constraint_Error to be raised. It is possible to
-encode a left bracket as ["5B"] and Wide_Text_IO and Wide_Wide_Text_IO
+encode a left bracket as [“5B”] and Wide_Text_IO and Wide_Wide_Text_IO
input will interpret this as a left bracket.
However, when a left bracket is output, it will be output as a left bracket
-and not as ["5B"]. We make this decision because for normal use of
+and not as [“5B”]. We make this decision because for normal use of
Wide_Text_IO for outputting messages, it is unpleasant to clobber left
brackets. For example, if we write:
@@ -21785,7 +21997,7 @@ Start of output ["5B"]first run]
@quotation
In practice brackets encoding is reasonably useful for normal Put_Line use
-since we won't get confused between left brackets and wide character
+since we won’t get confused between left brackets and wide character
sequences in the output. But for input, or when files are written out
and read back in, it really makes better sense to use one of the standard
encoding methods such as UTF-8.
@@ -21805,12 +22017,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{2ba}@anchor{gnat_rm/the_implementation_of_standard_i_o id14}@anchor{2bb}
+@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{2ba}
@subsection Stream Pointer Positioning
@code{Ada.Wide_Text_IO} is similar to @code{Ada.Text_IO} in its handling
-of stream pointer positioning (@ref{2ab,,Text_IO}). There is one additional
+of stream pointer positioning (@ref{2aa,,Text_IO}). There is one additional
case:
If @code{Ada.Wide_Text_IO.Look_Ahead} reads a character outside the
@@ -21829,7 +22041,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{2bc}@anchor{gnat_rm/the_implementation_of_standard_i_o id15}@anchor{2bd}
+@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{2bc}
@subsection Reading and Writing Non-Regular Files
@@ -21840,7 +22052,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{2be}@anchor{gnat_rm/the_implementation_of_standard_i_o wide-wide-text-io}@anchor{2bf}
+@anchor{gnat_rm/the_implementation_of_standard_i_o id16}@anchor{2bd}@anchor{gnat_rm/the_implementation_of_standard_i_o wide-wide-text-io}@anchor{2be}
@section Wide_Wide_Text_IO
@@ -22009,12 +22221,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{2c0}@anchor{gnat_rm/the_implementation_of_standard_i_o id17}@anchor{2c1}
+@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{2c0}
@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{2ab,,Text_IO}). There is one additional
+of stream pointer positioning (@ref{2aa,,Text_IO}). There is one additional
case:
If @code{Ada.Wide_Wide_Text_IO.Look_Ahead} reads a character outside the
@@ -22033,7 +22245,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{2c2}@anchor{gnat_rm/the_implementation_of_standard_i_o reading-and-writing-non-regular-files-2}@anchor{2c3}
+@anchor{gnat_rm/the_implementation_of_standard_i_o id18}@anchor{2c1}@anchor{gnat_rm/the_implementation_of_standard_i_o reading-and-writing-non-regular-files-2}@anchor{2c2}
@subsection Reading and Writing Non-Regular Files
@@ -22044,7 +22256,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{2c4}@anchor{gnat_rm/the_implementation_of_standard_i_o stream-io}@anchor{2c5}
+@anchor{gnat_rm/the_implementation_of_standard_i_o id19}@anchor{2c3}@anchor{gnat_rm/the_implementation_of_standard_i_o stream-io}@anchor{2c4}
@section Stream_IO
@@ -22066,7 +22278,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{2c6}@anchor{gnat_rm/the_implementation_of_standard_i_o text-translation}@anchor{2c7}
+@anchor{gnat_rm/the_implementation_of_standard_i_o id20}@anchor{2c5}@anchor{gnat_rm/the_implementation_of_standard_i_o text-translation}@anchor{2c6}
@section Text Translation
@@ -22100,7 +22312,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{2c8}@anchor{gnat_rm/the_implementation_of_standard_i_o shared-files}@anchor{2c9}
+@anchor{gnat_rm/the_implementation_of_standard_i_o id21}@anchor{2c7}@anchor{gnat_rm/the_implementation_of_standard_i_o shared-files}@anchor{2c8}
@section Shared Files
@@ -22163,7 +22375,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{2ca}@anchor{gnat_rm/the_implementation_of_standard_i_o id22}@anchor{2cb}
+@anchor{gnat_rm/the_implementation_of_standard_i_o filenames-encoding}@anchor{2c9}@anchor{gnat_rm/the_implementation_of_standard_i_o id22}@anchor{2ca}
@section Filenames encoding
@@ -22203,7 +22415,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{2cc}@anchor{gnat_rm/the_implementation_of_standard_i_o id23}@anchor{2cd}
+@anchor{gnat_rm/the_implementation_of_standard_i_o file-content-encoding}@anchor{2cb}@anchor{gnat_rm/the_implementation_of_standard_i_o id23}@anchor{2cc}
@section File content encoding
@@ -22236,7 +22448,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{2ce}@anchor{gnat_rm/the_implementation_of_standard_i_o id24}@anchor{2cf}
+@anchor{gnat_rm/the_implementation_of_standard_i_o id24}@anchor{2cd}@anchor{gnat_rm/the_implementation_of_standard_i_o open-modes}@anchor{2ce}
@section Open Modes
@@ -22269,11 +22481,11 @@ Append_File
@tab
-"r+"
+“r+”
@tab
-"w+"
+“w+”
@item
@@ -22281,11 +22493,11 @@ In_File
@tab
-"r"
+“r”
@tab
-"w+"
+“w+”
@item
@@ -22293,11 +22505,11 @@ Out_File (Direct_IO)
@tab
-"r+"
+“r+”
@tab
-"w"
+“w”
@item
@@ -22305,11 +22517,11 @@ Out_File (all other cases)
@tab
-"w"
+“w”
@tab
-"w"
+“w”
@item
@@ -22317,11 +22529,11 @@ Inout_File
@tab
-"r+"
+“r+”
@tab
-"w+"
+“w+”
@end multitable
@@ -22339,7 +22551,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{2d0}@anchor{gnat_rm/the_implementation_of_standard_i_o id25}@anchor{2d1}
+@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{2d0}
@section Operations on C Streams
@@ -22499,7 +22711,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{2d2}@anchor{gnat_rm/the_implementation_of_standard_i_o id26}@anchor{2d3}
+@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{2d2}
@section Interfacing to C Streams
@@ -22592,7 +22804,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{2d4}@anchor{gnat_rm/the_gnat_library id1}@anchor{2d5}
+@anchor{gnat_rm/the_gnat_library doc}@anchor{2d3}@anchor{gnat_rm/the_gnat_library id1}@anchor{2d4}@anchor{gnat_rm/the_gnat_library the-gnat-library}@anchor{10}
@chapter The GNAT Library
@@ -22786,7 +22998,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{2d6}@anchor{gnat_rm/the_gnat_library ada-characters-latin-9-a-chlat9-ads}@anchor{2d7}
+@anchor{gnat_rm/the_gnat_library ada-characters-latin-9-a-chlat9-ads}@anchor{2d5}@anchor{gnat_rm/the_gnat_library id2}@anchor{2d6}
@section @code{Ada.Characters.Latin_9} (@code{a-chlat9.ads})
@@ -22803,7 +23015,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{2d8}@anchor{gnat_rm/the_gnat_library id3}@anchor{2d9}
+@anchor{gnat_rm/the_gnat_library ada-characters-wide-latin-1-a-cwila1-ads}@anchor{2d7}@anchor{gnat_rm/the_gnat_library id3}@anchor{2d8}
@section @code{Ada.Characters.Wide_Latin_1} (@code{a-cwila1.ads})
@@ -22820,7 +23032,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{2da}@anchor{gnat_rm/the_gnat_library ada-characters-wide-latin-9-a-cwila1-ads}@anchor{2db}
+@anchor{gnat_rm/the_gnat_library ada-characters-wide-latin-9-a-cwila1-ads}@anchor{2d9}@anchor{gnat_rm/the_gnat_library id4}@anchor{2da}
@section @code{Ada.Characters.Wide_Latin_9} (@code{a-cwila1.ads})
@@ -22837,7 +23049,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{2dc}@anchor{gnat_rm/the_gnat_library id5}@anchor{2dd}
+@anchor{gnat_rm/the_gnat_library ada-characters-wide-wide-latin-1-a-chzla1-ads}@anchor{2db}@anchor{gnat_rm/the_gnat_library id5}@anchor{2dc}
@section @code{Ada.Characters.Wide_Wide_Latin_1} (@code{a-chzla1.ads})
@@ -22854,7 +23066,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{2de}@anchor{gnat_rm/the_gnat_library id6}@anchor{2df}
+@anchor{gnat_rm/the_gnat_library ada-characters-wide-wide-latin-9-a-chzla9-ads}@anchor{2dd}@anchor{gnat_rm/the_gnat_library id6}@anchor{2de}
@section @code{Ada.Characters.Wide_Wide_Latin_9} (@code{a-chzla9.ads})
@@ -22871,7 +23083,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{2e0}@anchor{gnat_rm/the_gnat_library ada-containers-formal-doubly-linked-lists-a-cfdlli-ads}@anchor{2e1}
+@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{2e0}
@section @code{Ada.Containers.Formal_Doubly_Linked_Lists} (@code{a-cfdlli.ads})
@@ -22890,7 +23102,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{2e2}@anchor{gnat_rm/the_gnat_library ada-containers-formal-hashed-maps-a-cfhama-ads}@anchor{2e3}
+@anchor{gnat_rm/the_gnat_library ada-containers-formal-hashed-maps-a-cfhama-ads}@anchor{2e1}@anchor{gnat_rm/the_gnat_library id8}@anchor{2e2}
@section @code{Ada.Containers.Formal_Hashed_Maps} (@code{a-cfhama.ads})
@@ -22909,7 +23121,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{2e4}@anchor{gnat_rm/the_gnat_library ada-containers-formal-hashed-sets-a-cfhase-ads}@anchor{2e5}
+@anchor{gnat_rm/the_gnat_library ada-containers-formal-hashed-sets-a-cfhase-ads}@anchor{2e3}@anchor{gnat_rm/the_gnat_library id9}@anchor{2e4}
@section @code{Ada.Containers.Formal_Hashed_Sets} (@code{a-cfhase.ads})
@@ -22928,7 +23140,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{2e6}@anchor{gnat_rm/the_gnat_library ada-containers-formal-ordered-maps-a-cforma-ads}@anchor{2e7}
+@anchor{gnat_rm/the_gnat_library ada-containers-formal-ordered-maps-a-cforma-ads}@anchor{2e5}@anchor{gnat_rm/the_gnat_library id10}@anchor{2e6}
@section @code{Ada.Containers.Formal_Ordered_Maps} (@code{a-cforma.ads})
@@ -22947,7 +23159,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{2e8}@anchor{gnat_rm/the_gnat_library id11}@anchor{2e9}
+@anchor{gnat_rm/the_gnat_library ada-containers-formal-ordered-sets-a-cforse-ads}@anchor{2e7}@anchor{gnat_rm/the_gnat_library id11}@anchor{2e8}
@section @code{Ada.Containers.Formal_Ordered_Sets} (@code{a-cforse.ads})
@@ -22966,7 +23178,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{2ea}@anchor{gnat_rm/the_gnat_library ada-containers-formal-vectors-a-cofove-ads}@anchor{2eb}
+@anchor{gnat_rm/the_gnat_library ada-containers-formal-vectors-a-cofove-ads}@anchor{2e9}@anchor{gnat_rm/the_gnat_library id12}@anchor{2ea}
@section @code{Ada.Containers.Formal_Vectors} (@code{a-cofove.ads})
@@ -22985,7 +23197,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{2ec}@anchor{gnat_rm/the_gnat_library ada-containers-formal-indefinite-vectors-a-cfinve-ads}@anchor{2ed}
+@anchor{gnat_rm/the_gnat_library ada-containers-formal-indefinite-vectors-a-cfinve-ads}@anchor{2eb}@anchor{gnat_rm/the_gnat_library id13}@anchor{2ec}
@section @code{Ada.Containers.Formal_Indefinite_Vectors} (@code{a-cfinve.ads})
@@ -23004,7 +23216,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{2ee}@anchor{gnat_rm/the_gnat_library ada-containers-functional-vectors-a-cofuve-ads}@anchor{2ef}
+@anchor{gnat_rm/the_gnat_library ada-containers-functional-vectors-a-cofuve-ads}@anchor{2ed}@anchor{gnat_rm/the_gnat_library id14}@anchor{2ee}
@section @code{Ada.Containers.Functional_Vectors} (@code{a-cofuve.ads})
@@ -23026,7 +23238,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{2f0}@anchor{gnat_rm/the_gnat_library id15}@anchor{2f1}
+@anchor{gnat_rm/the_gnat_library ada-containers-functional-sets-a-cofuse-ads}@anchor{2ef}@anchor{gnat_rm/the_gnat_library id15}@anchor{2f0}
@section @code{Ada.Containers.Functional_Sets} (@code{a-cofuse.ads})
@@ -23048,7 +23260,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{2f2}@anchor{gnat_rm/the_gnat_library ada-containers-functional-maps-a-cofuma-ads}@anchor{2f3}
+@anchor{gnat_rm/the_gnat_library ada-containers-functional-maps-a-cofuma-ads}@anchor{2f1}@anchor{gnat_rm/the_gnat_library id16}@anchor{2f2}
@section @code{Ada.Containers.Functional_Maps} (@code{a-cofuma.ads})
@@ -23070,7 +23282,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{2f4}@anchor{gnat_rm/the_gnat_library id17}@anchor{2f5}
+@anchor{gnat_rm/the_gnat_library ada-containers-bounded-holders-a-coboho-ads}@anchor{2f3}@anchor{gnat_rm/the_gnat_library id17}@anchor{2f4}
@section @code{Ada.Containers.Bounded_Holders} (@code{a-coboho.ads})
@@ -23082,7 +23294,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{2f6}@anchor{gnat_rm/the_gnat_library id18}@anchor{2f7}
+@anchor{gnat_rm/the_gnat_library ada-command-line-environment-a-colien-ads}@anchor{2f5}@anchor{gnat_rm/the_gnat_library id18}@anchor{2f6}
@section @code{Ada.Command_Line.Environment} (@code{a-colien.ads})
@@ -23095,7 +23307,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{2f8}@anchor{gnat_rm/the_gnat_library ada-command-line-remove-a-colire-ads}@anchor{2f9}
+@anchor{gnat_rm/the_gnat_library ada-command-line-remove-a-colire-ads}@anchor{2f7}@anchor{gnat_rm/the_gnat_library id19}@anchor{2f8}
@section @code{Ada.Command_Line.Remove} (@code{a-colire.ads})
@@ -23113,7 +23325,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{2fa}@anchor{gnat_rm/the_gnat_library ada-command-line-response-file-a-clrefi-ads}@anchor{2fb}
+@anchor{gnat_rm/the_gnat_library ada-command-line-response-file-a-clrefi-ads}@anchor{2f9}@anchor{gnat_rm/the_gnat_library id20}@anchor{2fa}
@section @code{Ada.Command_Line.Response_File} (@code{a-clrefi.ads})
@@ -23128,12 +23340,12 @@ see the removed argument.
@geindex handling long command lines
This child of @code{Ada.Command_Line} provides a mechanism facilities for
-getting command line arguments from a text file, called a "response file".
+getting command line arguments from a text file, called a “response file”.
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{2fc}@anchor{gnat_rm/the_gnat_library ada-direct-io-c-streams-a-diocst-ads}@anchor{2fd}
+@anchor{gnat_rm/the_gnat_library ada-direct-io-c-streams-a-diocst-ads}@anchor{2fb}@anchor{gnat_rm/the_gnat_library id21}@anchor{2fc}
@section @code{Ada.Direct_IO.C_Streams} (@code{a-diocst.ads})
@@ -23148,7 +23360,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{2fe}@anchor{gnat_rm/the_gnat_library ada-exceptions-is-null-occurrence-a-einuoc-ads}@anchor{2ff}
+@anchor{gnat_rm/the_gnat_library ada-exceptions-is-null-occurrence-a-einuoc-ads}@anchor{2fd}@anchor{gnat_rm/the_gnat_library id22}@anchor{2fe}
@section @code{Ada.Exceptions.Is_Null_Occurrence} (@code{a-einuoc.ads})
@@ -23162,7 +23374,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{300}@anchor{gnat_rm/the_gnat_library ada-exceptions-last-chance-handler-a-elchha-ads}@anchor{301}
+@anchor{gnat_rm/the_gnat_library ada-exceptions-last-chance-handler-a-elchha-ads}@anchor{2ff}@anchor{gnat_rm/the_gnat_library id23}@anchor{300}
@section @code{Ada.Exceptions.Last_Chance_Handler} (@code{a-elchha.ads})
@@ -23176,7 +23388,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{302}@anchor{gnat_rm/the_gnat_library id24}@anchor{303}
+@anchor{gnat_rm/the_gnat_library ada-exceptions-traceback-a-exctra-ads}@anchor{301}@anchor{gnat_rm/the_gnat_library id24}@anchor{302}
@section @code{Ada.Exceptions.Traceback} (@code{a-exctra.ads})
@@ -23189,7 +23401,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{304}@anchor{gnat_rm/the_gnat_library id25}@anchor{305}
+@anchor{gnat_rm/the_gnat_library ada-sequential-io-c-streams-a-siocst-ads}@anchor{303}@anchor{gnat_rm/the_gnat_library id25}@anchor{304}
@section @code{Ada.Sequential_IO.C_Streams} (@code{a-siocst.ads})
@@ -23204,7 +23416,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{306}@anchor{gnat_rm/the_gnat_library ada-streams-stream-io-c-streams-a-ssicst-ads}@anchor{307}
+@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{306}
@section @code{Ada.Streams.Stream_IO.C_Streams} (@code{a-ssicst.ads})
@@ -23219,7 +23431,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{308}@anchor{gnat_rm/the_gnat_library id27}@anchor{309}
+@anchor{gnat_rm/the_gnat_library ada-strings-unbounded-text-io-a-suteio-ads}@anchor{307}@anchor{gnat_rm/the_gnat_library id27}@anchor{308}
@section @code{Ada.Strings.Unbounded.Text_IO} (@code{a-suteio.ads})
@@ -23236,7 +23448,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{30a}@anchor{gnat_rm/the_gnat_library ada-strings-wide-unbounded-wide-text-io-a-swuwti-ads}@anchor{30b}
+@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{30a}
@section @code{Ada.Strings.Wide_Unbounded.Wide_Text_IO} (@code{a-swuwti.ads})
@@ -23253,7 +23465,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 Task_Initialization a-tasini ads,Ada Strings Wide_Unbounded Wide_Text_IO a-swuwti ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library id29}@anchor{30c}@anchor{gnat_rm/the_gnat_library ada-strings-wide-wide-unbounded-wide-wide-text-io-a-szuzti-ads}@anchor{30d}
+@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{30c}
@section @code{Ada.Strings.Wide_Wide_Unbounded.Wide_Wide_Text_IO} (@code{a-szuzti.ads})
@@ -23270,7 +23482,7 @@ wide wide strings, avoiding the necessity for an intermediate operation
with ordinary wide wide strings.
@node Ada Task_Initialization a-tasini ads,Ada Text_IO C_Streams a-tiocst ads,Ada Strings Wide_Wide_Unbounded Wide_Wide_Text_IO a-szuzti ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library ada-task-initialization-a-tasini-ads}@anchor{30e}@anchor{gnat_rm/the_gnat_library id30}@anchor{30f}
+@anchor{gnat_rm/the_gnat_library ada-task-initialization-a-tasini-ads}@anchor{30d}@anchor{gnat_rm/the_gnat_library id30}@anchor{30e}
@section @code{Ada.Task_Initialization} (@code{a-tasini.ads})
@@ -23282,7 +23494,7 @@ parameterless procedures. Note that such a handler is only invoked for
those tasks activated after the handler is set.
@node Ada Text_IO C_Streams a-tiocst ads,Ada Text_IO Reset_Standard_Files a-tirsfi ads,Ada Task_Initialization a-tasini ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library ada-text-io-c-streams-a-tiocst-ads}@anchor{310}@anchor{gnat_rm/the_gnat_library id31}@anchor{311}
+@anchor{gnat_rm/the_gnat_library ada-text-io-c-streams-a-tiocst-ads}@anchor{30f}@anchor{gnat_rm/the_gnat_library id31}@anchor{310}
@section @code{Ada.Text_IO.C_Streams} (@code{a-tiocst.ads})
@@ -23297,7 +23509,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{312}@anchor{gnat_rm/the_gnat_library id32}@anchor{313}
+@anchor{gnat_rm/the_gnat_library ada-text-io-reset-standard-files-a-tirsfi-ads}@anchor{311}@anchor{gnat_rm/the_gnat_library id32}@anchor{312}
@section @code{Ada.Text_IO.Reset_Standard_Files} (@code{a-tirsfi.ads})
@@ -23312,7 +23524,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 id33}@anchor{314}@anchor{gnat_rm/the_gnat_library ada-wide-characters-unicode-a-wichun-ads}@anchor{315}
+@anchor{gnat_rm/the_gnat_library ada-wide-characters-unicode-a-wichun-ads}@anchor{313}@anchor{gnat_rm/the_gnat_library id33}@anchor{314}
@section @code{Ada.Wide_Characters.Unicode} (@code{a-wichun.ads})
@@ -23325,7 +23537,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 id34}@anchor{316}@anchor{gnat_rm/the_gnat_library ada-wide-text-io-c-streams-a-wtcstr-ads}@anchor{317}
+@anchor{gnat_rm/the_gnat_library ada-wide-text-io-c-streams-a-wtcstr-ads}@anchor{315}@anchor{gnat_rm/the_gnat_library id34}@anchor{316}
@section @code{Ada.Wide_Text_IO.C_Streams} (@code{a-wtcstr.ads})
@@ -23340,7 +23552,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{318}@anchor{gnat_rm/the_gnat_library id35}@anchor{319}
+@anchor{gnat_rm/the_gnat_library ada-wide-text-io-reset-standard-files-a-wrstfi-ads}@anchor{317}@anchor{gnat_rm/the_gnat_library id35}@anchor{318}
@section @code{Ada.Wide_Text_IO.Reset_Standard_Files} (@code{a-wrstfi.ads})
@@ -23355,7 +23567,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 id36}@anchor{31a}@anchor{gnat_rm/the_gnat_library ada-wide-wide-characters-unicode-a-zchuni-ads}@anchor{31b}
+@anchor{gnat_rm/the_gnat_library ada-wide-wide-characters-unicode-a-zchuni-ads}@anchor{319}@anchor{gnat_rm/the_gnat_library id36}@anchor{31a}
@section @code{Ada.Wide_Wide_Characters.Unicode} (@code{a-zchuni.ads})
@@ -23368,7 +23580,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 id37}@anchor{31c}@anchor{gnat_rm/the_gnat_library ada-wide-wide-text-io-c-streams-a-ztcstr-ads}@anchor{31d}
+@anchor{gnat_rm/the_gnat_library ada-wide-wide-text-io-c-streams-a-ztcstr-ads}@anchor{31b}@anchor{gnat_rm/the_gnat_library id37}@anchor{31c}
@section @code{Ada.Wide_Wide_Text_IO.C_Streams} (@code{a-ztcstr.ads})
@@ -23383,7 +23595,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 ada-wide-wide-text-io-reset-standard-files-a-zrstfi-ads}@anchor{31e}@anchor{gnat_rm/the_gnat_library id38}@anchor{31f}
+@anchor{gnat_rm/the_gnat_library ada-wide-wide-text-io-reset-standard-files-a-zrstfi-ads}@anchor{31d}@anchor{gnat_rm/the_gnat_library id38}@anchor{31e}
@section @code{Ada.Wide_Wide_Text_IO.Reset_Standard_Files} (@code{a-zrstfi.ads})
@@ -23398,7 +23610,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{320}@anchor{gnat_rm/the_gnat_library id39}@anchor{321}
+@anchor{gnat_rm/the_gnat_library gnat-altivec-g-altive-ads}@anchor{31f}@anchor{gnat_rm/the_gnat_library id39}@anchor{320}
@section @code{GNAT.Altivec} (@code{g-altive.ads})
@@ -23411,7 +23623,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{322}@anchor{gnat_rm/the_gnat_library id40}@anchor{323}
+@anchor{gnat_rm/the_gnat_library gnat-altivec-conversions-g-altcon-ads}@anchor{321}@anchor{gnat_rm/the_gnat_library id40}@anchor{322}
@section @code{GNAT.Altivec.Conversions} (@code{g-altcon.ads})
@@ -23422,7 +23634,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 id41}@anchor{324}@anchor{gnat_rm/the_gnat_library gnat-altivec-vector-operations-g-alveop-ads}@anchor{325}
+@anchor{gnat_rm/the_gnat_library gnat-altivec-vector-operations-g-alveop-ads}@anchor{323}@anchor{gnat_rm/the_gnat_library id41}@anchor{324}
@section @code{GNAT.Altivec.Vector_Operations} (@code{g-alveop.ads})
@@ -23436,7 +23648,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{326}@anchor{gnat_rm/the_gnat_library id42}@anchor{327}
+@anchor{gnat_rm/the_gnat_library gnat-altivec-vector-types-g-alvety-ads}@anchor{325}@anchor{gnat_rm/the_gnat_library id42}@anchor{326}
@section @code{GNAT.Altivec.Vector_Types} (@code{g-alvety.ads})
@@ -23448,7 +23660,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{328}@anchor{gnat_rm/the_gnat_library id43}@anchor{329}
+@anchor{gnat_rm/the_gnat_library gnat-altivec-vector-views-g-alvevi-ads}@anchor{327}@anchor{gnat_rm/the_gnat_library id43}@anchor{328}
@section @code{GNAT.Altivec.Vector_Views} (@code{g-alvevi.ads})
@@ -23456,14 +23668,14 @@ to AltiVec facilities.
@geindex AltiVec
-This package provides public 'View' data types from/to which private
+This package provides public ‘View’ data types from/to which private
vector representations can be converted via
GNAT.Altivec.Conversions. This allows convenient access to individual
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{32a}@anchor{gnat_rm/the_gnat_library id44}@anchor{32b}
+@anchor{gnat_rm/the_gnat_library gnat-array-split-g-arrspl-ads}@anchor{329}@anchor{gnat_rm/the_gnat_library id44}@anchor{32a}
@section @code{GNAT.Array_Split} (@code{g-arrspl.ads})
@@ -23476,7 +23688,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 id45}@anchor{32c}@anchor{gnat_rm/the_gnat_library gnat-awk-g-awk-ads}@anchor{32d}
+@anchor{gnat_rm/the_gnat_library gnat-awk-g-awk-ads}@anchor{32b}@anchor{gnat_rm/the_gnat_library id45}@anchor{32c}
@section @code{GNAT.AWK} (@code{g-awk.ads})
@@ -23491,7 +23703,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 id46}@anchor{32e}@anchor{gnat_rm/the_gnat_library gnat-bind-environment-g-binenv-ads}@anchor{32f}
+@anchor{gnat_rm/the_gnat_library gnat-bind-environment-g-binenv-ads}@anchor{32d}@anchor{gnat_rm/the_gnat_library id46}@anchor{32e}
@section @code{GNAT.Bind_Environment} (@code{g-binenv.ads})
@@ -23504,7 +23716,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 id47}@anchor{330}@anchor{gnat_rm/the_gnat_library gnat-branch-prediction-g-brapre-ads}@anchor{331}
+@anchor{gnat_rm/the_gnat_library gnat-branch-prediction-g-brapre-ads}@anchor{32f}@anchor{gnat_rm/the_gnat_library id47}@anchor{330}
@section @code{GNAT.Branch_Prediction} (@code{g-brapre.ads})
@@ -23515,7 +23727,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 gnat-bounded-buffers-g-boubuf-ads}@anchor{332}@anchor{gnat_rm/the_gnat_library id48}@anchor{333}
+@anchor{gnat_rm/the_gnat_library gnat-bounded-buffers-g-boubuf-ads}@anchor{331}@anchor{gnat_rm/the_gnat_library id48}@anchor{332}
@section @code{GNAT.Bounded_Buffers} (@code{g-boubuf.ads})
@@ -23530,7 +23742,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{334}@anchor{gnat_rm/the_gnat_library id49}@anchor{335}
+@anchor{gnat_rm/the_gnat_library gnat-bounded-mailboxes-g-boumai-ads}@anchor{333}@anchor{gnat_rm/the_gnat_library id49}@anchor{334}
@section @code{GNAT.Bounded_Mailboxes} (@code{g-boumai.ads})
@@ -23543,7 +23755,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{336}@anchor{gnat_rm/the_gnat_library id50}@anchor{337}
+@anchor{gnat_rm/the_gnat_library gnat-bubble-sort-g-bubsor-ads}@anchor{335}@anchor{gnat_rm/the_gnat_library id50}@anchor{336}
@section @code{GNAT.Bubble_Sort} (@code{g-bubsor.ads})
@@ -23558,7 +23770,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 id51}@anchor{338}@anchor{gnat_rm/the_gnat_library gnat-bubble-sort-a-g-busora-ads}@anchor{339}
+@anchor{gnat_rm/the_gnat_library gnat-bubble-sort-a-g-busora-ads}@anchor{337}@anchor{gnat_rm/the_gnat_library id51}@anchor{338}
@section @code{GNAT.Bubble_Sort_A} (@code{g-busora.ads})
@@ -23574,7 +23786,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{33a}@anchor{gnat_rm/the_gnat_library id52}@anchor{33b}
+@anchor{gnat_rm/the_gnat_library gnat-bubble-sort-g-g-busorg-ads}@anchor{339}@anchor{gnat_rm/the_gnat_library id52}@anchor{33a}
@section @code{GNAT.Bubble_Sort_G} (@code{g-busorg.ads})
@@ -23590,7 +23802,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{33c}@anchor{gnat_rm/the_gnat_library id53}@anchor{33d}
+@anchor{gnat_rm/the_gnat_library gnat-byte-order-mark-g-byorma-ads}@anchor{33b}@anchor{gnat_rm/the_gnat_library id53}@anchor{33c}
@section @code{GNAT.Byte_Order_Mark} (@code{g-byorma.ads})
@@ -23601,12 +23813,12 @@ multiple instantiations.
@geindex Wide characte representations
Provides a routine which given a string, reads the start of the string to
-see whether it is one of the standard byte order marks (BOM's) which signal
+see whether it is one of the standard byte order marks (BOM’s) which signal
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{33e}@anchor{gnat_rm/the_gnat_library id54}@anchor{33f}
+@anchor{gnat_rm/the_gnat_library gnat-byte-swapping-g-bytswa-ads}@anchor{33d}@anchor{gnat_rm/the_gnat_library id54}@anchor{33e}
@section @code{GNAT.Byte_Swapping} (@code{g-bytswa.ads})
@@ -23620,7 +23832,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 id55}@anchor{340}@anchor{gnat_rm/the_gnat_library gnat-calendar-g-calend-ads}@anchor{341}
+@anchor{gnat_rm/the_gnat_library gnat-calendar-g-calend-ads}@anchor{33f}@anchor{gnat_rm/the_gnat_library id55}@anchor{340}
@section @code{GNAT.Calendar} (@code{g-calend.ads})
@@ -23634,7 +23846,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 id56}@anchor{342}@anchor{gnat_rm/the_gnat_library gnat-calendar-time-io-g-catiio-ads}@anchor{343}
+@anchor{gnat_rm/the_gnat_library gnat-calendar-time-io-g-catiio-ads}@anchor{341}@anchor{gnat_rm/the_gnat_library id56}@anchor{342}
@section @code{GNAT.Calendar.Time_IO} (@code{g-catiio.ads})
@@ -23645,7 +23857,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 id57}@anchor{344}@anchor{gnat_rm/the_gnat_library gnat-crc32-g-crc32-ads}@anchor{345}
+@anchor{gnat_rm/the_gnat_library gnat-crc32-g-crc32-ads}@anchor{343}@anchor{gnat_rm/the_gnat_library id57}@anchor{344}
@section @code{GNAT.CRC32} (@code{g-crc32.ads})
@@ -23662,7 +23874,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 id58}@anchor{346}@anchor{gnat_rm/the_gnat_library gnat-case-util-g-casuti-ads}@anchor{347}
+@anchor{gnat_rm/the_gnat_library gnat-case-util-g-casuti-ads}@anchor{345}@anchor{gnat_rm/the_gnat_library id58}@anchor{346}
@section @code{GNAT.Case_Util} (@code{g-casuti.ads})
@@ -23677,7 +23889,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 id59}@anchor{348}@anchor{gnat_rm/the_gnat_library gnat-cgi-g-cgi-ads}@anchor{349}
+@anchor{gnat_rm/the_gnat_library gnat-cgi-g-cgi-ads}@anchor{347}@anchor{gnat_rm/the_gnat_library id59}@anchor{348}
@section @code{GNAT.CGI} (@code{g-cgi.ads})
@@ -23692,7 +23904,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{34a}@anchor{gnat_rm/the_gnat_library id60}@anchor{34b}
+@anchor{gnat_rm/the_gnat_library gnat-cgi-cookie-g-cgicoo-ads}@anchor{349}@anchor{gnat_rm/the_gnat_library id60}@anchor{34a}
@section @code{GNAT.CGI.Cookie} (@code{g-cgicoo.ads})
@@ -23707,7 +23919,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{34c}@anchor{gnat_rm/the_gnat_library id61}@anchor{34d}
+@anchor{gnat_rm/the_gnat_library gnat-cgi-debug-g-cgideb-ads}@anchor{34b}@anchor{gnat_rm/the_gnat_library id61}@anchor{34c}
@section @code{GNAT.CGI.Debug} (@code{g-cgideb.ads})
@@ -23719,7 +23931,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 id62}@anchor{34e}@anchor{gnat_rm/the_gnat_library gnat-command-line-g-comlin-ads}@anchor{34f}
+@anchor{gnat_rm/the_gnat_library gnat-command-line-g-comlin-ads}@anchor{34d}@anchor{gnat_rm/the_gnat_library id62}@anchor{34e}
@section @code{GNAT.Command_Line} (@code{g-comlin.ads})
@@ -23732,7 +23944,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{350}@anchor{gnat_rm/the_gnat_library id63}@anchor{351}
+@anchor{gnat_rm/the_gnat_library gnat-compiler-version-g-comver-ads}@anchor{34f}@anchor{gnat_rm/the_gnat_library id63}@anchor{350}
@section @code{GNAT.Compiler_Version} (@code{g-comver.ads})
@@ -23750,7 +23962,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 id64}@anchor{352}@anchor{gnat_rm/the_gnat_library gnat-ctrl-c-g-ctrl-c-ads}@anchor{353}
+@anchor{gnat_rm/the_gnat_library gnat-ctrl-c-g-ctrl-c-ads}@anchor{351}@anchor{gnat_rm/the_gnat_library id64}@anchor{352}
@section @code{GNAT.Ctrl_C} (@code{g-ctrl_c.ads})
@@ -23761,7 +23973,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 id65}@anchor{354}@anchor{gnat_rm/the_gnat_library gnat-current-exception-g-curexc-ads}@anchor{355}
+@anchor{gnat_rm/the_gnat_library gnat-current-exception-g-curexc-ads}@anchor{353}@anchor{gnat_rm/the_gnat_library id65}@anchor{354}
@section @code{GNAT.Current_Exception} (@code{g-curexc.ads})
@@ -23778,7 +23990,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{356}@anchor{gnat_rm/the_gnat_library id66}@anchor{357}
+@anchor{gnat_rm/the_gnat_library gnat-debug-pools-g-debpoo-ads}@anchor{355}@anchor{gnat_rm/the_gnat_library id66}@anchor{356}
@section @code{GNAT.Debug_Pools} (@code{g-debpoo.ads})
@@ -23792,10 +24004,10 @@ obtaining information about exceptions provided by Ada 83 compilers.
Provide a debugging storage pools that helps tracking memory corruption
problems.
-See @code{The GNAT Debug_Pool Facility} section in the @cite{GNAT User's Guide}.
+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{358}@anchor{gnat_rm/the_gnat_library id67}@anchor{359}
+@anchor{gnat_rm/the_gnat_library gnat-debug-utilities-g-debuti-ads}@anchor{357}@anchor{gnat_rm/the_gnat_library id67}@anchor{358}
@section @code{GNAT.Debug_Utilities} (@code{g-debuti.ads})
@@ -23808,7 +24020,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 gnat-decode-string-g-decstr-ads}@anchor{35a}@anchor{gnat_rm/the_gnat_library id68}@anchor{35b}
+@anchor{gnat_rm/the_gnat_library gnat-decode-string-g-decstr-ads}@anchor{359}@anchor{gnat_rm/the_gnat_library id68}@anchor{35a}
@section @code{GNAT.Decode_String} (@code{g-decstr.ads})
@@ -23832,7 +24044,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{35c}@anchor{gnat_rm/the_gnat_library id69}@anchor{35d}
+@anchor{gnat_rm/the_gnat_library gnat-decode-utf8-string-g-deutst-ads}@anchor{35b}@anchor{gnat_rm/the_gnat_library id69}@anchor{35c}
@section @code{GNAT.Decode_UTF8_String} (@code{g-deutst.ads})
@@ -23853,7 +24065,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 id70}@anchor{35e}@anchor{gnat_rm/the_gnat_library gnat-directory-operations-g-dirope-ads}@anchor{35f}
+@anchor{gnat_rm/the_gnat_library gnat-directory-operations-g-dirope-ads}@anchor{35d}@anchor{gnat_rm/the_gnat_library id70}@anchor{35e}
@section @code{GNAT.Directory_Operations} (@code{g-dirope.ads})
@@ -23866,7 +24078,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 id71}@anchor{360}@anchor{gnat_rm/the_gnat_library gnat-directory-operations-iteration-g-diopit-ads}@anchor{361}
+@anchor{gnat_rm/the_gnat_library gnat-directory-operations-iteration-g-diopit-ads}@anchor{35f}@anchor{gnat_rm/the_gnat_library id71}@anchor{360}
@section @code{GNAT.Directory_Operations.Iteration} (@code{g-diopit.ads})
@@ -23878,7 +24090,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 id72}@anchor{362}@anchor{gnat_rm/the_gnat_library gnat-dynamic-htables-g-dynhta-ads}@anchor{363}
+@anchor{gnat_rm/the_gnat_library gnat-dynamic-htables-g-dynhta-ads}@anchor{361}@anchor{gnat_rm/the_gnat_library id72}@anchor{362}
@section @code{GNAT.Dynamic_HTables} (@code{g-dynhta.ads})
@@ -23896,7 +24108,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{364}@anchor{gnat_rm/the_gnat_library id73}@anchor{365}
+@anchor{gnat_rm/the_gnat_library gnat-dynamic-tables-g-dyntab-ads}@anchor{363}@anchor{gnat_rm/the_gnat_library id73}@anchor{364}
@section @code{GNAT.Dynamic_Tables} (@code{g-dyntab.ads})
@@ -23916,7 +24128,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 id74}@anchor{366}@anchor{gnat_rm/the_gnat_library gnat-encode-string-g-encstr-ads}@anchor{367}
+@anchor{gnat_rm/the_gnat_library gnat-encode-string-g-encstr-ads}@anchor{365}@anchor{gnat_rm/the_gnat_library id74}@anchor{366}
@section @code{GNAT.Encode_String} (@code{g-encstr.ads})
@@ -23938,7 +24150,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{368}@anchor{gnat_rm/the_gnat_library id75}@anchor{369}
+@anchor{gnat_rm/the_gnat_library gnat-encode-utf8-string-g-enutst-ads}@anchor{367}@anchor{gnat_rm/the_gnat_library id75}@anchor{368}
@section @code{GNAT.Encode_UTF8_String} (@code{g-enutst.ads})
@@ -23959,7 +24171,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{36a}@anchor{gnat_rm/the_gnat_library id76}@anchor{36b}
+@anchor{gnat_rm/the_gnat_library gnat-exception-actions-g-excact-ads}@anchor{369}@anchor{gnat_rm/the_gnat_library id76}@anchor{36a}
@section @code{GNAT.Exception_Actions} (@code{g-excact.ads})
@@ -23972,7 +24184,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{36c}@anchor{gnat_rm/the_gnat_library id77}@anchor{36d}
+@anchor{gnat_rm/the_gnat_library gnat-exception-traces-g-exctra-ads}@anchor{36b}@anchor{gnat_rm/the_gnat_library id77}@anchor{36c}
@section @code{GNAT.Exception_Traces} (@code{g-exctra.ads})
@@ -23986,7 +24198,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 id78}@anchor{36e}@anchor{gnat_rm/the_gnat_library gnat-exceptions-g-except-ads}@anchor{36f}
+@anchor{gnat_rm/the_gnat_library gnat-exceptions-g-except-ads}@anchor{36d}@anchor{gnat_rm/the_gnat_library id78}@anchor{36e}
@section @code{GNAT.Exceptions} (@code{g-except.ads})
@@ -24007,7 +24219,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 id79}@anchor{370}@anchor{gnat_rm/the_gnat_library gnat-expect-g-expect-ads}@anchor{371}
+@anchor{gnat_rm/the_gnat_library gnat-expect-g-expect-ads}@anchor{36f}@anchor{gnat_rm/the_gnat_library id79}@anchor{370}
@section @code{GNAT.Expect} (@code{g-expect.ads})
@@ -24023,7 +24235,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 id80}@anchor{372}@anchor{gnat_rm/the_gnat_library gnat-expect-tty-g-exptty-ads}@anchor{373}
+@anchor{gnat_rm/the_gnat_library gnat-expect-tty-g-exptty-ads}@anchor{371}@anchor{gnat_rm/the_gnat_library id80}@anchor{372}
@section @code{GNAT.Expect.TTY} (@code{g-exptty.ads})
@@ -24035,7 +24247,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 id81}@anchor{374}@anchor{gnat_rm/the_gnat_library gnat-float-control-g-flocon-ads}@anchor{375}
+@anchor{gnat_rm/the_gnat_library gnat-float-control-g-flocon-ads}@anchor{373}@anchor{gnat_rm/the_gnat_library id81}@anchor{374}
@section @code{GNAT.Float_Control} (@code{g-flocon.ads})
@@ -24049,7 +24261,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 id82}@anchor{376}@anchor{gnat_rm/the_gnat_library gnat-formatted-string-g-forstr-ads}@anchor{377}
+@anchor{gnat_rm/the_gnat_library gnat-formatted-string-g-forstr-ads}@anchor{375}@anchor{gnat_rm/the_gnat_library id82}@anchor{376}
@section @code{GNAT.Formatted_String} (@code{g-forstr.ads})
@@ -24064,7 +24276,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 id83}@anchor{378}@anchor{gnat_rm/the_gnat_library gnat-heap-sort-g-heasor-ads}@anchor{379}
+@anchor{gnat_rm/the_gnat_library gnat-heap-sort-g-heasor-ads}@anchor{377}@anchor{gnat_rm/the_gnat_library id83}@anchor{378}
@section @code{GNAT.Heap_Sort} (@code{g-heasor.ads})
@@ -24078,7 +24290,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 gnat-heap-sort-a-g-hesora-ads}@anchor{37a}@anchor{gnat_rm/the_gnat_library id84}@anchor{37b}
+@anchor{gnat_rm/the_gnat_library gnat-heap-sort-a-g-hesora-ads}@anchor{379}@anchor{gnat_rm/the_gnat_library id84}@anchor{37a}
@section @code{GNAT.Heap_Sort_A} (@code{g-hesora.ads})
@@ -24094,7 +24306,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 id85}@anchor{37c}@anchor{gnat_rm/the_gnat_library gnat-heap-sort-g-g-hesorg-ads}@anchor{37d}
+@anchor{gnat_rm/the_gnat_library gnat-heap-sort-g-g-hesorg-ads}@anchor{37b}@anchor{gnat_rm/the_gnat_library id85}@anchor{37c}
@section @code{GNAT.Heap_Sort_G} (@code{g-hesorg.ads})
@@ -24108,7 +24320,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 id86}@anchor{37e}@anchor{gnat_rm/the_gnat_library gnat-htable-g-htable-ads}@anchor{37f}
+@anchor{gnat_rm/the_gnat_library gnat-htable-g-htable-ads}@anchor{37d}@anchor{gnat_rm/the_gnat_library id86}@anchor{37e}
@section @code{GNAT.HTable} (@code{g-htable.ads})
@@ -24121,7 +24333,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 id87}@anchor{380}@anchor{gnat_rm/the_gnat_library gnat-io-g-io-ads}@anchor{381}
+@anchor{gnat_rm/the_gnat_library gnat-io-g-io-ads}@anchor{37f}@anchor{gnat_rm/the_gnat_library id87}@anchor{380}
@section @code{GNAT.IO} (@code{g-io.ads})
@@ -24137,7 +24349,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 id88}@anchor{382}@anchor{gnat_rm/the_gnat_library gnat-io-aux-g-io-aux-ads}@anchor{383}
+@anchor{gnat_rm/the_gnat_library gnat-io-aux-g-io-aux-ads}@anchor{381}@anchor{gnat_rm/the_gnat_library id88}@anchor{382}
@section @code{GNAT.IO_Aux} (@code{g-io_aux.ads})
@@ -24151,7 +24363,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 id89}@anchor{384}@anchor{gnat_rm/the_gnat_library gnat-lock-files-g-locfil-ads}@anchor{385}
+@anchor{gnat_rm/the_gnat_library gnat-lock-files-g-locfil-ads}@anchor{383}@anchor{gnat_rm/the_gnat_library id89}@anchor{384}
@section @code{GNAT.Lock_Files} (@code{g-locfil.ads})
@@ -24165,7 +24377,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 id90}@anchor{386}@anchor{gnat_rm/the_gnat_library gnat-mbbs-discrete-random-g-mbdira-ads}@anchor{387}
+@anchor{gnat_rm/the_gnat_library gnat-mbbs-discrete-random-g-mbdira-ads}@anchor{385}@anchor{gnat_rm/the_gnat_library id90}@anchor{386}
@section @code{GNAT.MBBS_Discrete_Random} (@code{g-mbdira.ads})
@@ -24177,7 +24389,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 id91}@anchor{388}@anchor{gnat_rm/the_gnat_library gnat-mbbs-float-random-g-mbflra-ads}@anchor{389}
+@anchor{gnat_rm/the_gnat_library gnat-mbbs-float-random-g-mbflra-ads}@anchor{387}@anchor{gnat_rm/the_gnat_library id91}@anchor{388}
@section @code{GNAT.MBBS_Float_Random} (@code{g-mbflra.ads})
@@ -24189,7 +24401,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 id92}@anchor{38a}@anchor{gnat_rm/the_gnat_library gnat-md5-g-md5-ads}@anchor{38b}
+@anchor{gnat_rm/the_gnat_library gnat-md5-g-md5-ads}@anchor{389}@anchor{gnat_rm/the_gnat_library id92}@anchor{38a}
@section @code{GNAT.MD5} (@code{g-md5.ads})
@@ -24202,7 +24414,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 id93}@anchor{38c}@anchor{gnat_rm/the_gnat_library gnat-memory-dump-g-memdum-ads}@anchor{38d}
+@anchor{gnat_rm/the_gnat_library gnat-memory-dump-g-memdum-ads}@anchor{38b}@anchor{gnat_rm/the_gnat_library id93}@anchor{38c}
@section @code{GNAT.Memory_Dump} (@code{g-memdum.ads})
@@ -24215,7 +24427,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{38e}@anchor{gnat_rm/the_gnat_library id94}@anchor{38f}
+@anchor{gnat_rm/the_gnat_library gnat-most-recent-exception-g-moreex-ads}@anchor{38d}@anchor{gnat_rm/the_gnat_library id94}@anchor{38e}
@section @code{GNAT.Most_Recent_Exception} (@code{g-moreex.ads})
@@ -24229,7 +24441,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{390}@anchor{gnat_rm/the_gnat_library id95}@anchor{391}
+@anchor{gnat_rm/the_gnat_library gnat-os-lib-g-os-lib-ads}@anchor{38f}@anchor{gnat_rm/the_gnat_library id95}@anchor{390}
@section @code{GNAT.OS_Lib} (@code{g-os_lib.ads})
@@ -24245,7 +24457,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{392}@anchor{gnat_rm/the_gnat_library id96}@anchor{393}
+@anchor{gnat_rm/the_gnat_library gnat-perfect-hash-generators-g-pehage-ads}@anchor{391}@anchor{gnat_rm/the_gnat_library id96}@anchor{392}
@section @code{GNAT.Perfect_Hash_Generators} (@code{g-pehage.ads})
@@ -24263,7 +24475,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{394}@anchor{gnat_rm/the_gnat_library id97}@anchor{395}
+@anchor{gnat_rm/the_gnat_library gnat-random-numbers-g-rannum-ads}@anchor{393}@anchor{gnat_rm/the_gnat_library id97}@anchor{394}
@section @code{GNAT.Random_Numbers} (@code{g-rannum.ads})
@@ -24275,7 +24487,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 id98}@anchor{396}@anchor{gnat_rm/the_gnat_library gnat-regexp-g-regexp-ads}@anchor{25b}
+@anchor{gnat_rm/the_gnat_library gnat-regexp-g-regexp-ads}@anchor{25a}@anchor{gnat_rm/the_gnat_library id98}@anchor{395}
@section @code{GNAT.Regexp} (@code{g-regexp.ads})
@@ -24288,10 +24500,10 @@ standard Ada library and are more convenient to use.
A simple implementation of regular expressions, using a subset of regular
expression syntax copied from familiar Unix style utilities. This is the
simplest of the three pattern matching packages provided, and is particularly
-suitable for 'file globbing' applications.
+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 id99}@anchor{397}@anchor{gnat_rm/the_gnat_library gnat-registry-g-regist-ads}@anchor{398}
+@anchor{gnat_rm/the_gnat_library gnat-registry-g-regist-ads}@anchor{396}@anchor{gnat_rm/the_gnat_library id99}@anchor{397}
@section @code{GNAT.Registry} (@code{g-regist.ads})
@@ -24305,7 +24517,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 id100}@anchor{399}@anchor{gnat_rm/the_gnat_library gnat-regpat-g-regpat-ads}@anchor{39a}
+@anchor{gnat_rm/the_gnat_library gnat-regpat-g-regpat-ads}@anchor{398}@anchor{gnat_rm/the_gnat_library id100}@anchor{399}
@section @code{GNAT.Regpat} (@code{g-regpat.ads})
@@ -24320,7 +24532,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 id101}@anchor{39b}@anchor{gnat_rm/the_gnat_library gnat-rewrite-data-g-rewdat-ads}@anchor{39c}
+@anchor{gnat_rm/the_gnat_library gnat-rewrite-data-g-rewdat-ads}@anchor{39a}@anchor{gnat_rm/the_gnat_library id101}@anchor{39b}
@section @code{GNAT.Rewrite_Data} (@code{g-rewdat.ads})
@@ -24334,7 +24546,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 gnat-secondary-stack-info-g-sestin-ads}@anchor{39d}@anchor{gnat_rm/the_gnat_library id102}@anchor{39e}
+@anchor{gnat_rm/the_gnat_library gnat-secondary-stack-info-g-sestin-ads}@anchor{39c}@anchor{gnat_rm/the_gnat_library id102}@anchor{39d}
@section @code{GNAT.Secondary_Stack_Info} (@code{g-sestin.ads})
@@ -24342,11 +24554,11 @@ this interface usable for large files or socket streams.
@geindex Secondary Stack Info
-Provide the capability to query the high water mark of the current task's
+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 id103}@anchor{39f}@anchor{gnat_rm/the_gnat_library gnat-semaphores-g-semaph-ads}@anchor{3a0}
+@anchor{gnat_rm/the_gnat_library gnat-semaphores-g-semaph-ads}@anchor{39e}@anchor{gnat_rm/the_gnat_library id103}@anchor{39f}
@section @code{GNAT.Semaphores} (@code{g-semaph.ads})
@@ -24357,7 +24569,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{3a1}@anchor{gnat_rm/the_gnat_library id104}@anchor{3a2}
+@anchor{gnat_rm/the_gnat_library gnat-serial-communications-g-sercom-ads}@anchor{3a0}@anchor{gnat_rm/the_gnat_library id104}@anchor{3a1}
@section @code{GNAT.Serial_Communications} (@code{g-sercom.ads})
@@ -24369,7 +24581,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{3a3}@anchor{gnat_rm/the_gnat_library id105}@anchor{3a4}
+@anchor{gnat_rm/the_gnat_library gnat-sha1-g-sha1-ads}@anchor{3a2}@anchor{gnat_rm/the_gnat_library id105}@anchor{3a3}
@section @code{GNAT.SHA1} (@code{g-sha1.ads})
@@ -24382,7 +24594,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{3a5}@anchor{gnat_rm/the_gnat_library id106}@anchor{3a6}
+@anchor{gnat_rm/the_gnat_library gnat-sha224-g-sha224-ads}@anchor{3a4}@anchor{gnat_rm/the_gnat_library id106}@anchor{3a5}
@section @code{GNAT.SHA224} (@code{g-sha224.ads})
@@ -24395,7 +24607,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{3a7}@anchor{gnat_rm/the_gnat_library id107}@anchor{3a8}
+@anchor{gnat_rm/the_gnat_library gnat-sha256-g-sha256-ads}@anchor{3a6}@anchor{gnat_rm/the_gnat_library id107}@anchor{3a7}
@section @code{GNAT.SHA256} (@code{g-sha256.ads})
@@ -24408,7 +24620,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 id108}@anchor{3a9}@anchor{gnat_rm/the_gnat_library gnat-sha384-g-sha384-ads}@anchor{3aa}
+@anchor{gnat_rm/the_gnat_library gnat-sha384-g-sha384-ads}@anchor{3a8}@anchor{gnat_rm/the_gnat_library id108}@anchor{3a9}
@section @code{GNAT.SHA384} (@code{g-sha384.ads})
@@ -24421,7 +24633,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 id109}@anchor{3ab}@anchor{gnat_rm/the_gnat_library gnat-sha512-g-sha512-ads}@anchor{3ac}
+@anchor{gnat_rm/the_gnat_library gnat-sha512-g-sha512-ads}@anchor{3aa}@anchor{gnat_rm/the_gnat_library id109}@anchor{3ab}
@section @code{GNAT.SHA512} (@code{g-sha512.ads})
@@ -24434,7 +24646,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 gnat-signals-g-signal-ads}@anchor{3ad}@anchor{gnat_rm/the_gnat_library id110}@anchor{3ae}
+@anchor{gnat_rm/the_gnat_library gnat-signals-g-signal-ads}@anchor{3ac}@anchor{gnat_rm/the_gnat_library id110}@anchor{3ad}
@section @code{GNAT.Signals} (@code{g-signal.ads})
@@ -24446,7 +24658,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{3af}@anchor{gnat_rm/the_gnat_library id111}@anchor{3b0}
+@anchor{gnat_rm/the_gnat_library gnat-sockets-g-socket-ads}@anchor{3ae}@anchor{gnat_rm/the_gnat_library id111}@anchor{3af}
@section @code{GNAT.Sockets} (@code{g-socket.ads})
@@ -24461,7 +24673,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{3b1}@anchor{gnat_rm/the_gnat_library id112}@anchor{3b2}
+@anchor{gnat_rm/the_gnat_library gnat-source-info-g-souinf-ads}@anchor{3b0}@anchor{gnat_rm/the_gnat_library id112}@anchor{3b1}
@section @code{GNAT.Source_Info} (@code{g-souinf.ads})
@@ -24475,7 +24687,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 gnat-spelling-checker-g-speche-ads}@anchor{3b3}@anchor{gnat_rm/the_gnat_library id113}@anchor{3b4}
+@anchor{gnat_rm/the_gnat_library gnat-spelling-checker-g-speche-ads}@anchor{3b2}@anchor{gnat_rm/the_gnat_library id113}@anchor{3b3}
@section @code{GNAT.Spelling_Checker} (@code{g-speche.ads})
@@ -24487,7 +24699,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{3b5}@anchor{gnat_rm/the_gnat_library id114}@anchor{3b6}
+@anchor{gnat_rm/the_gnat_library gnat-spelling-checker-generic-g-spchge-ads}@anchor{3b4}@anchor{gnat_rm/the_gnat_library id114}@anchor{3b5}
@section @code{GNAT.Spelling_Checker_Generic} (@code{g-spchge.ads})
@@ -24500,7 +24712,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{3b7}@anchor{gnat_rm/the_gnat_library id115}@anchor{3b8}
+@anchor{gnat_rm/the_gnat_library gnat-spitbol-patterns-g-spipat-ads}@anchor{3b6}@anchor{gnat_rm/the_gnat_library id115}@anchor{3b7}
@section @code{GNAT.Spitbol.Patterns} (@code{g-spipat.ads})
@@ -24516,7 +24728,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 id116}@anchor{3b9}@anchor{gnat_rm/the_gnat_library gnat-spitbol-g-spitbo-ads}@anchor{3ba}
+@anchor{gnat_rm/the_gnat_library gnat-spitbol-g-spitbo-ads}@anchor{3b8}@anchor{gnat_rm/the_gnat_library id116}@anchor{3b9}
@section @code{GNAT.Spitbol} (@code{g-spitbo.ads})
@@ -24531,7 +24743,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 gnat-spitbol-table-boolean-g-sptabo-ads}@anchor{3bb}@anchor{gnat_rm/the_gnat_library id117}@anchor{3bc}
+@anchor{gnat_rm/the_gnat_library gnat-spitbol-table-boolean-g-sptabo-ads}@anchor{3ba}@anchor{gnat_rm/the_gnat_library id117}@anchor{3bb}
@section @code{GNAT.Spitbol.Table_Boolean} (@code{g-sptabo.ads})
@@ -24546,7 +24758,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{3bd}@anchor{gnat_rm/the_gnat_library id118}@anchor{3be}
+@anchor{gnat_rm/the_gnat_library gnat-spitbol-table-integer-g-sptain-ads}@anchor{3bc}@anchor{gnat_rm/the_gnat_library id118}@anchor{3bd}
@section @code{GNAT.Spitbol.Table_Integer} (@code{g-sptain.ads})
@@ -24563,7 +24775,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 id119}@anchor{3bf}@anchor{gnat_rm/the_gnat_library gnat-spitbol-table-vstring-g-sptavs-ads}@anchor{3c0}
+@anchor{gnat_rm/the_gnat_library gnat-spitbol-table-vstring-g-sptavs-ads}@anchor{3be}@anchor{gnat_rm/the_gnat_library id119}@anchor{3bf}
@section @code{GNAT.Spitbol.Table_VString} (@code{g-sptavs.ads})
@@ -24580,7 +24792,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 id120}@anchor{3c1}@anchor{gnat_rm/the_gnat_library gnat-sse-g-sse-ads}@anchor{3c2}
+@anchor{gnat_rm/the_gnat_library gnat-sse-g-sse-ads}@anchor{3c0}@anchor{gnat_rm/the_gnat_library id120}@anchor{3c1}
@section @code{GNAT.SSE} (@code{g-sse.ads})
@@ -24592,7 +24804,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{3c3}@anchor{gnat_rm/the_gnat_library id121}@anchor{3c4}
+@anchor{gnat_rm/the_gnat_library gnat-sse-vector-types-g-ssvety-ads}@anchor{3c2}@anchor{gnat_rm/the_gnat_library id121}@anchor{3c3}
@section @code{GNAT.SSE.Vector_Types} (@code{g-ssvety.ads})
@@ -24601,7 +24813,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{3c5}@anchor{gnat_rm/the_gnat_library id122}@anchor{3c6}
+@anchor{gnat_rm/the_gnat_library gnat-string-hash-g-strhas-ads}@anchor{3c4}@anchor{gnat_rm/the_gnat_library id122}@anchor{3c5}
@section @code{GNAT.String_Hash} (@code{g-strhas.ads})
@@ -24613,7 +24825,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 id123}@anchor{3c7}@anchor{gnat_rm/the_gnat_library gnat-strings-g-string-ads}@anchor{3c8}
+@anchor{gnat_rm/the_gnat_library gnat-strings-g-string-ads}@anchor{3c6}@anchor{gnat_rm/the_gnat_library id123}@anchor{3c7}
@section @code{GNAT.Strings} (@code{g-string.ads})
@@ -24623,7 +24835,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{3c9}@anchor{gnat_rm/the_gnat_library id124}@anchor{3ca}
+@anchor{gnat_rm/the_gnat_library gnat-string-split-g-strspl-ads}@anchor{3c8}@anchor{gnat_rm/the_gnat_library id124}@anchor{3c9}
@section @code{GNAT.String_Split} (@code{g-strspl.ads})
@@ -24637,7 +24849,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 id125}@anchor{3cb}@anchor{gnat_rm/the_gnat_library gnat-table-g-table-ads}@anchor{3cc}
+@anchor{gnat_rm/the_gnat_library gnat-table-g-table-ads}@anchor{3ca}@anchor{gnat_rm/the_gnat_library id125}@anchor{3cb}
@section @code{GNAT.Table} (@code{g-table.ads})
@@ -24657,7 +24869,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 id126}@anchor{3cd}@anchor{gnat_rm/the_gnat_library gnat-task-lock-g-tasloc-ads}@anchor{3ce}
+@anchor{gnat_rm/the_gnat_library gnat-task-lock-g-tasloc-ads}@anchor{3cc}@anchor{gnat_rm/the_gnat_library id126}@anchor{3cd}
@section @code{GNAT.Task_Lock} (@code{g-tasloc.ads})
@@ -24674,7 +24886,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 id127}@anchor{3cf}@anchor{gnat_rm/the_gnat_library gnat-time-stamp-g-timsta-ads}@anchor{3d0}
+@anchor{gnat_rm/the_gnat_library gnat-time-stamp-g-timsta-ads}@anchor{3ce}@anchor{gnat_rm/the_gnat_library id127}@anchor{3cf}
@section @code{GNAT.Time_Stamp} (@code{g-timsta.ads})
@@ -24689,7 +24901,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 gnat-threads-g-thread-ads}@anchor{3d1}@anchor{gnat_rm/the_gnat_library id128}@anchor{3d2}
+@anchor{gnat_rm/the_gnat_library gnat-threads-g-thread-ads}@anchor{3d0}@anchor{gnat_rm/the_gnat_library id128}@anchor{3d1}
@section @code{GNAT.Threads} (@code{g-thread.ads})
@@ -24706,7 +24918,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 id129}@anchor{3d3}@anchor{gnat_rm/the_gnat_library gnat-traceback-g-traceb-ads}@anchor{3d4}
+@anchor{gnat_rm/the_gnat_library gnat-traceback-g-traceb-ads}@anchor{3d2}@anchor{gnat_rm/the_gnat_library id129}@anchor{3d3}
@section @code{GNAT.Traceback} (@code{g-traceb.ads})
@@ -24718,7 +24930,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 id130}@anchor{3d5}@anchor{gnat_rm/the_gnat_library gnat-traceback-symbolic-g-trasym-ads}@anchor{3d6}
+@anchor{gnat_rm/the_gnat_library gnat-traceback-symbolic-g-trasym-ads}@anchor{3d4}@anchor{gnat_rm/the_gnat_library id130}@anchor{3d5}
@section @code{GNAT.Traceback.Symbolic} (@code{g-trasym.ads})
@@ -24727,7 +24939,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 id131}@anchor{3d7}@anchor{gnat_rm/the_gnat_library gnat-utf-32-g-table-ads}@anchor{3d8}
+@anchor{gnat_rm/the_gnat_library gnat-utf-32-g-table-ads}@anchor{3d6}@anchor{gnat_rm/the_gnat_library id131}@anchor{3d7}
@section @code{GNAT.UTF_32} (@code{g-table.ads})
@@ -24746,7 +24958,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{3d9}@anchor{gnat_rm/the_gnat_library id132}@anchor{3da}
+@anchor{gnat_rm/the_gnat_library gnat-wide-spelling-checker-g-u3spch-ads}@anchor{3d8}@anchor{gnat_rm/the_gnat_library id132}@anchor{3d9}
@section @code{GNAT.Wide_Spelling_Checker} (@code{g-u3spch.ads})
@@ -24759,7 +24971,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{3db}@anchor{gnat_rm/the_gnat_library id133}@anchor{3dc}
+@anchor{gnat_rm/the_gnat_library gnat-wide-spelling-checker-g-wispch-ads}@anchor{3da}@anchor{gnat_rm/the_gnat_library id133}@anchor{3db}
@section @code{GNAT.Wide_Spelling_Checker} (@code{g-wispch.ads})
@@ -24771,7 +24983,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 id134}@anchor{3dd}@anchor{gnat_rm/the_gnat_library gnat-wide-string-split-g-wistsp-ads}@anchor{3de}
+@anchor{gnat_rm/the_gnat_library gnat-wide-string-split-g-wistsp-ads}@anchor{3dc}@anchor{gnat_rm/the_gnat_library id134}@anchor{3dd}
@section @code{GNAT.Wide_String_Split} (@code{g-wistsp.ads})
@@ -24785,7 +24997,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{3df}@anchor{gnat_rm/the_gnat_library id135}@anchor{3e0}
+@anchor{gnat_rm/the_gnat_library gnat-wide-wide-spelling-checker-g-zspche-ads}@anchor{3de}@anchor{gnat_rm/the_gnat_library id135}@anchor{3df}
@section @code{GNAT.Wide_Wide_Spelling_Checker} (@code{g-zspche.ads})
@@ -24797,7 +25009,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{3e1}@anchor{gnat_rm/the_gnat_library id136}@anchor{3e2}
+@anchor{gnat_rm/the_gnat_library gnat-wide-wide-string-split-g-zistsp-ads}@anchor{3e0}@anchor{gnat_rm/the_gnat_library id136}@anchor{3e1}
@section @code{GNAT.Wide_Wide_String_Split} (@code{g-zistsp.ads})
@@ -24811,7 +25023,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{3e3}@anchor{gnat_rm/the_gnat_library id137}@anchor{3e4}
+@anchor{gnat_rm/the_gnat_library id137}@anchor{3e2}@anchor{gnat_rm/the_gnat_library interfaces-c-extensions-i-cexten-ads}@anchor{3e3}
@section @code{Interfaces.C.Extensions} (@code{i-cexten.ads})
@@ -24822,7 +25034,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 id138}@anchor{3e5}@anchor{gnat_rm/the_gnat_library interfaces-c-streams-i-cstrea-ads}@anchor{3e6}
+@anchor{gnat_rm/the_gnat_library id138}@anchor{3e4}@anchor{gnat_rm/the_gnat_library interfaces-c-streams-i-cstrea-ads}@anchor{3e5}
@section @code{Interfaces.C.Streams} (@code{i-cstrea.ads})
@@ -24835,7 +25047,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 interfaces-packed-decimal-i-pacdec-ads}@anchor{3e7}@anchor{gnat_rm/the_gnat_library id139}@anchor{3e8}
+@anchor{gnat_rm/the_gnat_library id139}@anchor{3e6}@anchor{gnat_rm/the_gnat_library interfaces-packed-decimal-i-pacdec-ads}@anchor{3e7}
@section @code{Interfaces.Packed_Decimal} (@code{i-pacdec.ads})
@@ -24850,7 +25062,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 interfaces-vxworks-i-vxwork-ads}@anchor{3e9}@anchor{gnat_rm/the_gnat_library id140}@anchor{3ea}
+@anchor{gnat_rm/the_gnat_library id140}@anchor{3e8}@anchor{gnat_rm/the_gnat_library interfaces-vxworks-i-vxwork-ads}@anchor{3e9}
@section @code{Interfaces.VxWorks} (@code{i-vxwork.ads})
@@ -24866,7 +25078,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{3eb}@anchor{gnat_rm/the_gnat_library id141}@anchor{3ec}
+@anchor{gnat_rm/the_gnat_library id141}@anchor{3ea}@anchor{gnat_rm/the_gnat_library interfaces-vxworks-int-connection-i-vxinco-ads}@anchor{3eb}
@section @code{Interfaces.VxWorks.Int_Connection} (@code{i-vxinco.ads})
@@ -24882,7 +25094,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{3ed}@anchor{gnat_rm/the_gnat_library id142}@anchor{3ee}
+@anchor{gnat_rm/the_gnat_library id142}@anchor{3ec}@anchor{gnat_rm/the_gnat_library interfaces-vxworks-io-i-vxwoio-ads}@anchor{3ed}
@section @code{Interfaces.VxWorks.IO} (@code{i-vxwoio.ads})
@@ -24905,7 +25117,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{3ef}@anchor{gnat_rm/the_gnat_library id143}@anchor{3f0}
+@anchor{gnat_rm/the_gnat_library id143}@anchor{3ee}@anchor{gnat_rm/the_gnat_library system-address-image-s-addima-ads}@anchor{3ef}
@section @code{System.Address_Image} (@code{s-addima.ads})
@@ -24921,7 +25133,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 id144}@anchor{3f1}@anchor{gnat_rm/the_gnat_library system-assertions-s-assert-ads}@anchor{3f2}
+@anchor{gnat_rm/the_gnat_library id144}@anchor{3f0}@anchor{gnat_rm/the_gnat_library system-assertions-s-assert-ads}@anchor{3f1}
@section @code{System.Assertions} (@code{s-assert.ads})
@@ -24937,7 +25149,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 id145}@anchor{3f3}@anchor{gnat_rm/the_gnat_library system-atomic-counters-s-atocou-ads}@anchor{3f4}
+@anchor{gnat_rm/the_gnat_library id145}@anchor{3f2}@anchor{gnat_rm/the_gnat_library system-atomic-counters-s-atocou-ads}@anchor{3f3}
@section @code{System.Atomic_Counters} (@code{s-atocou.ads})
@@ -24951,7 +25163,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{3f5}@anchor{gnat_rm/the_gnat_library id146}@anchor{3f6}
+@anchor{gnat_rm/the_gnat_library id146}@anchor{3f4}@anchor{gnat_rm/the_gnat_library system-memory-s-memory-ads}@anchor{3f5}
@section @code{System.Memory} (@code{s-memory.ads})
@@ -24969,7 +25181,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 id147}@anchor{3f7}@anchor{gnat_rm/the_gnat_library system-multiprocessors-s-multip-ads}@anchor{3f8}
+@anchor{gnat_rm/the_gnat_library id147}@anchor{3f6}@anchor{gnat_rm/the_gnat_library system-multiprocessors-s-multip-ads}@anchor{3f7}
@section @code{System.Multiprocessors} (@code{s-multip.ads})
@@ -24982,7 +25194,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{3f9}@anchor{gnat_rm/the_gnat_library id148}@anchor{3fa}
+@anchor{gnat_rm/the_gnat_library id148}@anchor{3f8}@anchor{gnat_rm/the_gnat_library system-multiprocessors-dispatching-domains-s-mudido-ads}@anchor{3f9}
@section @code{System.Multiprocessors.Dispatching_Domains} (@code{s-mudido.ads})
@@ -24995,7 +25207,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 id149}@anchor{3fb}@anchor{gnat_rm/the_gnat_library system-partition-interface-s-parint-ads}@anchor{3fc}
+@anchor{gnat_rm/the_gnat_library id149}@anchor{3fa}@anchor{gnat_rm/the_gnat_library system-partition-interface-s-parint-ads}@anchor{3fb}
@section @code{System.Partition_Interface} (@code{s-parint.ads})
@@ -25008,7 +25220,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 id150}@anchor{3fd}@anchor{gnat_rm/the_gnat_library system-pool-global-s-pooglo-ads}@anchor{3fe}
+@anchor{gnat_rm/the_gnat_library id150}@anchor{3fc}@anchor{gnat_rm/the_gnat_library system-pool-global-s-pooglo-ads}@anchor{3fd}
@section @code{System.Pool_Global} (@code{s-pooglo.ads})
@@ -25025,7 +25237,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{3ff}@anchor{gnat_rm/the_gnat_library id151}@anchor{400}
+@anchor{gnat_rm/the_gnat_library id151}@anchor{3fe}@anchor{gnat_rm/the_gnat_library system-pool-local-s-pooloc-ads}@anchor{3ff}
@section @code{System.Pool_Local} (@code{s-pooloc.ads})
@@ -25042,7 +25254,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 id152}@anchor{401}@anchor{gnat_rm/the_gnat_library system-restrictions-s-restri-ads}@anchor{402}
+@anchor{gnat_rm/the_gnat_library id152}@anchor{400}@anchor{gnat_rm/the_gnat_library system-restrictions-s-restri-ads}@anchor{401}
@section @code{System.Restrictions} (@code{s-restri.ads})
@@ -25058,7 +25270,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{403}@anchor{gnat_rm/the_gnat_library id153}@anchor{404}
+@anchor{gnat_rm/the_gnat_library id153}@anchor{402}@anchor{gnat_rm/the_gnat_library system-rident-s-rident-ads}@anchor{403}
@section @code{System.Rident} (@code{s-rident.ads})
@@ -25074,7 +25286,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 id154}@anchor{405}@anchor{gnat_rm/the_gnat_library system-strings-stream-ops-s-ststop-ads}@anchor{406}
+@anchor{gnat_rm/the_gnat_library id154}@anchor{404}@anchor{gnat_rm/the_gnat_library system-strings-stream-ops-s-ststop-ads}@anchor{405}
@section @code{System.Strings.Stream_Ops} (@code{s-ststop.ads})
@@ -25090,7 +25302,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{407}@anchor{gnat_rm/the_gnat_library id155}@anchor{408}
+@anchor{gnat_rm/the_gnat_library id155}@anchor{406}@anchor{gnat_rm/the_gnat_library system-unsigned-types-s-unstyp-ads}@anchor{407}
@section @code{System.Unsigned_Types} (@code{s-unstyp.ads})
@@ -25103,7 +25315,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{409}@anchor{gnat_rm/the_gnat_library id156}@anchor{40a}
+@anchor{gnat_rm/the_gnat_library id156}@anchor{408}@anchor{gnat_rm/the_gnat_library system-wch-cnv-s-wchcnv-ads}@anchor{409}
@section @code{System.Wch_Cnv} (@code{s-wchcnv.ads})
@@ -25124,7 +25336,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 id157}@anchor{40b}@anchor{gnat_rm/the_gnat_library system-wch-con-s-wchcon-ads}@anchor{40c}
+@anchor{gnat_rm/the_gnat_library id157}@anchor{40a}@anchor{gnat_rm/the_gnat_library system-wch-con-s-wchcon-ads}@anchor{40b}
@section @code{System.Wch_Con} (@code{s-wchcon.ads})
@@ -25136,7 +25348,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{40d}@anchor{gnat_rm/interfacing_to_other_languages id1}@anchor{40e}
+@anchor{gnat_rm/interfacing_to_other_languages doc}@anchor{40c}@anchor{gnat_rm/interfacing_to_other_languages id1}@anchor{40d}@anchor{gnat_rm/interfacing_to_other_languages interfacing-to-other-languages}@anchor{11}
@chapter Interfacing to Other Languages
@@ -25154,7 +25366,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{40f}@anchor{gnat_rm/interfacing_to_other_languages id2}@anchor{410}
+@anchor{gnat_rm/interfacing_to_other_languages id2}@anchor{40e}@anchor{gnat_rm/interfacing_to_other_languages interfacing-to-c}@anchor{40f}
@section Interfacing to C
@@ -25294,7 +25506,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{411}@anchor{gnat_rm/interfacing_to_other_languages id3}@anchor{47}
+@anchor{gnat_rm/interfacing_to_other_languages id3}@anchor{47}@anchor{gnat_rm/interfacing_to_other_languages id4}@anchor{410}
@section Interfacing to C++
@@ -25351,7 +25563,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{412}@anchor{gnat_rm/interfacing_to_other_languages interfacing-to-cobol}@anchor{413}
+@anchor{gnat_rm/interfacing_to_other_languages id5}@anchor{411}@anchor{gnat_rm/interfacing_to_other_languages interfacing-to-cobol}@anchor{412}
@section Interfacing to COBOL
@@ -25359,7 +25571,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{414}@anchor{gnat_rm/interfacing_to_other_languages interfacing-to-fortran}@anchor{415}
+@anchor{gnat_rm/interfacing_to_other_languages id6}@anchor{413}@anchor{gnat_rm/interfacing_to_other_languages interfacing-to-fortran}@anchor{414}
@section Interfacing to Fortran
@@ -25369,7 +25581,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{416}@anchor{gnat_rm/interfacing_to_other_languages id7}@anchor{417}
+@anchor{gnat_rm/interfacing_to_other_languages id7}@anchor{415}@anchor{gnat_rm/interfacing_to_other_languages interfacing-to-non-gnat-ada-code}@anchor{416}
@section Interfacing to non-GNAT Ada code
@@ -25393,7 +25605,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{418}@anchor{gnat_rm/specialized_needs_annexes id1}@anchor{419}
+@anchor{gnat_rm/specialized_needs_annexes doc}@anchor{417}@anchor{gnat_rm/specialized_needs_annexes id1}@anchor{418}@anchor{gnat_rm/specialized_needs_annexes specialized-needs-annexes}@anchor{12}
@chapter Specialized Needs Annexes
@@ -25434,7 +25646,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{41a}@anchor{gnat_rm/implementation_of_specific_ada_features id1}@anchor{41b}
+@anchor{gnat_rm/implementation_of_specific_ada_features doc}@anchor{419}@anchor{gnat_rm/implementation_of_specific_ada_features id1}@anchor{41a}@anchor{gnat_rm/implementation_of_specific_ada_features implementation-of-specific-ada-features}@anchor{13}
@chapter Implementation of Specific Ada Features
@@ -25447,12 +25659,13 @@ facilities.
* GNAT Implementation of Shared Passive Packages::
* Code Generation for Array Aggregates::
* The Size of Discriminated Records with Default Discriminants::
+* Image Values For Nonscalar Types::
* Strict Conformance to the Ada Reference Manual::
@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{169}@anchor{gnat_rm/implementation_of_specific_ada_features id2}@anchor{41c}
+@anchor{gnat_rm/implementation_of_specific_ada_features id2}@anchor{41b}@anchor{gnat_rm/implementation_of_specific_ada_features machine-code-insertions}@anchor{166}
@section Machine Code Insertions
@@ -25517,7 +25730,7 @@ 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}.
-No support is provided for GNU C's symbolic names for output parameters.
+No support is provided for GNU C’s symbolic names for output parameters.
The second argument of @code{my_float'Asm_Output} functions as
though it were an @code{out} parameter, which is a little curious, but
@@ -25536,7 +25749,7 @@ 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
constraint are the same as those used in the RTL, and are dependent on
the configuration file used to built the GCC back end.
-No support is provided for GNU C's symbolic names for input parameters.
+No support is provided for GNU C’s symbolic names for input parameters.
If there are no input operands, this argument may either be omitted, or
explicitly given as @code{No_Input_Operands}. The fourth argument, not
@@ -25561,11 +25774,11 @@ Generally it is strongly advisable to use Volatile for any ASM statement
that is missing either input or output operands or to avoid unwanted
optimizations. A warning is generated if this advice is not followed.
-No support is provided for GNU C's @code{asm goto} feature.
+No support is provided for GNU C’s @code{asm goto} feature.
The @code{Asm} subprograms may be used in two ways. First the procedure
forms can be used anywhere a procedure call would be valid, and
-correspond to what the RM calls 'intrinsic' routines. Such calls can
+correspond to what the RM calls ‘intrinsic’ routines. Such calls can
be used to intersperse machine instructions with other Ada statements.
Second, the function forms, which return a dummy value of the limited
private type @code{Asm_Insn}, can be used in code statements, and indeed
@@ -25620,7 +25833,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{41d}@anchor{gnat_rm/implementation_of_specific_ada_features gnat-implementation-of-tasking}@anchor{41e}
+@anchor{gnat_rm/implementation_of_specific_ada_features gnat-implementation-of-tasking}@anchor{41c}@anchor{gnat_rm/implementation_of_specific_ada_features id3}@anchor{41d}
@section GNAT Implementation of Tasking
@@ -25636,11 +25849,11 @@ 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{41f}@anchor{gnat_rm/implementation_of_specific_ada_features id4}@anchor{420}
+@anchor{gnat_rm/implementation_of_specific_ada_features id4}@anchor{41e}@anchor{gnat_rm/implementation_of_specific_ada_features mapping-ada-tasks-onto-the-underlying-kernel-threads}@anchor{41f}
@subsection Mapping Ada Tasks onto the Underlying Kernel Threads
-GNAT's run-time support comprises two layers:
+GNAT’s run-time support comprises two layers:
@itemize *
@@ -25652,12 +25865,12 @@ GNARL (GNAT Run-time Layer)
GNULL (GNAT Low-level Library)
@end itemize
-In GNAT, Ada's tasking services rely on a platform and OS independent
+In GNAT, Ada’s tasking services rely on a platform and OS independent
layer known as GNARL. This code is responsible for implementing the
-correct semantics of Ada's task creation, rendezvous, protected
+correct semantics of Ada’s task creation, rendezvous, protected
operations etc.
-GNARL decomposes Ada's tasking semantics into simpler lower level
+GNARL decomposes Ada’s tasking semantics into simpler lower level
operations such as create a thread, set the priority of a thread,
yield, create a lock, lock/unlock, etc. The spec for these low-level
operations constitutes GNULLI, the GNULL Interface. This interface is
@@ -25705,7 +25918,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{421}@anchor{gnat_rm/implementation_of_specific_ada_features ensuring-compliance-with-the-real-time-annex}@anchor{422}
+@anchor{gnat_rm/implementation_of_specific_ada_features ensuring-compliance-with-the-real-time-annex}@anchor{420}@anchor{gnat_rm/implementation_of_specific_ada_features id5}@anchor{421}
@subsection Ensuring Compliance with the Real-Time Annex
@@ -25756,7 +25969,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{423}
+@anchor{gnat_rm/implementation_of_specific_ada_features support-for-locking-policies}@anchor{422}
@subsection Support for Locking Policies
@@ -25778,19 +25991,19 @@ and VxWorks.
@code{Concurrent_Readers_Locking} is supported on Linux.
Notes about @code{Ceiling_Locking} on Linux:
-If the process is running as 'root', ceiling locking is used.
+If the process is running as ‘root’, ceiling locking is used.
If the capabilities facility is installed
-("sudo apt-get --assume-yes install libcap-dev" on Ubuntu,
+(“sudo apt-get –assume-yes install libcap-dev” on Ubuntu,
for example),
and the program is linked against that library
-("-largs -lcap"),
+(“-largs -lcap”),
and the executable file has the cap_sys_nice capability
-("sudo /sbin/setcap cap_sys_nice=ep executable_file_name"),
+(“sudo /sbin/setcap cap_sys_nice=ep executable_file_name”),
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{424}@anchor{gnat_rm/implementation_of_specific_ada_features gnat-implementation-of-shared-passive-packages}@anchor{425}
+@anchor{gnat_rm/implementation_of_specific_ada_features gnat-implementation-of-shared-passive-packages}@anchor{423}@anchor{gnat_rm/implementation_of_specific_ada_features id6}@anchor{424}
@section GNAT Implementation of Shared Passive Packages
@@ -25888,7 +26101,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{426}@anchor{gnat_rm/implementation_of_specific_ada_features id7}@anchor{427}
+@anchor{gnat_rm/implementation_of_specific_ada_features code-generation-for-array-aggregates}@anchor{425}@anchor{gnat_rm/implementation_of_specific_ada_features id7}@anchor{426}
@section Code Generation for Array Aggregates
@@ -25919,7 +26132,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{428}@anchor{gnat_rm/implementation_of_specific_ada_features id8}@anchor{429}
+@anchor{gnat_rm/implementation_of_specific_ada_features id8}@anchor{427}@anchor{gnat_rm/implementation_of_specific_ada_features static-constant-aggregates-with-static-bounds}@anchor{428}
@subsection Static constant aggregates with static bounds
@@ -25966,7 +26179,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{42a}@anchor{gnat_rm/implementation_of_specific_ada_features id9}@anchor{42b}
+@anchor{gnat_rm/implementation_of_specific_ada_features constant-aggregates-with-unconstrained-nominal-types}@anchor{429}@anchor{gnat_rm/implementation_of_specific_ada_features id9}@anchor{42a}
@subsection Constant aggregates with unconstrained nominal types
@@ -25981,7 +26194,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{42c}@anchor{gnat_rm/implementation_of_specific_ada_features aggregates-with-static-bounds}@anchor{42d}
+@anchor{gnat_rm/implementation_of_specific_ada_features aggregates-with-static-bounds}@anchor{42b}@anchor{gnat_rm/implementation_of_specific_ada_features id10}@anchor{42c}
@subsection Aggregates with static bounds
@@ -26009,7 +26222,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{42e}@anchor{gnat_rm/implementation_of_specific_ada_features aggregates-with-nonstatic-bounds}@anchor{42f}
+@anchor{gnat_rm/implementation_of_specific_ada_features aggregates-with-nonstatic-bounds}@anchor{42d}@anchor{gnat_rm/implementation_of_specific_ada_features id11}@anchor{42e}
@subsection Aggregates with nonstatic bounds
@@ -26020,7 +26233,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{430}@anchor{gnat_rm/implementation_of_specific_ada_features aggregates-in-assignment-statements}@anchor{431}
+@anchor{gnat_rm/implementation_of_specific_ada_features aggregates-in-assignment-statements}@anchor{42f}@anchor{gnat_rm/implementation_of_specific_ada_features id12}@anchor{430}
@subsection Aggregates in assignment statements
@@ -26061,8 +26274,8 @@ If any of these conditions are violated, the aggregate will be built in
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{432}@anchor{gnat_rm/implementation_of_specific_ada_features the-size-of-discriminated-records-with-default-discriminants}@anchor{433}
+@node The Size of Discriminated Records with Default Discriminants,Image Values For Nonscalar Types,Code Generation for Array Aggregates,Implementation of Specific Ada Features
+@anchor{gnat_rm/implementation_of_specific_ada_features id13}@anchor{431}@anchor{gnat_rm/implementation_of_specific_ada_features the-size-of-discriminated-records-with-default-discriminants}@anchor{432}
@section The Size of Discriminated Records with Default Discriminants
@@ -26111,8 +26324,8 @@ object, and place it on the stack.
This maximum size approach
has been a source of surprise to some users, who expect the default
values of the discriminants to determine the size reserved for an
-unconstrained object: "If the default is 15, why should the object occupy
-a larger size?"
+unconstrained object: “If the default is 15, why should the object occupy
+a larger size?”
The answer, of course, is that the discriminant may be later modified,
and its full range of values must be taken into account. This is why the
declaration:
@@ -26129,7 +26342,7 @@ is flagged by the compiler with a warning:
an attempt to create @code{Too_Large} will raise @code{Storage_Error},
because the required size includes @code{Positive'Last}
bytes. As the first example indicates, the proper approach is to declare an
-index type of 'reasonable' range so that unconstrained objects are not too
+index type of ‘reasonable’ range so that unconstrained objects are not too
large.
One final wrinkle: if the object is declared to be @code{aliased}, or if it is
@@ -26141,8 +26354,28 @@ aliasing all views of the object (which may be manipulated by different tasks,
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{434}@anchor{gnat_rm/implementation_of_specific_ada_features id14}@anchor{435}
+@node Image Values For Nonscalar Types,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 id14}@anchor{433}@anchor{gnat_rm/implementation_of_specific_ada_features image-values-for-nonscalar-types}@anchor{434}
+@section Image Values For Nonscalar Types
+
+
+Ada 2022 defines the Image, Wide_Image, and Wide_Wide image attributes
+for nonscalar types; earlier Ada versions defined these attributes only
+for scalar types. Ada RM 4.10 provides some general guidance regarding
+the default implementation of these attributes and the GNAT compiler
+follows that guidance. However, beyond that the precise details of the
+image text generated in these cases are deliberately not documented and are
+subject to change. In particular, users should not rely on formatting details
+(such as spaces or line breaking), record field order, image values for access
+types, image values for types that have ancestor or subcomponent types
+declared in non-Ada2022 code, image values for predefined types, or the
+compiler’s choices regarding the implementation permissions described in
+Ada RM 4.10. This list is not intended to be exhaustive. If more precise
+control of image text is required for some type T, then T’Put_Image should be
+explicitly specified.
+
+@node Strict Conformance to the Ada Reference Manual,,Image Values For Nonscalar Types,Implementation of Specific Ada Features
+@anchor{gnat_rm/implementation_of_specific_ada_features id15}@anchor{435}@anchor{gnat_rm/implementation_of_specific_ada_features strict-conformance-to-the-ada-reference-manual}@anchor{436}
@section Strict Conformance to the Ada Reference Manual
@@ -26169,7 +26402,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{436}@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{437}
+@anchor{gnat_rm/implementation_of_ada_2012_features doc}@anchor{437}@anchor{gnat_rm/implementation_of_ada_2012_features id1}@anchor{438}@anchor{gnat_rm/implementation_of_ada_2012_features implementation-of-ada-2012-features}@anchor{14}
@chapter Implementation of Ada 2012 Features
@@ -26203,10 +26436,10 @@ subsequent releases. A date of 0000-00-00 means that GNAT has always
implemented the feature, or implemented it as soon as it appeared as a
binding interpretation.
-Each feature corresponds to an Ada Issue ('AI') approved by the Ada
+Each feature corresponds to an Ada Issue (‘AI’) approved by the Ada
standardization group (ISO/IEC JTC1/SC22/WG9) for inclusion in Ada 2012.
The features are ordered based on the relevant sections of the Ada
-Reference Manual ("RM"). When a given AI relates to multiple points
+Reference Manual (“RM”). When a given AI relates to multiple points
in the RM, the earliest is used.
A complete description of the AIs may be found in
@@ -26292,7 +26525,7 @@ RM References: 2.08 (7) 2.08 (16)
@itemize *
@item
-@emph{AI-0080 'View of' not needed if clear from context (0000-00-00)}
+@emph{AI-0080 ‘View of’ not needed if clear from context (0000-00-00)}
This is an editorial change only, described as non-testable in the AI.
@@ -26308,7 +26541,7 @@ RM References: 3.01 (7)
@emph{AI-0183 Aspect specifications (2010-08-16)}
Aspect specifications have been fully implemented except for pre and post-
-conditions, and type invariants, which have their own separate AI's. All
+conditions, and type invariants, which have their own separate AI’s. All
forms of declarations listed in the AI are supported. The following is a
list of the aspects supported (with GNAT implementation aspects marked)
@end itemize
@@ -26329,7 +26562,7 @@ Source
@tab
--- GNAT
+– GNAT
@item
@@ -26337,7 +26570,7 @@ Source
@tab
--- GNAT
+– GNAT
@item
@@ -26381,7 +26614,7 @@ Source
@tab
--- GNAT
+– GNAT
@item
@@ -26401,7 +26634,7 @@ Source
@tab
--- GNAT
+– GNAT
@item
@@ -26415,7 +26648,7 @@ Source
@tab
--- GNAT
+– GNAT
@item
@@ -26423,7 +26656,7 @@ Source
@tab
--- GNAT
+– GNAT
@item
@@ -26443,7 +26676,7 @@ Source
@tab
--- GNAT
+– GNAT
@item
@@ -26457,7 +26690,7 @@ Source
@tab
--- GNAT
+– GNAT
@item
@@ -26489,7 +26722,7 @@ Source
@tab
--- GNAT
+– GNAT
@item
@@ -26497,7 +26730,7 @@ Source
@tab
--- GNAT
+– GNAT
@item
@@ -26505,7 +26738,7 @@ Source
@tab
--- GNAT
+– GNAT
@item
@@ -26543,7 +26776,7 @@ Source
@tab
--- GNAT
+– GNAT
@item
@@ -26551,7 +26784,7 @@ Source
@tab
--- GNAT
+– GNAT
@item
@@ -26559,7 +26792,7 @@ Source
@tab
--- GNAT
+– GNAT
@item
@@ -26579,7 +26812,7 @@ Source
@tab
--- GNAT
+– GNAT
@item
@@ -26587,7 +26820,7 @@ Source
@tab
--- GNAT
+– GNAT
@item
@@ -26595,7 +26828,7 @@ Source
@tab
--- GNAT
+– GNAT
@item
@@ -26603,7 +26836,7 @@ Source
@tab
--- GNAT
+– GNAT
@item
@@ -26617,7 +26850,7 @@ Source
@tab
--- GNAT
+– GNAT
@item
@@ -26637,7 +26870,7 @@ Source
@tab
--- GNAT
+– GNAT
@end multitable
@@ -26665,8 +26898,8 @@ RM References: 3.02.01 (3) 3.02.02 (2) 3.03.01 (2/2) 3.08 (6)
@item
@emph{AI-0128 Inequality is a primitive operation (0000-00-00)}
-If an equality operator ("=") is declared for a type, then the implicitly
-declared inequality operator ("/=") is a primitive operation of the type.
+If an equality operator (“=”) is declared for a type, then the implicitly
+declared inequality operator (“/=”) is a primitive operation of the type.
This is the only reasonable interpretation, and is the one always implemented
by GNAT, but the RM was not entirely clear in making this point.
@@ -26730,7 +26963,7 @@ RM References: 3.03 (23) 3.10.02 (26/2) 4.01 (9) 6.04.01 (17) 8.05.01 (
@emph{AI-0093 Additional rules use immutably limited (0000-00-00)}
This is an editorial change only, to make more widespread use of the Ada 2012
-'immutably limited'.
+‘immutably limited’.
RM References: 3.03 (23.4/3)
@end itemize
@@ -26798,7 +27031,7 @@ RM References: 3.05 (56/2)
Ada 2012 relaxes the restriction that forbids discriminants of tagged types
to have default expressions by allowing them when the type is limited. It
is often useful to define a default value for a discriminant even though
-it can't be changed by assignment.
+it can’t be changed by assignment.
RM References: 3.07 (9.1/2) 3.07.02 (3)
@end itemize
@@ -26857,7 +27090,7 @@ RM References: 3.09 (7.4/2) 3.09 (12.4/2)
@emph{AI-0076 function with controlling result (0000-00-00)}
This is an editorial change only. The RM defines calls with controlling
-results, but uses the term 'function with controlling result' without an
+results, but uses the term ‘function with controlling result’ without an
explicit definition.
RM References: 3.09.02 (2/2)
@@ -27411,10 +27644,10 @@ RM References: 7.05 (5/2) 12.05.01 (5.1/2)
@item
@emph{AI-0099 Tag determines whether finalization needed (0000-00-00)}
-This AI clarifies that 'needs finalization' is part of dynamic semantics,
+This AI clarifies that ‘needs finalization’ is part of dynamic semantics,
and therefore depends on the run-time characteristics of an object (i.e. its
-tag) and not on its nominal type. As the AI indicates: "we do not expect
-this to affect any implementation'@w{'}.
+tag) and not on its nominal type. As the AI indicates: “we do not expect
+this to affect any implementation’’.
RM References: 7.06.01 (6) 7.06.01 (7) 7.06.01 (8) 7.06.01 (9/2)
@end itemize
@@ -27544,7 +27777,7 @@ C.06 (4) C.06 (6) C.06 (9) C.06 (13) C.06 (14)
@itemize *
@item
-@emph{AI-0072 Task signalling using 'Terminated (0000-00-00)}
+@emph{AI-0072 Task signalling using ‘Terminated (0000-00-00)}
This AI clarifies that task signalling for reading @code{'Terminated} only
occurs if the result is True. GNAT semantics has always been consistent with
@@ -27684,7 +27917,7 @@ RM References: 10.02.01 (15.1/2) 10.02.01 (15.4/2) 10.02.01 (15.5/2) 10.0
@emph{AI-0219 Pure permissions and limited parameters (2010-05-25)}
This AI refines the rules for the cases with limited parameters which do not
-allow the implementations to omit 'redundant'. GNAT now properly conforms
+allow the implementations to omit ‘redundant’. GNAT now properly conforms
to the requirements of this binding interpretation.
RM References: 10.02.01 (18/2)
@@ -27963,7 +28196,7 @@ RM References: 13.13.02 (1.2/2)
@itemize *
@item
-@emph{AI-0109 Redundant check in S'Class'Input (0000-00-00)}
+@emph{AI-0109 Redundant check in S’Class’Input (0000-00-00)}
This AI is an editorial change only. It removes the need for a tag check
that can never fail.
@@ -28025,7 +28258,7 @@ RM References: 13.14 (2) 13.14 (3/1) 13.14 (8.1/1) 13.14 (10) 13.14 (14
@item
@emph{AI-0017 Freezing and incomplete types (0000-00-00)}
-So-called 'Taft-amendment types' (i.e., types that are completed in package
+So-called ‘Taft-amendment types’ (i.e., types that are completed in package
bodies) are not frozen by the occurrence of bodies in the
enclosing declarative part. GNAT always implemented this properly.
@@ -28335,7 +28568,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{438}@anchor{gnat_rm/obsolescent_features doc}@anchor{439}@anchor{gnat_rm/obsolescent_features obsolescent-features}@anchor{15}
+@anchor{gnat_rm/obsolescent_features doc}@anchor{439}@anchor{gnat_rm/obsolescent_features id1}@anchor{43a}@anchor{gnat_rm/obsolescent_features obsolescent-features}@anchor{15}
@chapter Obsolescent Features
@@ -28354,12 +28587,12 @@ compatibility purposes.
@end menu
@node pragma No_Run_Time,pragma Ravenscar,,Obsolescent Features
-@anchor{gnat_rm/obsolescent_features id2}@anchor{43a}@anchor{gnat_rm/obsolescent_features pragma-no-run-time}@anchor{43b}
+@anchor{gnat_rm/obsolescent_features id2}@anchor{43b}@anchor{gnat_rm/obsolescent_features pragma-no-run-time}@anchor{43c}
@section pragma No_Run_Time
The pragma @code{No_Run_Time} is used to achieve an affect similar
-to the use of the "Zero Foot Print" configurable run time, but without
+to the use of the “Zero Foot Print” configurable run time, but without
requiring a specially configured run time. The result of using this
pragma, which must be used for all units in a partition, is to restrict
the use of any language features requiring run-time support code. The
@@ -28367,7 +28600,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{43c}@anchor{gnat_rm/obsolescent_features pragma-ravenscar}@anchor{43d}
+@anchor{gnat_rm/obsolescent_features id3}@anchor{43d}@anchor{gnat_rm/obsolescent_features pragma-ravenscar}@anchor{43e}
@section pragma Ravenscar
@@ -28376,7 +28609,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{43e}@anchor{gnat_rm/obsolescent_features id4}@anchor{43f}
+@anchor{gnat_rm/obsolescent_features id4}@anchor{43f}@anchor{gnat_rm/obsolescent_features pragma-restricted-run-time}@anchor{440}
@section pragma Restricted_Run_Time
@@ -28386,7 +28619,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{440}@anchor{gnat_rm/obsolescent_features id5}@anchor{441}
+@anchor{gnat_rm/obsolescent_features id5}@anchor{441}@anchor{gnat_rm/obsolescent_features pragma-task-info}@anchor{442}
@section pragma Task_Info
@@ -28412,17 +28645,17 @@ 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{442}@anchor{gnat_rm/obsolescent_features package-system-task-info-s-tasinf-ads}@anchor{443}
+@anchor{gnat_rm/obsolescent_features package-system-task-info}@anchor{443}@anchor{gnat_rm/obsolescent_features package-system-task-info-s-tasinf-ads}@anchor{444}
@section package System.Task_Info (@code{s-tasinf.ads})
This package provides target dependent functionality that is used
to support the @code{Task_Info} pragma. The predefined Ada package
@code{System.Multiprocessors} and the @code{CPU} aspect now provide a
-standard replacement for GNAT's @code{Task_Info} functionality.
+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{444}@anchor{gnat_rm/compatibility_and_porting_guide id1}@anchor{445}
+@anchor{gnat_rm/compatibility_and_porting_guide doc}@anchor{445}@anchor{gnat_rm/compatibility_and_porting_guide compatibility-and-porting-guide}@anchor{16}@anchor{gnat_rm/compatibility_and_porting_guide id1}@anchor{446}
@chapter Compatibility and Porting Guide
@@ -28444,7 +28677,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{446}@anchor{gnat_rm/compatibility_and_porting_guide writing-portable-fixed-point-declarations}@anchor{447}
+@anchor{gnat_rm/compatibility_and_porting_guide id2}@anchor{447}@anchor{gnat_rm/compatibility_and_porting_guide writing-portable-fixed-point-declarations}@anchor{448}
@section Writing Portable Fixed-Point Declarations
@@ -28459,7 +28692,7 @@ type F1 is delta 1.0 range -128.0 .. +128.0;
then the implementation is allowed to choose -128.0 .. +127.0 if it
likes, but is not required to do so.
-This leads to possible portability problems, so let's have a closer
+This leads to possible portability problems, so let’s have a closer
look at this, and figure out how to avoid these problems.
First, why does this freedom exist, and why would an implementation
@@ -28469,11 +28702,11 @@ it would need 9 bits to hold the largest positive value (and typically
that means 16 bits on all machines). But if the implementation chooses
the +127.0 bound then it can fit values of the type in 8 bits.
-Why not make the user write +127.0 if that's what is wanted?
+Why not make the user write +127.0 if that’s what is wanted?
The rationale is that if you are thinking of fixed point
-as a kind of 'poor man's floating-point', then you don't want
+as a kind of ‘poor man’s floating-point’, then you don’t want
to be thinking about the scaled integers that are used in its
-representation. Let's take another example:
+representation. Let’s take another example:
@example
type F2 is delta 2.0**(-15) range -1.0 .. +1.0;
@@ -28489,7 +28722,7 @@ type F2 is delta 2.0**(-15) range -1.0 .. +1.0-(2.0**(-15));
@end example
and the Ada language design team felt that this was too annoying
-to require. We don't need to debate this decision at this point,
+to require. We don’t need to debate this decision at this point,
since it is well established (the rule about narrowing the ranges
dates to Ada 83).
@@ -28566,7 +28799,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{448}@anchor{gnat_rm/compatibility_and_porting_guide id3}@anchor{449}
+@anchor{gnat_rm/compatibility_and_porting_guide compatibility-with-ada-83}@anchor{449}@anchor{gnat_rm/compatibility_and_porting_guide id3}@anchor{44a}
@section Compatibility with Ada 83
@@ -28594,7 +28827,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{44a}@anchor{gnat_rm/compatibility_and_porting_guide legal-ada-83-programs-that-are-illegal-in-ada-95}@anchor{44b}
+@anchor{gnat_rm/compatibility_and_porting_guide id4}@anchor{44b}@anchor{gnat_rm/compatibility_and_porting_guide legal-ada-83-programs-that-are-illegal-in-ada-95}@anchor{44c}
@subsection Legal Ada 83 programs that are illegal in Ada 95
@@ -28616,7 +28849,7 @@ For example:
for Char in 'A' .. 'Z' loop ... end loop;
@end example
-The problem is that 'A' and 'Z' could be from either
+The problem is that ‘A’ and ‘Z’ could be from either
@code{Character} or @code{Wide_Character}. The simplest correction
is to make the type explicit; e.g.:
@@ -28679,7 +28912,7 @@ In Ada 83, it was permissible to pass an indefinite type (e.g, @code{String})
as the actual for a generic formal private type, but then the instantiation
would be illegal if there were any instances of declarations of variables
of this type in the generic body. In Ada 95, to avoid this clear violation
-of the methodological principle known as the 'contract model',
+of the methodological principle known as the ‘contract model’,
the generic declaration explicitly indicates whether
or not such instantiations are permitted. If a generic formal parameter
has explicit unknown discriminants, indicated by using @code{(<>)} after the
@@ -28694,7 +28927,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{44c}@anchor{gnat_rm/compatibility_and_porting_guide id5}@anchor{44d}
+@anchor{gnat_rm/compatibility_and_porting_guide id5}@anchor{44d}@anchor{gnat_rm/compatibility_and_porting_guide more-deterministic-semantics}@anchor{44e}
@subsection More deterministic semantics
@@ -28722,7 +28955,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{44e}@anchor{gnat_rm/compatibility_and_porting_guide changed-semantics}@anchor{44f}
+@anchor{gnat_rm/compatibility_and_porting_guide changed-semantics}@anchor{44f}@anchor{gnat_rm/compatibility_and_porting_guide id6}@anchor{450}
@subsection Changed semantics
@@ -28764,7 +28997,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{450}@anchor{gnat_rm/compatibility_and_porting_guide id7}@anchor{451}
+@anchor{gnat_rm/compatibility_and_porting_guide id7}@anchor{451}@anchor{gnat_rm/compatibility_and_porting_guide other-language-compatibility-issues}@anchor{452}
@subsection Other language compatibility issues
@@ -28782,7 +29015,7 @@ as identifiers as in Ada 83. However,
in practice, it is usually advisable to make the necessary modifications
to the program to remove the need for using this switch.
See the @code{Compiling Different Versions of Ada} section in
-the @cite{GNAT User's Guide}.
+the @cite{GNAT User’s Guide}.
@item
Support for removed Ada 83 pragmas and attributes
@@ -28797,7 +29030,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{452}@anchor{gnat_rm/compatibility_and_porting_guide id8}@anchor{453}
+@anchor{gnat_rm/compatibility_and_porting_guide compatibility-between-ada-95-and-ada-2005}@anchor{453}@anchor{gnat_rm/compatibility_and_porting_guide id8}@anchor{454}
@section Compatibility between Ada 95 and Ada 2005
@@ -28854,7 +29087,7 @@ now need to be considered in expression resolution.
@item
@emph{Fixed-point multiplication and division.}
-Certain expressions involving '*' or '/' for a fixed-point type, which
+Certain expressions involving ‘*’ or ‘/’ for a fixed-point type, which
were legal in Ada 95 and invoked the predefined versions of these operations,
are now ambiguous.
The ambiguity may be resolved either by applying a type conversion to the
@@ -28869,7 +29102,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{454}@anchor{gnat_rm/compatibility_and_porting_guide id9}@anchor{455}
+@anchor{gnat_rm/compatibility_and_porting_guide id9}@anchor{455}@anchor{gnat_rm/compatibility_and_porting_guide implementation-dependent-characteristics}@anchor{456}
@section Implementation-dependent characteristics
@@ -28892,7 +29125,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{456}@anchor{gnat_rm/compatibility_and_porting_guide id10}@anchor{457}
+@anchor{gnat_rm/compatibility_and_porting_guide id10}@anchor{457}@anchor{gnat_rm/compatibility_and_porting_guide implementation-defined-pragmas}@anchor{458}
@subsection Implementation-defined pragmas
@@ -28900,7 +29133,7 @@ Ada compilers are allowed to supplement the language-defined pragmas, and
these are a potential source of non-portability. All GNAT-defined pragmas
are described in @ref{7,,Implementation Defined Pragmas},
and these include several that are specifically
-intended to correspond to other vendors' Ada 83 pragmas.
+intended to correspond to other vendors’ Ada 83 pragmas.
For migrating from VADS, the pragma @code{Use_VADS_Size} may be useful.
For compatibility with HP Ada 83, GNAT supplies the pragmas
@code{Extend_System}, @code{Ident}, @code{Inline_Generic},
@@ -28914,7 +29147,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{458}@anchor{gnat_rm/compatibility_and_porting_guide implementation-defined-attributes}@anchor{459}
+@anchor{gnat_rm/compatibility_and_porting_guide id11}@anchor{459}@anchor{gnat_rm/compatibility_and_porting_guide implementation-defined-attributes}@anchor{45a}
@subsection Implementation-defined attributes
@@ -28922,13 +29155,13 @@ Analogous to pragmas, the set of attributes may be extended by an
implementation. All GNAT-defined attributes are described in
@ref{8,,Implementation Defined Attributes},
and these include several that are specifically intended
-to correspond to other vendors' Ada 83 attributes. For migrating from VADS,
+to correspond to other vendors’ Ada 83 attributes. For migrating from VADS,
the attribute @code{VADS_Size} may be useful. For compatibility with HP
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{45a}@anchor{gnat_rm/compatibility_and_porting_guide id12}@anchor{45b}
+@anchor{gnat_rm/compatibility_and_porting_guide id12}@anchor{45b}@anchor{gnat_rm/compatibility_and_porting_guide libraries}@anchor{45c}
@subsection Libraries
@@ -28957,13 +29190,13 @@ 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{45c}@anchor{gnat_rm/compatibility_and_porting_guide id13}@anchor{45d}
+@anchor{gnat_rm/compatibility_and_porting_guide elaboration-order}@anchor{45d}@anchor{gnat_rm/compatibility_and_porting_guide id13}@anchor{45e}
@subsection Elaboration order
The implementation can choose any elaboration order consistent with the unit
dependency relationship. This freedom means that some orders can result in
-Program_Error being raised due to an 'Access Before Elaboration': an attempt
+Program_Error being raised due to an ‘Access Before Elaboration’: an attempt
to invoke a subprogram before its body has been elaborated, or to instantiate
a generic before the generic body has been elaborated. By default GNAT
attempts to choose a safe order (one that will not encounter access before
@@ -28972,7 +29205,7 @@ elaboration problems) by implicitly inserting @code{Elaborate} or
needed. However, this can lead to the creation of elaboration circularities
and a resulting rejection of the program by gnatbind. This issue is
thoroughly described in the @emph{Elaboration Order Handling in GNAT} appendix
-in the @cite{GNAT User's Guide}.
+in the @cite{GNAT User’s Guide}.
In brief, there are several
ways to deal with this situation:
@@ -28993,7 +29226,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{45e}@anchor{gnat_rm/compatibility_and_porting_guide id14}@anchor{45f}
+@anchor{gnat_rm/compatibility_and_porting_guide id14}@anchor{45f}@anchor{gnat_rm/compatibility_and_porting_guide target-specific-aspects}@anchor{460}
@subsection Target-specific aspects
@@ -29006,10 +29239,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{460,,Representation Clauses}.
+GNAT’s approach to these issues is described in @ref{461,,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{461}@anchor{gnat_rm/compatibility_and_porting_guide compatibility-with-other-ada-systems}@anchor{462}
+@anchor{gnat_rm/compatibility_and_porting_guide compatibility-with-other-ada-systems}@anchor{462}@anchor{gnat_rm/compatibility_and_porting_guide id15}@anchor{463}
@section Compatibility with Other Ada Systems
@@ -29052,7 +29285,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{460}@anchor{gnat_rm/compatibility_and_porting_guide id16}@anchor{463}
+@anchor{gnat_rm/compatibility_and_porting_guide id16}@anchor{464}@anchor{gnat_rm/compatibility_and_porting_guide representation-clauses}@anchor{461}
@section Representation Clauses
@@ -29082,7 +29315,7 @@ Some Ada 83 compilers allowed a Size specification to cause implicit
packing of an array or record. This could cause expensive implicit
conversions for change of representation in the presence of derived
types, and the Ada design intends to avoid this possibility.
-Subsequent AI's were issued to make it clear that such implicit
+Subsequent AI’s were issued to make it clear that such implicit
change of representation in response to a Size clause is inadvisable,
and this recommendation is represented explicitly in the Ada 95 (and Ada 2005)
Reference Manuals as implementation advice that is followed by GNAT.
@@ -29100,7 +29333,7 @@ on a 32-bit machine, the size of @code{Natural} will typically be 31 and not
32 (since no sign bit is required). Some Ada 83 compilers gave 31, and
some 32 in this situation. This problem will usually show up as a compile
time error, but not always. It is a good idea to check all uses of the
-'Size attribute when porting Ada 83 code. The GNAT specific attribute
+‘Size attribute when porting Ada 83 code. The GNAT specific attribute
Object_Size can provide a useful way of duplicating the behavior of
some Ada 83 compiler systems.
@@ -29111,14 +29344,14 @@ A common assumption in Ada 83 code is that an access type is in fact a pointer,
and that therefore it will be the same size as a System.Address value. This
assumption is true for GNAT in most cases with one exception. For the case of
a pointer to an unconstrained array type (where the bounds may vary from one
-value of the access type to another), the default is to use a 'fat pointer',
+value of the access type to another), the default is to use a ‘fat pointer’,
which is represented as two separate pointers, one to the bounds, and one to
the array. This representation has a number of advantages, including improved
efficiency. However, it may cause some difficulties in porting existing Ada 83
code which makes the assumption that, for example, pointers fit in 32 bits on
a machine with 32-bit addressing.
-To get around this problem, GNAT also permits the use of 'thin pointers' for
+To get around this problem, GNAT also permits the use of ‘thin pointers’ for
access types in this case (where the designated type is an unconstrained array
type). These thin pointers are indeed the same size as a System.Address value.
To specify a thin pointer, use a size clause for the type, for example:
@@ -29145,7 +29378,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{464}@anchor{gnat_rm/compatibility_and_porting_guide id17}@anchor{465}
+@anchor{gnat_rm/compatibility_and_porting_guide compatibility-with-hp-ada-83}@anchor{465}@anchor{gnat_rm/compatibility_and_porting_guide id17}@anchor{466}
@section Compatibility with HP Ada 83
@@ -29175,7 +29408,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{466}@anchor{share/gnu_free_documentation_license gnu-free-documentation-license}@anchor{467}
+@anchor{share/gnu_free_documentation_license doc}@anchor{467}@anchor{share/gnu_free_documentation_license gnu-fdl}@anchor{1}@anchor{share/gnu_free_documentation_license gnu-free-documentation-license}@anchor{468}
@chapter GNU Free Documentation License
@@ -29190,14 +29423,14 @@ license document, but changing it is not allowed.
@strong{Preamble}
The purpose of this License is to make a manual, textbook, or other
-functional and useful document "free" in the sense of freedom: to
+functional and useful document “free” in the sense of freedom: to
assure everyone the effective freedom to copy and redistribute it,
with or without modifying it, either commercially or noncommercially.
Secondarily, this License preserves for the author and publisher a way
to get credit for their work, while not being considered responsible
for modifications made by others.
-This License is a kind of "copyleft", which means that derivative
+This License is a kind of “copyleft”, which means that derivative
works of the document must themselves be free in the same sense. It
complements the GNU General Public License, which is a copyleft
license designed for free software.
@@ -29218,17 +29451,17 @@ distributed under the terms of this License. Such a notice grants a
world-wide, royalty-free license, unlimited in duration, to use that
work under the conditions stated herein. The @strong{Document}, below,
refers to any such manual or work. Any member of the public is a
-licensee, and is addressed as "@strong{you}". You accept the license if you
+licensee, and is addressed as “@strong{you}”. You accept the license if you
copy, modify or distribute the work in a way requiring permission
under copyright law.
-A "@strong{Modified Version}" of the Document means any work containing the
+A “@strong{Modified Version}” of the Document means any work containing the
Document or a portion of it, either copied verbatim, or with
modifications and/or translated into another language.
-A "@strong{Secondary Section}" is a named appendix or a front-matter section of
+A “@strong{Secondary Section}” is a named appendix or a front-matter section of
the Document that deals exclusively with the relationship of the
-publishers or authors of the Document to the Document's overall subject
+publishers or authors of the Document to the Document’s overall subject
(or to related matters) and contains nothing that could fall directly
within that overall subject. (Thus, if the Document is in part a
textbook of mathematics, a Secondary Section may not explain any
@@ -29237,7 +29470,7 @@ connection with the subject or with related matters, or of legal,
commercial, philosophical, ethical or political position regarding
them.
-The "@strong{Invariant Sections}" are certain Secondary Sections whose titles
+The “@strong{Invariant Sections}” are certain Secondary Sections whose titles
are designated, as being those of Invariant Sections, in the notice
that says that the Document is released under this License. If a
section does not fit the above definition of Secondary then it is not
@@ -29245,12 +29478,12 @@ allowed to be designated as Invariant. The Document may contain zero
Invariant Sections. If the Document does not identify any Invariant
Sections then there are none.
-The "@strong{Cover Texts}" are certain short passages of text that are listed,
+The “@strong{Cover Texts}” are certain short passages of text that are listed,
as Front-Cover Texts or Back-Cover Texts, in the notice that says that
the Document is released under this License. A Front-Cover Text may
be at most 5 words, and a Back-Cover Text may be at most 25 words.
-A "@strong{Transparent}" copy of the Document means a machine-readable copy,
+A “@strong{Transparent}” copy of the Document means a machine-readable copy,
represented in a format whose specification is available to the
general public, that is suitable for revising the document
straightforwardly with generic text editors or (for images composed of
@@ -29261,7 +29494,7 @@ to text formatters. A copy made in an otherwise Transparent file
format whose markup, or absence of markup, has been arranged to thwart
or discourage subsequent modification by readers is not Transparent.
An image format is not Transparent if used for any substantial amount
-of text. A copy that is not "Transparent" is called @strong{Opaque}.
+of text. A copy that is not “Transparent” is called @strong{Opaque}.
Examples of suitable formats for Transparent copies include plain
ASCII without markup, Texinfo input format, LaTeX input format, SGML
@@ -29274,24 +29507,24 @@ processing tools are not generally available, and the
machine-generated HTML, PostScript or PDF produced by some word
processors for output purposes only.
-The "@strong{Title Page}" means, for a printed book, the title page itself,
+The “@strong{Title Page}” means, for a printed book, the title page itself,
plus such following pages as are needed to hold, legibly, the material
this License requires to appear in the title page. For works in
-formats which do not have any title page as such, "Title Page" means
-the text near the most prominent appearance of the work's title,
+formats which do not have any title page as such, “Title Page” means
+the text near the most prominent appearance of the work’s title,
preceding the beginning of the body of the text.
-The "@strong{publisher}" means any person or entity that distributes
+The “@strong{publisher}” means any person or entity that distributes
copies of the Document to the public.
-A section "@strong{Entitled XYZ}" means a named subunit of the Document whose
+A section “@strong{Entitled XYZ}” means a named subunit of the Document whose
title either is precisely XYZ or contains XYZ in parentheses following
text that translates XYZ in another language. (Here XYZ stands for a
-specific section name mentioned below, such as "@strong{Acknowledgements}",
-"@strong{Dedications}", "@strong{Endorsements}", or "@strong{History}".)
-To "@strong{Preserve the Title}"
+specific section name mentioned below, such as “@strong{Acknowledgements}”,
+“@strong{Dedications}”, “@strong{Endorsements}”, or “@strong{History}”.)
+To “@strong{Preserve the Title}”
of such a section when you modify the Document means that it remains a
-section "Entitled XYZ" according to this definition.
+section “Entitled XYZ” according to this definition.
The Document may include Warranty Disclaimers next to the notice which
states that this License applies to the Document. These Warranty
@@ -29319,7 +29552,7 @@ you may publicly display copies.
If you publish printed copies (or copies in media that commonly have
printed covers) of the Document, numbering more than 100, and the
-Document's license notice requires Cover Texts, you must enclose the
+Document’s license notice requires Cover Texts, you must enclose the
copies in covers that carry, clearly and legibly, all these Cover
Texts: Front-Cover Texts on the front cover, and Back-Cover Texts on
the back cover. Both covers must also clearly and legibly identify
@@ -29396,16 +29629,16 @@ terms of this License, in the form shown in the Addendum below.
@item
Preserve in that license notice the full lists of Invariant Sections
-and required Cover Texts given in the Document's license notice.
+and required Cover Texts given in the Document’s license notice.
@item
Include an unaltered copy of this License.
@item
-Preserve the section Entitled "History", Preserve its Title, and add
+Preserve the section Entitled “History”, Preserve its Title, and add
to it an item stating at least the title, year, new authors, and
publisher of the Modified Version as given on the Title Page. If
-there is no section Entitled "History" in the Document, create one
+there is no section Entitled “History” in the Document, create one
stating the title, year, authors, and publisher of the Document as
given on its Title Page, then add an item describing the Modified
Version as stated in the previous sentence.
@@ -29414,13 +29647,13 @@ Version as stated in the previous sentence.
Preserve the network location, if any, given in the Document for
public access to a Transparent copy of the Document, and likewise
the network locations given in the Document for previous versions
-it was based on. These may be placed in the "History" section.
+it was based on. These may be placed in the “History” section.
You may omit a network location for a work that was published at
least four years before the Document itself, or if the original
publisher of the version it refers to gives permission.
@item
-For any section Entitled "Acknowledgements" or "Dedications",
+For any section Entitled “Acknowledgements” or “Dedications”,
Preserve the Title of the section, and preserve in the section all
the substance and tone of each of the contributor acknowledgements
and/or dedications given therein.
@@ -29431,11 +29664,11 @@ unaltered in their text and in their titles. Section numbers
or the equivalent are not considered part of the section titles.
@item
-Delete any section Entitled "Endorsements". Such a section
+Delete any section Entitled “Endorsements”. Such a section
may not be included in the Modified Version.
@item
-Do not retitle any existing section to be Entitled "Endorsements"
+Do not retitle any existing section to be Entitled “Endorsements”
or to conflict in title with any Invariant Section.
@item
@@ -29446,12 +29679,12 @@ If the Modified Version includes new front-matter sections or
appendices that qualify as Secondary Sections and contain no material
copied from the Document, you may at your option designate some or all
of these sections as invariant. To do this, add their titles to the
-list of Invariant Sections in the Modified Version's license notice.
+list of Invariant Sections in the Modified Version’s license notice.
These titles must be distinct from any other section titles.
-You may add a section Entitled "Endorsements", provided it contains
+You may add a section Entitled “Endorsements”, provided it contains
nothing but endorsements of your Modified Version by various
-parties---for example, statements of peer review or that the text has
+parties—for example, statements of peer review or that the text has
been approved by an organization as the authoritative definition of a
standard.
@@ -29487,11 +29720,11 @@ author or publisher of that section if known, or else a unique number.
Make the same adjustment to the section titles in the list of
Invariant Sections in the license notice of the combined work.
-In the combination, you must combine any sections Entitled "History"
+In the combination, you must combine any sections Entitled “History”
in the various original documents, forming one section Entitled
-"History"; likewise combine any sections Entitled "Acknowledgements",
-and any sections Entitled "Dedications". You must delete all sections
-Entitled "Endorsements".
+“History”; likewise combine any sections Entitled “Acknowledgements”,
+and any sections Entitled “Dedications”. You must delete all sections
+Entitled “Endorsements”.
@strong{6. COLLECTIONS OF DOCUMENTS}
@@ -29510,16 +29743,16 @@ other respects regarding verbatim copying of that document.
A compilation of the Document or its derivatives with other separate
and independent documents or works, in or on a volume of a storage or
-distribution medium, is called an "aggregate" if the copyright
+distribution medium, is called an “aggregate” if the copyright
resulting from the compilation is not used to limit the legal rights
-of the compilation's users beyond what the individual works permit.
+of the compilation’s users beyond what the individual works permit.
When the Document is included in an aggregate, this License does not
apply to the other works in the aggregate which are not themselves
derivative works of the Document.
If the Cover Text requirement of section 3 is applicable to these
copies of the Document, then if the Document is less than one half of
-the entire aggregate, the Document's Cover Texts may be placed on
+the entire aggregate, the Document’s Cover Texts may be placed on
covers that bracket the Document within the aggregate, or the
electronic equivalent of covers if the Document is in electronic form.
Otherwise they must appear on printed covers that bracket the whole
@@ -29540,8 +29773,8 @@ of those notices and disclaimers. In case of a disagreement between
the translation and the original version of this License or a notice
or disclaimer, the original version will prevail.
-If a section in the Document is Entitled "Acknowledgements",
-"Dedications", or "History", the requirement (section 4) to Preserve
+If a section in the Document is Entitled “Acknowledgements”,
+“Dedications”, or “History”, the requirement (section 4) to Preserve
its Title (section 1) will typically require changing the actual
title.
@@ -29582,37 +29815,37 @@ differ in detail to address new problems or concerns. See
Each version of the License is given a distinguishing version number.
If the Document specifies that a particular numbered version of this
-License "or any later version" applies to it, you have the option of
+License “or any later version” applies to it, you have the option of
following the terms and conditions either of that specified version or
of any later version that has been published (not as a draft) by the
Free Software Foundation. If the Document does not specify a version
number of this License, you may choose any version ever published (not
as a draft) by the Free Software Foundation. If the Document
specifies that a proxy can decide which future versions of this
-License can be used, that proxy's public statement of acceptance of a
+License can be used, that proxy’s public statement of acceptance of a
version permanently authorizes you to choose that version for the
Document.
@strong{11. RELICENSING}
-"Massive Multiauthor Collaboration Site" (or "MMC Site") means any
+“Massive Multiauthor Collaboration Site” (or “MMC Site”) means any
World Wide Web server that publishes copyrightable works and also
provides prominent facilities for anybody to edit those works. A
public wiki that anybody can edit is an example of such a server. A
-"Massive Multiauthor Collaboration" (or "MMC") contained in the
+“Massive Multiauthor Collaboration” (or “MMC”) contained in the
site means any set of copyrightable works thus published on the MMC
site.
-"CC-BY-SA" means the Creative Commons Attribution-Share Alike 3.0
+“CC-BY-SA” means the Creative Commons Attribution-Share Alike 3.0
license published by Creative Commons Corporation, a not-for-profit
corporation with a principal place of business in San Francisco,
California, as well as future copyleft versions of that license
published by that same organization.
-"Incorporate" means to publish or republish a Document, in whole or
+“Incorporate” means to publish or republish a Document, in whole or
in part, as part of another Document.
-An MMC is "eligible for relicensing" if it is licensed under this
+An MMC is “eligible for relicensing” if it is licensed under this
License, and if all works that were first published under this License
somewhere other than this MMC, and subsequently incorporated in whole
or in part into the MMC, (1) had no cover texts or invariant sections,
@@ -29635,12 +29868,12 @@ Permission is granted to copy, distribute and/or modify this document
under the terms of the GNU Free Documentation License, Version 1.3
or any later version published by the Free Software Foundation;
with no Invariant Sections, no Front-Cover Texts, and no Back-Cover Texts.
-A copy of the license is included in the section entitled "GNU
-Free Documentation License".
+A copy of the license is included in the section entitled “GNU
+Free Documentation License”.
@end quotation
If you have Invariant Sections, Front-Cover Texts and Back-Cover Texts,
-replace the "with ... Texts." line with this:
+replace the “with … Texts.” line with this:
@quotation
diff --git a/gcc/ada/gnat_ugn.texi b/gcc/ada/gnat_ugn.texi
index 360177b..713a662 100644
--- a/gcc/ada/gnat_ugn.texi
+++ b/gcc/ada/gnat_ugn.texi
@@ -3,7 +3,7 @@
@setfilename gnat_ugn.info
@documentencoding UTF-8
@ifinfo
-@*Generated by Sphinx 1.4.6.@*
+@*Generated by Sphinx 4.0.2.@*
@end ifinfo
@settitle GNAT User's Guide for Native Platforms
@defindex ge
@@ -21,7 +21,7 @@
@copying
@quotation
-GNAT User's Guide for Native Platforms , Dec 11, 2020
+GNAT User's Guide for Native Platforms , Jun 23, 2021
AdaCore
@@ -59,7 +59,7 @@ Permission is granted to copy, distribute and/or modify this document
under the terms of the GNU Free Documentation License, Version 1.3 or
any later version published by the Free Software Foundation; with no
Invariant Sections, with the Front-Cover Texts being
-"GNAT User's Guide for Native Platforms",
+“GNAT User’s Guide for Native Platforms”,
and with no Back-Cover Texts. A copy of the license is
included in the section entitled @ref{1,,GNU Free Documentation License}.
@@ -538,7 +538,7 @@ Other Asm Functionality
@end menu
@node About This Guide,Getting Started with GNAT,Top,Top
-@anchor{gnat_ugn/about_this_guide about-this-guide}@anchor{2}@anchor{gnat_ugn/about_this_guide doc}@anchor{3}@anchor{gnat_ugn/about_this_guide gnat-user-s-guide-for-native-platforms}@anchor{4}@anchor{gnat_ugn/about_this_guide id1}@anchor{5}
+@anchor{gnat_ugn/about_this_guide doc}@anchor{2}@anchor{gnat_ugn/about_this_guide about-this-guide}@anchor{3}@anchor{gnat_ugn/about_this_guide gnat-user-s-guide-for-native-platforms}@anchor{4}@anchor{gnat_ugn/about_this_guide id1}@anchor{5}
@chapter About This Guide
@@ -554,7 +554,7 @@ 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
+Throughout this manual, references to ‘Ada’ without a year suffix
apply to all Ada versions of the language, starting with Ada 95.
@menu
@@ -721,22 +721,22 @@ Commands that are entered by the user are shown as preceded by a prompt string
comprising the @code{$} character followed by a space.
@item
-Full file names are shown with the '/' character
+Full file names are shown with the ‘/’ character
as the directory separator; e.g., @code{parent-dir/subdir/myfile.adb}.
If you are using GNAT on a Windows platform, please note that
-the '\' character should be used instead.
+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{14}@anchor{gnat_ugn/getting_started_with_gnat id1}@anchor{15}
+@anchor{gnat_ugn/getting_started_with_gnat doc}@anchor{14}@anchor{gnat_ugn/getting_started_with_gnat getting-started-with-gnat}@anchor{8}@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
+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: GNAT Studio.
-GNAT Studio offers a graphical "look and feel", support for development in
+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 the
@@ -780,7 +780,7 @@ 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}
+@anchor{gnat_ugn/getting_started_with_gnat id3}@anchor{18}@anchor{gnat_ugn/getting_started_with_gnat running-gnat}@anchor{19}
@section Running GNAT
@@ -805,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{1a}@anchor{gnat_ugn/getting_started_with_gnat id4}@anchor{1b}
+@anchor{gnat_ugn/getting_started_with_gnat id4}@anchor{1a}@anchor{gnat_ugn/getting_started_with_gnat running-a-simple-ada-program}@anchor{1b}
@section Running a Simple Ada Program
@@ -862,7 +862,7 @@ switch must always be present.)
This compile command generates a file
@code{hello.o}, which is the object
file corresponding to your Ada program. It also generates
-an 'Ada Library Information' file @code{hello.ali},
+an ‘Ada Library Information’ file @code{hello.ali},
which contains additional information used to check
that an Ada program is consistent.
@@ -871,7 +871,7 @@ 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.
+on such modified sources, so that ‘version skew’ is avoided.
@geindex Version skew (avoided by `@w{`}gnatmake`@w{`})
@@ -972,7 +972,7 @@ $ gnatmake gmain.adb
@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{20}@anchor{gnat_ugn/the_gnat_compilation_model the-gnat-compilation-model}@anchor{9}@anchor{gnat_ugn/the_gnat_compilation_model id1}@anchor{21}
+@anchor{gnat_ugn/the_gnat_compilation_model doc}@anchor{20}@anchor{gnat_ugn/the_gnat_compilation_model id1}@anchor{21}@anchor{gnat_ugn/the_gnat_compilation_model the-gnat-compilation-model}@anchor{9}
@chapter The GNAT Compilation Model
@@ -1054,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{22}@anchor{gnat_ugn/the_gnat_compilation_model id2}@anchor{2f}
+@anchor{gnat_ugn/the_gnat_compilation_model id2}@anchor{2f}@anchor{gnat_ugn/the_gnat_compilation_model source-representation}@anchor{22}
@section Source Representation
@@ -1205,7 +1205,7 @@ of the compiler (@ref{31,,Character Set Control}).
The basic character set is Latin-1. This character set is defined by ISO
standard 8859, part 1. The lower half (character codes @code{16#00#}
-... @code{16#7F#)} is identical to standard ASCII coding, but the upper
+… @code{16#7F#)} is identical to standard ASCII coding, but the upper
half is used to represent additional characters. These include extended letters
used by European languages, such as French accents, the vowels with umlauts
used in German, and the extra letter A-ring used in Swedish.
@@ -1220,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{34}@anchor{gnat_ugn/the_gnat_compilation_model id5}@anchor{35}
+@anchor{gnat_ugn/the_gnat_compilation_model id5}@anchor{34}@anchor{gnat_ugn/the_gnat_compilation_model other-8-bit-codes}@anchor{35}
@subsection Other 8-Bit Codes
@@ -1368,7 +1368,7 @@ This scheme is compatible with use of the full Wide_Character set.
@geindex Upper-Half Coding
The wide character with encoding @code{16#abcd#} where the upper bit is on
-(in other words, 'a' is in the range 8-F) is represented as two bytes,
+(in other words, ‘a’ is in the range 8-F) is represented as two bytes,
@code{16#ab#} and @code{16#cd#}. The second byte cannot be a format control
character, but is not required to be in the upper half. This method can
be also used for shift-JIS or EUC, where the internal coding matches the
@@ -1429,7 +1429,7 @@ character sequence:
where @code{a}, @code{b}, @code{c}, @code{d} are the four hexadecimal
characters (using uppercase letters) of the wide character code. For
-example, ['A345'] is used to represent the wide character with code
+example, [‘A345’] is used to represent the wide character with code
@code{16#A345#}. It is also possible (though not required) to use the
Brackets coding for upper half characters. For example, the code
@code{16#A3#} can be represented as @code{['A3']}.
@@ -1491,7 +1491,7 @@ twelve byte character sequence:
where @code{a-h} are the six or eight hexadecimal
characters (using uppercase letters) of the wide wide character code. For
-example, ["1F4567"] is used to represent the wide wide character with code
+example, [“1F4567”] is used to represent the wide wide character with code
@code{16#001F_4567#}.
This scheme is compatible with use of the full Wide_Wide_Character set,
@@ -1500,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{3a}@anchor{gnat_ugn/the_gnat_compilation_model file-naming-topics-and-utilities}@anchor{24}
+@anchor{gnat_ugn/the_gnat_compilation_model file-naming-topics-and-utilities}@anchor{24}@anchor{gnat_ugn/the_gnat_compilation_model id8}@anchor{3a}
@section File Naming Topics and Utilities
@@ -1626,7 +1626,7 @@ Following these rules can result in excessively long
file names if corresponding
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
+(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{3d,,Using gnatkr}.
@@ -1707,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{40}@anchor{gnat_ugn/the_gnat_compilation_model alternative-file-naming-schemes}@anchor{41}
+@anchor{gnat_ugn/the_gnat_compilation_model alternative-file-naming-schemes}@anchor{40}@anchor{gnat_ugn/the_gnat_compilation_model id11}@anchor{41}
@subsection Alternative File Naming Schemes
@@ -1825,7 +1825,7 @@ pragma Source_File_Name
@end example
Our final example implements a scheme typically used with one of the
-Ada 83 compilers, where the separator character for subunits was '__'
+Ada 83 compilers, where the separator character for subunits was ‘__’
(two underscores), specs were identified by adding @code{_.ADA}, bodies
by adding @code{.ADA}, and subunits by
adding @code{.SEP}. All file names were
@@ -1881,7 +1881,7 @@ 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{41,,Alternative File Naming Schemes}) may be sufficient. However,
+(@ref{40,,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.
@@ -1891,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{46}@anchor{gnat_ugn/the_gnat_compilation_model id14}@anchor{47}
+@anchor{gnat_ugn/the_gnat_compilation_model id14}@anchor{46}@anchor{gnat_ugn/the_gnat_compilation_model running-gnatname}@anchor{47}
@subsubsection Running @code{gnatname}
@@ -1934,7 +1934,7 @@ Examples of Naming Patterns are:
For a more complete description of the syntax of Naming Patterns,
see the second kind of regular expressions described in @code{g-regexp.ads}
-(the 'Glob' regular expressions).
+(the ‘Glob’ regular expressions).
When invoked without the switch @code{-P}, @code{gnatname} will create a
configuration pragmas file @code{gnat.adc} in the current working directory,
@@ -2084,7 +2084,7 @@ When a switch @code{-P} is specified,
no switch @code{-c} may be specified.
On all platforms, except on VMS, when @code{gnatname} is invoked for an
existing project file <proj>.gpr, a backup copy of the project file is created
-in the project directory with file name <proj>.gpr.saved_x. 'x' is the first
+in the project directory with file name <proj>.gpr.saved_x. ‘x’ is the first
non negative number that makes this backup copy a new file.
@geindex -v (gnatname)
@@ -2172,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{4e}@anchor{gnat_ugn/the_gnat_compilation_model about-gnatkr}@anchor{4f}
+@anchor{gnat_ugn/the_gnat_compilation_model about-gnatkr}@anchor{4e}@anchor{gnat_ugn/the_gnat_compilation_model id18}@anchor{4f}
@subsubsection About @code{gnatkr}
@@ -2202,7 +2202,7 @@ respectively.
@end itemize
The @code{-gnatk@emph{nn}}
-switch of the compiler activates a 'krunching'
+switch of the compiler activates a ‘krunching’
circuit that limits file names to nn characters (where nn is a decimal
integer).
@@ -2377,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{53}@anchor{gnat_ugn/the_gnat_compilation_model examples-of-gnatkr-usage}@anchor{54}
+@anchor{gnat_ugn/the_gnat_compilation_model examples-of-gnatkr-usage}@anchor{53}@anchor{gnat_ugn/the_gnat_compilation_model id21}@anchor{54}
@subsubsection Examples of @code{gnatkr} Usage
@@ -2411,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{56}@anchor{gnat_ugn/the_gnat_compilation_model handling-files-with-multiple-units}@anchor{57}
+@anchor{gnat_ugn/the_gnat_compilation_model handling-files-with-multiple-units}@anchor{56}@anchor{gnat_ugn/the_gnat_compilation_model id23}@anchor{57}
@subsubsection Handling Files with Multiple Units
@@ -2427,7 +2427,7 @@ Generated or modified project files can be processed by GNAT.
See @ref{42,,Handling Arbitrary File Naming Conventions with gnatname}
for more details on how to use @cite{gnatname}.
-Alternatively, if you want to permanently restructure a set of 'foreign'
+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.
@@ -2438,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{58}@anchor{gnat_ugn/the_gnat_compilation_model id24}@anchor{59}
+@anchor{gnat_ugn/the_gnat_compilation_model id24}@anchor{58}@anchor{gnat_ugn/the_gnat_compilation_model operating-gnatchop-in-compilation-mode}@anchor{59}
@subsubsection Operating gnatchop in Compilation Mode
@@ -2454,7 +2454,7 @@ find this default to be what they want. In this default mode it is incorrect to
submit a file containing only configuration pragmas, or one that ends in
configuration pragmas, to @code{gnatchop}.
-However, using a special option to activate 'compilation mode',
+However, using a special option to activate ‘compilation mode’,
@code{gnatchop}
can perform another function, which is to provide exactly the semantics
required by the RM for handling of configuration pragmas in a compilation.
@@ -2498,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{5a}@anchor{gnat_ugn/the_gnat_compilation_model command-line-for-gnatchop}@anchor{5b}
+@anchor{gnat_ugn/the_gnat_compilation_model command-line-for-gnatchop}@anchor{5a}@anchor{gnat_ugn/the_gnat_compilation_model id25}@anchor{5b}
@subsubsection Command Line for @code{gnatchop}
@@ -2572,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{5c}@anchor{gnat_ugn/the_gnat_compilation_model id26}@anchor{5d}
+@anchor{gnat_ugn/the_gnat_compilation_model id26}@anchor{5c}@anchor{gnat_ugn/the_gnat_compilation_model switches-for-gnatchop}@anchor{5d}
@subsubsection Switches for @code{gnatchop}
@@ -2738,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{5e}@anchor{gnat_ugn/the_gnat_compilation_model examples-of-gnatchop-usage}@anchor{5f}
+@anchor{gnat_ugn/the_gnat_compilation_model examples-of-gnatchop-usage}@anchor{5e}@anchor{gnat_ugn/the_gnat_compilation_model id27}@anchor{5f}
@subsubsection Examples of @code{gnatchop} Usage
@@ -2779,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{60}@anchor{gnat_ugn/the_gnat_compilation_model configuration-pragmas}@anchor{25}
+@anchor{gnat_ugn/the_gnat_compilation_model configuration-pragmas}@anchor{25}@anchor{gnat_ugn/the_gnat_compilation_model id28}@anchor{60}
@section Configuration Pragmas
@@ -2889,7 +2889,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{61}@anchor{gnat_ugn/the_gnat_compilation_model handling-of-configuration-pragmas}@anchor{3f}
+@anchor{gnat_ugn/the_gnat_compilation_model handling-of-configuration-pragmas}@anchor{3f}@anchor{gnat_ugn/the_gnat_compilation_model id29}@anchor{61}
@subsection Handling of Configuration Pragmas
@@ -2900,7 +2900,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{58,,Operating gnatchop in Compilation Mode} for details.
+See @ref{59,,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.
@@ -2930,7 +2930,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{62}@anchor{gnat_ugn/the_gnat_compilation_model id30}@anchor{63}
+@anchor{gnat_ugn/the_gnat_compilation_model id30}@anchor{62}@anchor{gnat_ugn/the_gnat_compilation_model the-configuration-pragmas-files}@anchor{63}
@subsection The Configuration Pragmas Files
@@ -2966,7 +2966,7 @@ Files containing configuration pragmas specified with switches
temporary files. A file is considered temporary if its name ends in
@code{.tmp} or @code{.TMP}. Certain tools follow this naming
convention because they pass information to @code{gcc} via
-temporary files that are immediately deleted; it doesn't make sense to
+temporary files that are immediately deleted; it doesn’t make sense to
depend on a file that no longer exists. Such tools include
@code{gprbuild}, @code{gnatmake}, and @code{gnatcheck}.
@@ -3057,7 +3057,7 @@ checking mode, use the @code{-gnatc} switch.
A given object file clearly depends on the source file which is compiled
-to produce it. Here we are using "depends" in the sense of a typical
+to produce it. Here we are using “depends” in the sense of a typical
@code{make} utility; in other words, an object file depends on a source
file if changes to the source file require the object file to be
recompiled.
@@ -3107,8 +3107,7 @@ that is performed by the front end of the compiler. This inlining does
not require that the code generation be optimized. Like @code{-gnatn},
the use of this switch generates additional dependencies.
-When using a gcc-based back end (in practice this means using any version
-of GNAT other than for the JVM, .NET or GNAAMP platforms), then the use of
+When using a gcc-based back end, then the use of
@code{-gnatN} is deprecated, and the use of @code{-gnatn} is preferred.
Historically front end inlining was more extensive than the gcc back end
inlining, but that is no longer the case.
@@ -3215,7 +3214,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{67}@anchor{gnat_ugn/the_gnat_compilation_model binding-an-ada-program}@anchor{29}
+@anchor{gnat_ugn/the_gnat_compilation_model binding-an-ada-program}@anchor{29}@anchor{gnat_ugn/the_gnat_compilation_model id34}@anchor{67}
@section Binding an Ada Program
@@ -3260,7 +3259,7 @@ object files for the Ada units of the program.
This section describes how to build and use libraries with GNAT, and also shows
how to recompile the GNAT run-time library. You should be familiar with the
Project Manager facility (see the @emph{GNAT_Project_Manager} chapter of the
-@emph{GPRbuild User's Guide}) before reading this chapter.
+@emph{GPRbuild User’s Guide}) before reading this chapter.
@menu
* Introduction to Libraries in GNAT::
@@ -3271,7 +3270,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{69}@anchor{gnat_ugn/the_gnat_compilation_model id36}@anchor{6a}
+@anchor{gnat_ugn/the_gnat_compilation_model id36}@anchor{69}@anchor{gnat_ugn/the_gnat_compilation_model introduction-to-libraries-in-gnat}@anchor{6a}
@subsection Introduction to Libraries in GNAT
@@ -3313,7 +3312,7 @@ inlined routine. In the case of @emph{stand-alone libraries} those exposed
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
+need to be elaborated in an order partially defined by Ada’s semantics. GNAT
computes the elaboration order from the @code{ALI} files and this is why they
constitute a mandatory part of GNAT libraries.
@emph{Stand-alone libraries} are the exception to this rule because a specific
@@ -3340,7 +3339,7 @@ using the library.
The easiest way to build a library is to use the Project Manager,
which supports a special type of project called a @emph{Library Project}
(see the @emph{Library Projects} section in the @emph{GNAT Project Manager}
-chapter of the @emph{GPRbuild User's Guide}).
+chapter of the @emph{GPRbuild User’s Guide}).
A project is considered a library project, when two project-level attributes
are defined in it: @code{Library_Name} and @code{Library_Dir}. In order to
@@ -3466,7 +3465,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{71}@anchor{gnat_ugn/the_gnat_compilation_model id39}@anchor{72}
+@anchor{gnat_ugn/the_gnat_compilation_model id39}@anchor{71}@anchor{gnat_ugn/the_gnat_compilation_model installing-a-library}@anchor{72}
@subsubsection Installing a library
@@ -3476,14 +3475,14 @@ be accessed by the directive @code{-l@emph{xxx}} at link time.
If you use project files, library installation is part of the library build
process (see the @emph{Installing a Library with Project Files} section of the
-@emph{GNAT Project Manager} chapter of the @emph{GPRbuild User's Guide}).
+@emph{GNAT Project Manager} chapter of the @emph{GPRbuild User’s Guide}).
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{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
+paths, by specifying the libraries’ location in the configuration files
@code{ada_source_path} and @code{ada_object_path}. These configuration files
must be located in the GNAT installation tree at the same place as the gcc spec
file. The location of the gcc spec file can be determined as follows:
@@ -3523,7 +3522,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{74}@anchor{gnat_ugn/the_gnat_compilation_model id40}@anchor{75}
+@anchor{gnat_ugn/the_gnat_compilation_model id40}@anchor{74}@anchor{gnat_ugn/the_gnat_compilation_model using-a-library}@anchor{75}
@subsubsection Using a library
@@ -3540,7 +3539,7 @@ project My_Proj is
end My_Proj;
@end example
-Even if you have a third-party, non-Ada library, you can still use GNAT's
+Even if you have a third-party, non-Ada library, you can still use GNAT’s
Project Manager facility to provide a wrapper for it. For example, the
following project, when @emph{with}ed by your main project, will link with the
third-party library @code{liba.a}:
@@ -3617,7 +3616,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{6b}@anchor{gnat_ugn/the_gnat_compilation_model id41}@anchor{77}
+@anchor{gnat_ugn/the_gnat_compilation_model id41}@anchor{77}@anchor{gnat_ugn/the_gnat_compilation_model stand-alone-ada-libraries}@anchor{6b}
@subsection Stand-alone Ada Libraries
@@ -3632,11 +3631,11 @@ 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{78}@anchor{gnat_ugn/the_gnat_compilation_model id42}@anchor{79}
+@anchor{gnat_ugn/the_gnat_compilation_model id42}@anchor{78}@anchor{gnat_ugn/the_gnat_compilation_model introduction-to-stand-alone-libraries}@anchor{79}
@subsubsection Introduction to Stand-alone Libraries
-A Stand-alone Library (abbreviated 'SAL') is a library that contains the
+A Stand-alone Library (abbreviated ‘SAL’) is a library that contains the
necessary code to
elaborate the Ada units that are included in the library. In contrast with
an ordinary library, which consists of all sources, objects and @code{ALI}
@@ -3644,10 +3643,10 @@ files of the
library, a SAL may specify a restricted subset of compilation units
to serve as a library interface. In this case, the fully
self-sufficient set of files will normally consist of an objects
-archive, the sources of interface units' specs, and the @code{ALI}
+archive, the sources of interface units’ specs, and the @code{ALI}
files of interface units.
If an interface spec contains a generic unit or an inlined subprogram,
-the body's
+the body’s
source must also be provided; if the units that must be provided in the source
form depend on other units, the source and @code{ALI} files of those must
also be provided.
@@ -3660,24 +3659,24 @@ version, controlled by @code{Library_Version} attribute, is not changed,
then the clients do not need to be relinked.
SALs also allow the library providers to minimize the amount of library source
-text exposed to the clients. Such 'information hiding' might be useful or
+text exposed to the clients. Such ‘information hiding’ might be useful or
necessary for various reasons.
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{7a}@anchor{gnat_ugn/the_gnat_compilation_model building-a-stand-alone-library}@anchor{7b}
+@anchor{gnat_ugn/the_gnat_compilation_model building-a-stand-alone-library}@anchor{7a}@anchor{gnat_ugn/the_gnat_compilation_model id43}@anchor{7b}
@subsubsection Building a Stand-alone Library
-GNAT's Project facility provides a simple way of building and installing
+GNAT’s Project facility provides a simple way of building and installing
stand-alone libraries; see the @emph{Stand-alone Library Projects} section
-in the @emph{GNAT Project Manager} chapter of the @emph{GPRbuild User's Guide}.
+in the @emph{GNAT Project Manager} chapter of the @emph{GPRbuild User’s Guide}.
To be a Stand-alone Library Project, in addition to the two attributes
that make a project a Library Project (@code{Library_Name} and
@code{Library_Dir}; see the @emph{Library Projects} section in the
-@emph{GNAT Project Manager} chapter of the @emph{GPRbuild User's Guide}),
+@emph{GNAT Project Manager} chapter of the @emph{GPRbuild User’s Guide}),
the attribute @code{Library_Interface} must be defined. For example:
@example
@@ -3781,12 +3780,12 @@ the object directory.
Copy the @code{ALI} files of the interface to the library directory,
add in this copy an indication that it is an interface to a SAL
(i.e., add a word @code{SL} on the line in the @code{ALI} file that starts
-with letter 'P') and make the modified copy of the @code{ALI} file
+with letter ‘P’) and make the modified copy of the @code{ALI} file
read-only.
@end itemize
Using SALs is not different from using other libraries
-(see @ref{74,,Using a library}).
+(see @ref{75,,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{7c}@anchor{gnat_ugn/the_gnat_compilation_model id44}@anchor{7d}
@@ -3814,7 +3813,7 @@ package My_Package is
end My_Package;
@end example
-On the foreign language side, you must provide a 'foreign' view of the
+On the foreign language side, you must provide a ‘foreign’ view of the
library interface; remember that it should contain elaboration routines in
addition to interface subprograms.
@@ -3956,7 +3955,7 @@ 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{82}@anchor{gnat_ugn/the_gnat_compilation_model conditional-compilation}@anchor{2b}
+@anchor{gnat_ugn/the_gnat_compilation_model conditional-compilation}@anchor{2b}@anchor{gnat_ugn/the_gnat_compilation_model id47}@anchor{82}
@section Conditional Compilation
@@ -3973,7 +3972,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{83}@anchor{gnat_ugn/the_gnat_compilation_model id48}@anchor{84}
+@anchor{gnat_ugn/the_gnat_compilation_model id48}@anchor{83}@anchor{gnat_ugn/the_gnat_compilation_model modeling-conditional-compilation-in-ada}@anchor{84}
@subsection Modeling Conditional Compilation in Ada
@@ -4168,7 +4167,7 @@ the @code{-gnata} switch is often the most convenient method of controlling
the status of these pragmas.
Note that a pragma is not a statement, so in contexts where a statement
-sequence is required, you can't just write a pragma on its own. You have
+sequence is required, you can’t just write a pragma on its own. You have
to add a @code{null} statement.
@example
@@ -4246,7 +4245,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{8b}@anchor{gnat_ugn/the_gnat_compilation_model id52}@anchor{8c}
+@anchor{gnat_ugn/the_gnat_compilation_model id52}@anchor{8b}@anchor{gnat_ugn/the_gnat_compilation_model use-of-alternative-implementations}@anchor{8c}
@subsubsection Use of Alternative Implementations
@@ -4280,7 +4279,7 @@ end if;
where @code{Ada_2005} is a Boolean constant.
-But this won't work when @code{Ada_2005} is set to @code{False},
+But this won’t work when @code{Ada_2005} is set to @code{False},
since the @code{then} clause will be illegal for an Ada 95 compiler.
(Recall that although such unreachable code would eventually be deleted
by the compiler, it still needs to be legal. If it uses features
@@ -4309,7 +4308,7 @@ have two files
and the build script renames the appropriate file to @code{file_queries-insert.adb} and then carries out the compilation.
-This can also be done with project files' naming schemes. For example:
+This can also be done with project files’ naming schemes. For example:
@example
for body ("File_Queries.Insert") use "file_queries-insert-2005.ada";
@@ -4366,11 +4365,11 @@ VMS-compatible AST handling. The GNAT build script knows the architecture
and operating system, and automatically selects the right version,
renaming it if necessary to @code{s-asthan.adb} before the run-time build.
-Another style for arranging alternative implementations is through Ada's
+Another style for arranging alternative implementations is through Ada’s
access-to-subprogram facility.
In case some functionality is to be conditionally included,
you can declare an access-to-procedure variable @code{Ref} that is initialized
-to designate a 'do nothing' procedure, and then invoke @code{Ref.all}
+to designate a ‘do nothing’ procedure, and then invoke @code{Ref.all}
when appropriate.
In some library package, set @code{Ref} to @code{Proc'Access} for some
procedure @code{Proc} that performs the relevant processing.
@@ -4380,7 +4379,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{8d}@anchor{gnat_ugn/the_gnat_compilation_model id53}@anchor{8e}
+@anchor{gnat_ugn/the_gnat_compilation_model id53}@anchor{8d}@anchor{gnat_ugn/the_gnat_compilation_model preprocessing}@anchor{8e}
@subsubsection Preprocessing
@@ -4434,7 +4433,7 @@ For more details on this approach, see @ref{90,,Integrated Preprocessing}.
@geindex Preprocessing (gnatprep)
-This section discusses how to use GNAT's @code{gnatprep} utility for simple
+This section discusses how to use GNAT’s @code{gnatprep} utility for simple
preprocessing.
Although designed for use with GNAT, @code{gnatprep} does not depend on any
special GNAT features.
@@ -4461,7 +4460,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{94}@anchor{gnat_ugn/the_gnat_compilation_model id56}@anchor{95}
+@anchor{gnat_ugn/the_gnat_compilation_model id56}@anchor{94}@anchor{gnat_ugn/the_gnat_compilation_model using-gnatprep}@anchor{95}
@subsubsection Using @code{gnatprep}
@@ -4519,7 +4518,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{96}@anchor{gnat_ugn/the_gnat_compilation_model id57}@anchor{97}
+@anchor{gnat_ugn/the_gnat_compilation_model id57}@anchor{96}@anchor{gnat_ugn/the_gnat_compilation_model switches-for-gnatprep}@anchor{97}
@subsubsection Switches for @code{gnatprep}
@@ -4700,7 +4699,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{9a}@anchor{gnat_ugn/the_gnat_compilation_model form-of-input-text-for-gnatprep}@anchor{9b}
+@anchor{gnat_ugn/the_gnat_compilation_model form-of-input-text-for-gnatprep}@anchor{9a}@anchor{gnat_ugn/the_gnat_compilation_model id59}@anchor{9b}
@subsubsection Form of Input Text for @code{gnatprep}
@@ -4742,8 +4741,8 @@ In this example, <expression> is defined by the following grammar:
<expression> ::= ( <expression> )
@end example
-Note the following restriction: it is not allowed to have "and" or "or"
-following "not" in the same expression without parentheses. For example, this
+Note the following restriction: it is not allowed to have “and” or “or”
+following “not” in the same expression without parentheses. For example, this
is not allowed:
@example
@@ -4769,7 +4768,7 @@ literal integer as defined in the Ada Reference Manual, such as 3, 16#FF# or
2#11#. The symbol value must also be a non negative integer. Integer values
in the range 0 .. 2**31-1 are supported.
-The test (<expression> ::= <symbol>'Defined) is true only if
+The test (<expression> ::= <symbol>’Defined) is true only if
the symbol has been defined in the definition file or by a @code{-D}
switch on the command line. Otherwise, the test is false.
@@ -4785,8 +4784,8 @@ or @code{False}.
The use of the @code{not} operator inverts the sense of this logical test.
The @code{not} operator cannot be combined with the @code{or} or @code{and}
-operators, without parentheses. For example, "if not X or Y then" is not
-allowed, but "if (not X) or Y then" and "if not (X or Y) then" are.
+operators, without parentheses. For example, “if not X or Y then” is not
+allowed, but “if (not X) or Y then” and “if not (X or Y) then” are.
The @code{then} keyword is optional as shown
@@ -4906,7 +4905,7 @@ that relate to integrated preprocessing.
This switch specifies the file name (without directory
information) of the preprocessor data file. Either place this file
in one of the source directories, or, when using project
-files, reference the project file's directory via the
+files, reference the project file’s directory via the
@code{project_name'Project_Dir} project attribute; e.g:
@quotation
@@ -4932,7 +4931,7 @@ preprocessing.
Empty lines and comments (using Ada syntax) are also permitted, with no
semantic effect.
-Here's an example of a preprocessor data file:
+Here’s an example of a preprocessor data file:
@quotation
@@ -4971,7 +4970,7 @@ A preprocessor control line has the following syntax:
@end quotation
Thus each preprocessor control line starts with either a literal string or
-the character '*':
+the character ‘*’:
@itemize *
@@ -4981,16 +4980,16 @@ A literal string is the file name (without directory information) of the source
file that will be input to the preprocessor.
@item
-The character '*' is a wild-card indicator; the additional parameters on the line
+The character ‘*’ is a wild-card indicator; the additional parameters on the line
indicate the preprocessing for all the sources
that are not specified explicitly on other lines (the order of the lines is not
significant).
@end itemize
It is an error to have two lines with the same file name or two
-lines starting with the character '*'.
+lines starting with the character ‘*’.
-After the file name or '*', an optional literal string specifies the name of
+After the file name or ‘*’, an optional literal string specifies the name of
the definition file to be used for preprocessing
(@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
@@ -5015,7 +5014,7 @@ it cancels the effect of @code{-c}.
Causes both preprocessor lines and the lines deleted
by preprocessing to be retained as comments marked
-with the special string '@cite{--!}'.
+with the special string ‘@cite{–!}’.
@item @code{-D@emph{symbol}=@emph{new_value}}
@@ -5084,7 +5083,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{2c}@anchor{gnat_ugn/the_gnat_compilation_model id61}@anchor{9d}
+@anchor{gnat_ugn/the_gnat_compilation_model id61}@anchor{9d}@anchor{gnat_ugn/the_gnat_compilation_model mixed-language-programming}@anchor{2c}
@section Mixed Language Programming
@@ -5103,13 +5102,13 @@ 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{9e}@anchor{gnat_ugn/the_gnat_compilation_model id62}@anchor{9f}
+@anchor{gnat_ugn/the_gnat_compilation_model id62}@anchor{9e}@anchor{gnat_ugn/the_gnat_compilation_model interfacing-to-c}@anchor{9f}
@subsection Interfacing to C
Interfacing Ada with a foreign language such as C involves using
compiler directives to import and/or export entity definitions in each
-language -- using @code{extern} statements in C, for instance, and the
+language – using @code{extern} statements in C, for instance, and the
@code{Import}, @code{Export}, and @code{Convention} pragmas in Ada.
A full treatment of these topics is provided in Appendix B, section 1
of the Ada Reference Manual.
@@ -5284,7 +5283,7 @@ end Unit2;
@end example
The build procedure for this application is similar to the last
-example's:
+example’s:
@itemize *
@@ -5437,7 +5436,7 @@ in section B.4 of the Ada Reference Manual.
Data will be passed according to the conventions described
in section B.3 of the Ada Reference Manual.
-A note on interfacing to a C 'varargs' function:
+A note on interfacing to a C ‘varargs’ function:
@quotation
@@ -5543,7 +5542,7 @@ The return type must be the same as the type of the first argument. The size
of this type can only be 8, 16, 32, or 64.
@item
-Binary arithmetic operators: '+', '-', '*', '/'.
+Binary arithmetic operators: ‘+’, ‘-‘, ‘*’, ‘/’.
The corresponding operator declaration must have parameters and result type
that have the same root numeric type (for example, all three are long_float
types). This simplifies the definition of operations that use type checking
@@ -5580,7 +5579,7 @@ pragma Import (Intrinsic, builtin_sqrt, "__builtin_sqrtf");
@end example
Most of the GCC builtins are accessible this way, and as for other
-import conventions (e.g. C), it is the user's responsibility to ensure
+import conventions (e.g. C), it is the user’s responsibility to ensure
that the Ada subprogram profile matches the underlying builtin
expectations.
@end itemize
@@ -5654,7 +5653,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{a3}@anchor{gnat_ugn/the_gnat_compilation_model building-mixed-ada-and-c-programs}@anchor{a4}
+@anchor{gnat_ugn/the_gnat_compilation_model building-mixed-ada-and-c-programs}@anchor{a3}@anchor{gnat_ugn/the_gnat_compilation_model id64}@anchor{a4}
@subsection Building Mixed Ada and C++ Programs
@@ -5678,7 +5677,7 @@ challenge. This section gives a few hints that should make this task easier.
GNAT supports interfacing with the G++ compiler (or any C++ compiler
generating code that is compatible with the G++ Application Binary
-Interface ---see @indicateurl{http://www.codesourcery.com/archives/cxx-abi}).
+Interface —see @indicateurl{http://www.codesourcery.com/archives/cxx-abi}).
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}
@@ -5752,7 +5751,7 @@ important to note that environment variables such as
at the same time and may make one of the two compilers operate
improperly if set during invocation of the wrong compiler. It is also
very important that the linker uses the proper @code{libgcc.a} GCC
-library -- that is, the one from the C++ compiler installation. The
+library – that is, the one from the C++ compiler installation. The
implicit link command as suggested in the @code{gnatmake} command
from the former example can be replaced by an explicit link command with
the full-verbosity option in order to verify which library is used:
@@ -5794,7 +5793,7 @@ $ gnatlink ada_unit file1.o file2.o --LINK=./my_script
where CC is the name of the non-GNU C++ compiler.
-If the "zero cost" exception mechanism is used, and the platform
+If the “zero cost” exception mechanism is used, and the platform
supports automatic registration of exception tables (e.g., Solaris),
paths to more objects are required:
@@ -5807,8 +5806,8 @@ gcc -print-file-name=crtend.o
$ gnatlink ada_unit file1.o file2.o --LINK=./my_script
@end example
-If the "zero cost exception" mechanism is used, and the platform
-doesn't support automatic registration of exception tables (e.g., HP-UX
+If the “zero cost exception” mechanism is used, and the platform
+doesn’t support automatic registration of exception tables (e.g., HP-UX
or AIX), the simple approach described above will not work and
a pre-linking phase using GNAT will be necessary.
@end itemize
@@ -5818,7 +5817,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{aa}@anchor{gnat_ugn/the_gnat_compilation_model a-simple-example}@anchor{ab}
+@anchor{gnat_ugn/the_gnat_compilation_model a-simple-example}@anchor{aa}@anchor{gnat_ugn/the_gnat_compilation_model id67}@anchor{ab}
@subsubsection A Simple Example
@@ -6144,7 +6143,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{ae}@anchor{gnat_ugn/the_gnat_compilation_model id69}@anchor{af}
+@anchor{gnat_ugn/the_gnat_compilation_model id69}@anchor{af}@anchor{gnat_ugn/the_gnat_compilation_model interfacing-with-c-at-the-class-level}@anchor{ae}
@subsubsection Interfacing with C++ at the Class Level
@@ -6390,7 +6389,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{b0}@anchor{gnat_ugn/the_gnat_compilation_model generating-ada-bindings-for-c-and-c-headers}@anchor{a7}
+@anchor{gnat_ugn/the_gnat_compilation_model generating-ada-bindings-for-c-and-c-headers}@anchor{a7}@anchor{gnat_ugn/the_gnat_compilation_model id70}@anchor{b0}
@subsection Generating Ada Bindings for C and C++ headers
@@ -6458,7 +6457,7 @@ $ gcc -c *.ads
will generate, under GNU/Linux, the following files: @code{time_h.ads},
@code{bits_time_h.ads}, @code{stddef_h.ads}, @code{bits_types_h.ads} which
correspond to the files @code{/usr/include/time.h},
-@code{/usr/include/bits/time.h}, etc..., and will then compile these Ada specs
+@code{/usr/include/bits/time.h}, etc…, and will then compile these Ada specs
in Ada 2005 mode.
The @code{-C} switch tells @code{gcc} to extract comments from headers,
@@ -6535,7 +6534,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{b3}@anchor{gnat_ugn/the_gnat_compilation_model generating-bindings-for-c-headers}@anchor{b4}
+@anchor{gnat_ugn/the_gnat_compilation_model generating-bindings-for-c-headers}@anchor{b3}@anchor{gnat_ugn/the_gnat_compilation_model id72}@anchor{b4}
@subsubsection Generating Bindings for C++ Headers
@@ -6795,7 +6794,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{ba}@anchor{gnat_ugn/the_gnat_compilation_model gnat-and-other-compilation-models}@anchor{2d}
+@anchor{gnat_ugn/the_gnat_compilation_model gnat-and-other-compilation-models}@anchor{2d}@anchor{gnat_ugn/the_gnat_compilation_model id74}@anchor{ba}
@section GNAT and Other Compilation Models
@@ -6817,7 +6816,7 @@ used for Ada 83.
The GNAT model of compilation is close to the C and C++ models. You can
think of Ada specs as corresponding to header files in C. As in C, you
-don't need to compile specs; they are compiled when they are used. The
+don’t need to compile specs; they are compiled when they are used. The
Ada @emph{with} is similar in effect to the @code{#include} of a C
header.
@@ -6855,7 +6854,7 @@ model, as described in the Ada Reference Manual.
@geindex GNAT library
-In GNAT, there is no 'library' in the normal sense. Instead, the set of
+In GNAT, there is no ‘library’ in the normal sense. Instead, the set of
source files themselves acts as the library. Compiling Ada programs does
not generate any centralized information, but rather an object file and
a ALI file, which are of interest only to the binder and linker.
@@ -6913,7 +6912,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{2e}@anchor{gnat_ugn/the_gnat_compilation_model id77}@anchor{bf}
+@anchor{gnat_ugn/the_gnat_compilation_model id77}@anchor{bf}@anchor{gnat_ugn/the_gnat_compilation_model using-gnat-files-with-external-tools}@anchor{2e}
@section Using GNAT Files with External Tools
@@ -6927,7 +6926,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{c0}@anchor{gnat_ugn/the_gnat_compilation_model id78}@anchor{c1}
+@anchor{gnat_ugn/the_gnat_compilation_model id78}@anchor{c0}@anchor{gnat_ugn/the_gnat_compilation_model using-other-utility-programs-with-gnat}@anchor{c1}
@subsection Using Other Utility Programs with GNAT
@@ -6942,7 +6941,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{c2}@anchor{gnat_ugn/the_gnat_compilation_model id79}@anchor{c3}
+@anchor{gnat_ugn/the_gnat_compilation_model id79}@anchor{c2}@anchor{gnat_ugn/the_gnat_compilation_model the-external-symbol-naming-scheme-of-gnat}@anchor{c3}
@subsection The External Symbol Naming Scheme of GNAT
@@ -7001,7 +7000,7 @@ 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{c4}@anchor{gnat_ugn/building_executable_programs_with_gnat id1}@anchor{c5}
+@anchor{gnat_ugn/building_executable_programs_with_gnat doc}@anchor{c4}@anchor{gnat_ugn/building_executable_programs_with_gnat building-executable-programs-with-gnat}@anchor{a}@anchor{gnat_ugn/building_executable_programs_with_gnat id1}@anchor{c5}
@chapter Building Executable Programs with GNAT
@@ -7032,7 +7031,7 @@ in a GNAT context (see @ref{70,,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{c6}@anchor{gnat_ugn/building_executable_programs_with_gnat building-with-gnatmake}@anchor{ca}
+@anchor{gnat_ugn/building_executable_programs_with_gnat building-with-gnatmake}@anchor{ca}@anchor{gnat_ugn/building_executable_programs_with_gnat the-gnat-make-program-gnatmake}@anchor{c6}
@section Building with @code{gnatmake}
@@ -7081,7 +7080,7 @@ dependencies, they will always be tracked exactly correctly by
Note that for advanced forms of project structure, we recommend creating
a project file as explained in the @emph{GNAT_Project_Manager} chapter in the
-@emph{GPRbuild User's Guide}, and using the
+@emph{GPRbuild User’s Guide}, and using the
@code{gprbuild} tool which supports building with project files and works similarly
to @code{gnatmake}.
@@ -7096,7 +7095,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{cb}@anchor{gnat_ugn/building_executable_programs_with_gnat id2}@anchor{cc}
+@anchor{gnat_ugn/building_executable_programs_with_gnat id2}@anchor{cb}@anchor{gnat_ugn/building_executable_programs_with_gnat running-gnatmake}@anchor{cc}
@subsection Running @code{gnatmake}
@@ -7131,7 +7130,7 @@ All @code{gnatmake} output (except when you specify @code{-M}) is sent to
@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{cd}@anchor{gnat_ugn/building_executable_programs_with_gnat id3}@anchor{ce}
+@anchor{gnat_ugn/building_executable_programs_with_gnat id3}@anchor{cd}@anchor{gnat_ugn/building_executable_programs_with_gnat switches-for-gnatmake}@anchor{ce}
@subsection Switches for @code{gnatmake}
@@ -7219,7 +7218,7 @@ itself must not include any embedded spaces.
@item @code{--create-map-file}
When linking an executable, create a map file. The name of the map file
-has the same name as the executable with extension ".map".
+has the same name as the executable with extension “.map”.
@item @code{--create-map-file=@emph{mapfile}}
@@ -7267,7 +7266,7 @@ to process the project files, especially when looking for sources that take a
long time. If the source info file exists but cannot be parsed successfully,
the Project Manager will attempt to recreate it. If the Project Manager fails
to create the source info file, a message is issued, but gnatmake does not
-fail. @code{gnatmake} "trusts" the source info file. This means that
+fail. @code{gnatmake} “trusts” the source info file. This means that
if the source files have changed (addition, deletion, moving to a different
source directory), then the source info file need to be deleted and recreated.
@end table
@@ -7347,7 +7346,7 @@ the objects.
Use a temporary mapping file. A mapping file is a way to communicate
to the compiler two mappings: from unit names to file names (without
any directory information) and from file names to path names (with
-full directory information). A mapping file can make the compiler's
+full directory information). A mapping file can make the compiler’s
file searches faster, especially if there are many source directories,
or the sources are read over a slow network connection. If
@code{-P} is used, a mapping file is always used, so
@@ -7434,7 +7433,7 @@ directories, but is not needed in other cases.
@geindex naming scheme
This also assumes that no directory matches the naming scheme for files (for
-instance that you do not have a directory called "sources.ads" when using the
+instance that you do not have a directory called “sources.ads” when using the
default GNAT naming scheme).
When you do not have to use this switch (i.e., by default), gnatmake is able to
@@ -7463,7 +7462,7 @@ instead of standard error.
@item @code{-f}
Force recompilations. Recompile all sources, even though some object
-files may be up to date, but don't recompile predefined or GNAT internal
+files may be up to date, but don’t recompile predefined or GNAT internal
files or locked files (files with a write-protected ALI file),
unless the @code{-a} switch is also specified.
@end table
@@ -7541,7 +7540,7 @@ rerun the make process with n set to 1 to get a clean list of messages.
@item @code{-k}
Keep going. Continue as much as possible after a compilation error. To
-ease the programmer's task in case of compilation errors, the list of
+ease the programmer’s task in case of compilation errors, the list of
sources for which the compile fails is given when @code{gnatmake}
terminates.
@@ -7625,7 +7624,7 @@ are never reported.
@item @code{-n}
-Don't compile, bind, or link. Checks if all objects are up to date.
+Don’t compile, bind, or link. Checks if all objects are up to date.
If they are not, the full name of the first file that needs to be
recompiled is printed.
Repeated use of this option, followed by compiling the indicated source
@@ -7692,7 +7691,7 @@ Quiet. When this flag is not set, the commands carried out by
Recompile if compiler switches have changed since last compilation.
All compiler switches but -I and -o are taken into account in the
following way:
-orders between different 'first letter' switches are ignored, but
+orders between different ‘first letter’ switches are ignored, but
orders between same switches are taken into account. For example,
@code{-O -O2} is different than @code{-O2 -O}, but @code{-g -O}
is equivalent to @code{-O -g}.
@@ -8096,12 +8095,12 @@ 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{d4}@anchor{gnat_ugn/building_executable_programs_with_gnat how-gnatmake-works}@anchor{d5}
+@anchor{gnat_ugn/building_executable_programs_with_gnat how-gnatmake-works}@anchor{d4}@anchor{gnat_ugn/building_executable_programs_with_gnat id6}@anchor{d5}
@subsection How @code{gnatmake} Works
Generally @code{gnatmake} automatically performs all necessary
-recompilations and you don't need to worry about how it works. However,
+recompilations and you don’t need to worry about how it works. However,
it may be useful to have some basic understanding of the @code{gnatmake}
approach and in particular to understand how it uses the results of
previous compilations without incorrectly depending on them.
@@ -8124,7 +8123,7 @@ files.
This process ensures that @code{gnatmake} only trusts the dependencies
in an existing ALI file if they are known to be correct. Otherwise it
always recompiles to determine a new, guaranteed accurate set of
-dependencies. As a result the program is compiled 'upside down' from what may
+dependencies. As a result the program is compiled ‘upside down’ from what may
be more familiar as the required order of compilation in some other Ada
systems. In particular, clients are compiled before the units on which
they depend. The ability of GNAT to compile in any order is critical in
@@ -8366,7 +8365,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{71,,Installing a library}
+@ref{72,,Installing a library}
@end itemize
Specifying the switch @code{-I-}
@@ -8449,7 +8448,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{df}@anchor{gnat_ugn/building_executable_programs_with_gnat examples}@anchor{e0}
+@anchor{gnat_ugn/building_executable_programs_with_gnat examples}@anchor{df}@anchor{gnat_ugn/building_executable_programs_with_gnat id12}@anchor{e0}
@subsection Examples
@@ -8516,7 +8515,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{e2}@anchor{gnat_ugn/building_executable_programs_with_gnat alphabetical-list-of-all-switches}@anchor{e3}
+@anchor{gnat_ugn/building_executable_programs_with_gnat alphabetical-list-of-all-switches}@anchor{e2}@anchor{gnat_ugn/building_executable_programs_with_gnat id13}@anchor{e3}
@subsection Alphabetical List of All Switches
@@ -8542,7 +8541,7 @@ system configuration. You must have a GNAT cross-compiler built if
Load compiler executables (for example, @code{gnat1}, the Ada compiler)
from @code{dir} instead of the default location. Only use this switch
when multiple versions of the GNAT compiler are available.
-See the "Options for Directory Search" section in the
+See the “Options for Directory Search” section in the
@cite{Using the GNU Compiler Collection (GCC)} manual for further details.
You would normally use the @code{-b} or @code{-V} switch instead.
@end table
@@ -8581,6 +8580,18 @@ marker is specified, the callgraph is decorated with information about
dynamically allocated objects.
@end table
+@geindex -fdiagnostics-format (gcc)
+
+
+@table @asis
+
+@item @code{-fdiagnostics-format=json}
+
+Makes GNAT emit warning and error messages as JSON. Inhibits printing of
+text warning and errors messages except if @code{-gnatv} or
+@code{-gnatl} are present.
+@end table
+
@geindex -fdump-scos (gcc)
@@ -8794,6 +8805,16 @@ Allow full Ada 2005 features (same as @code{-gnat05})
@item @code{-gnat2012}
Allow full Ada 2012 features (same as @code{-gnat12})
+@end table
+
+@geindex -gnat2022 (gcc)
+
+
+@table @asis
+
+@item @code{-gnat2022}
+
+Allow full Ada 2022 features
@item @code{-gnat83}
@@ -8867,7 +8888,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
+Assume no invalid (bad) values except for ‘Valid attribute use
(@ref{e7,,Validity Checking}).
@end table
@@ -8911,9 +8932,9 @@ as -gnatn, and enable others such as -gnata).
@item @code{-gnatd}
Specify debug options for the compiler. The string of characters after
-the @code{-gnatd} specify the specific debug options. The possible
-characters are 0-9, a-z, A-Z, optionally preceded by a dot. See
-compiler source file @code{debug.adb} for details of the implemented
+the @code{-gnatd} specifies the specific debug options. The possible
+characters are 0-9, a-z, A-Z, optionally preceded by a dot or underscore.
+See compiler source file @code{debug.adb} for details of the implemented
debug options. Certain debug options are relevant to applications
programmers, and these are documented at appropriate points in this
users guide.
@@ -8994,7 +9015,7 @@ ALI files.
Specify a configuration pragma file
(the equal sign is optional)
-(@ref{62,,The Configuration Pragmas Files}).
+(@ref{63,,The Configuration Pragmas Files}).
@end table
@geindex -gnateC (gcc)
@@ -9265,8 +9286,7 @@ be specified in GNAT. It is computed for GCC backends as @code{BIGGEST_ALIGNMENT
follows: @cite{Biggest alignment that any data type can require on this machine@comma{} in bits.}
@code{Max_Unaligned_Field} is the maximum size for unaligned bit field, which is
-64 for the majority of GCC targets (but can be different on some targets like
-AAMP).
+64 for the majority of GCC targets (but can be different on some targets).
@code{Strict_Alignment} is the equivalent of GCC macro @code{STRICT_ALIGNMENT}
documented as follows: @cite{Define this macro to be the value 1 if instructions will fail to work if given data not on the nominal alignment. If instructions will merely go slower in that case@comma{} define this macro as 0.}
@@ -9299,8 +9319,9 @@ name digs float_rep size alignment
where @code{name} is the string name of the type (which can have
single spaces embedded in the name (e.g. long double), @code{digs} is
the number of digits for the floating-point type, @code{float_rep} is
-the float representation (I/V/A for IEEE-754-Binary, Vax_Native,
-AAMP), @code{size} is the size in bits, @code{alignment} is the
+the float representation (I for IEEE-754-Binary, which is
+the only one supported at this time),
+@code{size} is the size in bits, @code{alignment} is the
alignment in bits. The name is followed by at least two blanks, fields
are separated by at least one blank, and a LF character immediately
follows the alignment field.
@@ -9462,7 +9483,7 @@ For further details see @ref{f,,Elaboration Order Handling in GNAT}.
@item @code{-gnati@emph{c}}
-Identifier character set (@code{c} = 1/2/3/4/8/9/p/f/n/w).
+Identifier character set (@code{c} = 1/2/3/4/5/9/p/8/f/n/w).
For details of the possible selections for @code{c},
see @ref{31,,Character Set Control}.
@end table
@@ -9484,7 +9505,7 @@ and attribute_definition_clause for the following attributes:
Address, Alignment, Bit_Order, Component_Size, Machine_Radix,
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
+Note that this option should be used only for compiling – the
code is likely to malfunction at run time.
@end table
@@ -9533,7 +9554,7 @@ Calls to subprograms defined in instances
Entry calls
@item
-Indirect calls using 'Access
+Indirect calls using ‘Access
@item
Requeue statements
@@ -9624,8 +9645,7 @@ pragma @code{Inline} is specified. This inlining is performed
by the front end and will be visible in the
@code{-gnatG} output.
-When using a gcc-based back end (in practice this means using any version
-of GNAT other than the JGNAT, .NET or GNAAMP versions), then the use of
+When using a gcc-based back end, then the use of
@code{-gnatN} is deprecated, and the use of @code{-gnatn} is preferred.
Historically front end inlining was more extensive than the gcc back end
inlining, but that is no longer the case.
@@ -9744,7 +9764,7 @@ Cancel effect of previous @code{-gnatp} switch.
@item @code{-gnatq}
-Don't quit. Try semantics, even if parse errors.
+Don’t quit. Try semantics, even if parse errors.
@end table
@geindex -gnatQ (gcc)
@@ -9754,7 +9774,7 @@ Don't quit. Try semantics, even if parse errors.
@item @code{-gnatQ}
-Don't quit. Generate @code{ALI} and tree files even if illegalities.
+Don’t quit. Generate @code{ALI} and tree files even if illegalities.
Note that code generation is still suppressed in the presence of any
errors, so even with @code{-gnatQ} no object file is generated.
@end table
@@ -9829,7 +9849,7 @@ List units for this compilation.
@item @code{-gnatU}
-Tag all error messages with the unique string 'error:'
+Tag all error messages with the unique string ‘error:’
@end table
@geindex -gnatv (gcc)
@@ -10068,7 +10088,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{cd,,Switches for gnatmake}).
+equivalent @code{gnatmake} flag (@ref{ce,,Switches for gnatmake}).
@end table
@geindex -S (gcc)
@@ -10177,27 +10197,27 @@ switches, and only one of them may appear in the command line.
The switch @code{-gnat-p} may not be combined with any other switch.
@item
-Once a 'y' appears in the string (that is a use of the @code{-gnaty}
+Once a ‘y’ appears in the string (that is a use of the @code{-gnaty}
switch), then all further characters in the switch are interpreted
as style modifiers (see description of @code{-gnaty}).
@item
-Once a 'd' appears in the string (that is a use of the @code{-gnatd}
+Once a ‘d’ appears in the string (that is a use of the @code{-gnatd}
switch), then all further characters in the switch are interpreted
as debug flags (see description of @code{-gnatd}).
@item
-Once a 'w' appears in the string (that is a use of the @code{-gnatw}
+Once a ‘w’ appears in the string (that is a use of the @code{-gnatw}
switch), then all further characters in the switch are interpreted
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}
+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{e7,,Validity Checking}).
@item
-Option 'em', 'ec', 'ep', 'l=' and 'R' must be the last options in
+Option ‘em’, ‘ec’, ‘ep’, ‘l=’ and ‘R’ must be the last options in
a combined list of options.
@end itemize
@@ -10208,7 +10228,7 @@ a combined list of options.
@geindex stderr
-The standard default format for error messages is called 'brief format'.
+The standard default format for error messages is called ‘brief format’.
Brief format messages are written to @code{stderr} (the standard error
file) and have the following form:
@@ -10332,7 +10352,7 @@ then the output is written to file xyz.adb.lst.
@item @code{-gnatU}
This switch forces all error messages to be preceded by the unique
-string 'error:'. This means that error messages take a few more
+string ‘error:’. This means that error messages take a few more
characters in space, but allows easy searching for and identification
of error messages.
@end table
@@ -10460,7 +10480,7 @@ is longer than nn characters.
@item @code{-gnatq}
-The @code{q} stands for quit (really 'don't quit').
+The @code{q} stands for quit (really ‘don’t quit’).
In normal operation mode, the compiler first parses the program and
determines if there are any syntax errors. If there are, appropriate
error messages are generated and compilation is immediately terminated.
@@ -10497,7 +10517,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{eb}@anchor{gnat_ugn/building_executable_programs_with_gnat id15}@anchor{f0}
+@anchor{gnat_ugn/building_executable_programs_with_gnat id15}@anchor{f0}@anchor{gnat_ugn/building_executable_programs_with_gnat warning-message-control}@anchor{eb}
@subsection Warning Message Control
@@ -10930,10 +10950,10 @@ for conditional compilation in Ada, and this would generate too many
false positive warnings.
This warning option also activates a special test for comparisons using
-the operators '>=' and' <='.
+the operators ‘>=’ and’ <=’.
If the compiler can tell that only the equality condition is possible,
-then it will warn that the '>' or '<' part of the test
-is useless and that the operator could be replaced by '='.
+then it will warn that the ‘>’ or ‘<’ part of the test
+is useless and that the operator could be replaced by ‘=’.
An example would be comparing a @code{Natural} variable <= 0.
This warning option also generates warnings if
@@ -11099,7 +11119,7 @@ of the pragma @code{Restriction_Warnings}.
@emph{[warning-as-error]}
Used to tag warning messages that have been converted to error messages by
use of the pragma Warning_As_Error. Note that such warnings are prefixed by
-the string "error: " rather than "warning: ".
+the string “error: ” rather than “warning: “.
@item
@emph{[enabled by default]}
@@ -11336,7 +11356,7 @@ implementation unit, defined as any unit from the @code{Ada},
or @code{System}
hierarchies that is not
documented in either the Ada Reference Manual or the GNAT
-Programmer's Reference Manual. Such units are intended only
+Programmer’s Reference Manual. Such units are intended only
for internal implementation purposes and should not be @emph{with}ed
by user programs. The default is that such warnings are generated
@end table
@@ -11377,7 +11397,7 @@ types of the actuals are not by-copy types. This warning is off by default.
@emph{Disable warnings on overlapping actuals.}
-This switch disables warnings on overlapping actuals in a call..
+This switch disables warnings on overlapping actuals in a call.
@end table
@geindex -gnatwj (gcc)
@@ -11555,8 +11575,8 @@ This switch suppresses warnings for possible elaboration problems.
@emph{List inherited aspects.}
This switch causes the compiler to list inherited invariants,
-preconditions, and postconditions from Type_Invariant'Class, Invariant'Class,
-Pre'Class, and Post'Class aspects. Also list inherited subtype predicates.
+preconditions, and postconditions from Type_Invariant’Class, Invariant’Class,
+Pre’Class, and Post’Class aspects. Also list inherited subtype predicates.
@end table
@geindex -gnatw.L (gcc)
@@ -11616,7 +11636,9 @@ a modulus of 7 with a size of 7 bits), and modulus values of 32 or 64
with no size clause. The guess in both cases is that 2**x was intended
rather than x. In addition expressions of the form 2*x for small x
generate a warning (the almost certainly accurate guess being that
-2**x was intended). The default is that these warnings are given.
+2**x was intended). This switch also activates warnings for negative
+literal values of a modular type, which are interpreted as large positive
+integers after wrap-around. The default is that these warnings are given.
@end table
@geindex -gnatw.M (gcc)
@@ -11799,7 +11821,7 @@ ordering when the list of arguments are all simple identifiers that
match the names of the formals, but are in a different order. The
warning is suppressed if any use of named parameter notation is used,
so this is the appropriate way to suppress a false positive (and
-serves to emphasize that the "misordering" is deliberate). The
+serves to emphasize that the “misordering” is deliberate). The
default is that such warnings are not given.
@end table
@@ -11889,7 +11911,7 @@ then the remaining components whose length is fixed and not a multiple
of the storage unit,
@item
-then the remaining components whose length doesn't depend on discriminants
+then the remaining components whose length doesn’t depend on discriminants
(that is to say, with variable but uniform length for all objects),
@item
@@ -12166,7 +12188,7 @@ This switch activates warnings to be generated for entities that
are declared but not referenced, and for units that are @emph{with}ed
and not
referenced. In the case of packages, a warning is also generated if
-no entities in the package are referenced. This means that if a with'ed
+no entities in the package are referenced. This means that if a with’ed
package is referenced but the only references are in @code{use}
clauses or @code{renames}
declarations, a warning is still generated. A warning is also generated
@@ -12275,7 +12297,7 @@ may not be properly initialized.
@emph{Activate info messages for non-default bit order.}
-This switch activates messages (labeled "info", they are not warnings,
+This switch activates messages (labeled “info”, they are not warnings,
just informational messages) about the effects of non-default bit-order
on records to which a component clause is applied. The effect of specifying
non-default bit ordering is a bit subtle (and changed with Ada 2005), so
@@ -12308,7 +12330,7 @@ non-default bit order on record components with component clauses.
@emph{Activate warnings on wrong low bound assumption.}
This switch activates warnings for indexing an unconstrained string parameter
-with a literal or S'Length. This is a case where the code is assuming that the
+with a literal or S’Length. This is a case where the code is assuming that the
low bound is one, which is in general not true (for example when a slice is
passed). The default is that such warnings are generated.
@end table
@@ -12323,7 +12345,7 @@ passed). The default is that such warnings are generated.
@emph{Suppress warnings on wrong low bound assumption.}
This switch suppresses warnings for indexing an unconstrained string parameter
-with a literal or S'Length. Note that this warning can also be suppressed
+with a literal or S’Length. Note that this warning can also be suppressed
in a particular case by adding an assertion that the lower bound is 1,
as shown in the following example:
@@ -12843,7 +12865,7 @@ pragma Assertion_Policy
@end example
The pragmas @code{Assert} and @code{Debug} normally have no effect and
-are ignored. This switch, where @code{a} stands for 'assert', causes
+are ignored. This switch, where @code{a} stands for ‘assert’, causes
pragmas @code{Assert} and @code{Debug} to be activated. This switch also
causes preconditions, postconditions, subtype predicates, and
type invariants to be activated.
@@ -12885,7 +12907,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{e7}@anchor{gnat_ugn/building_executable_programs_with_gnat id17}@anchor{f3}
+@anchor{gnat_ugn/building_executable_programs_with_gnat id17}@anchor{f3}@anchor{gnat_ugn/building_executable_programs_with_gnat validity-checking}@anchor{e7}
@subsection Validity Checking
@@ -13187,7 +13209,7 @@ enforce specified style rules. A limited set of style rules has been used
in writing the GNAT sources themselves. This switch allows user programs
to activate all or some of these checks. If the source program fails a
specified style check, an appropriate message is given, preceded by
-the character sequence '(style)'. This message does not prevent
+the character sequence ‘(style)’. This message does not prevent
successful compilation (unless the @code{-gnatwe} switch is used).
Note that this is by no means intended to be a general facility for
@@ -13215,8 +13237,25 @@ If a digit from 1-9 appears
in the string after @code{-gnaty}
then proper indentation is checked, with the digit indicating the
indentation level required. A value of zero turns off this style check.
-The general style of required indentation is as specified by
-the examples in the Ada Reference Manual. Full line comments must be
+The rule checks that the following constructs start on a column that is
+a multiple of the alignment level:
+
+
+@itemize *
+
+@item
+beginnings of declarations (except record component declarations)
+and statements;
+
+@item
+beginnings of the structural components of compound statements;
+
+@item
+@code{end} keyword that completes the declaration of a program unit declaration
+or body or that completes a compound statement.
+@end itemize
+
+Full line comments must be
aligned with the @code{--} starting on a column that is a multiple of
the alignment level, or they may be aligned the same way as the following
non-blank line (this is useful when full line comments appear in the middle
@@ -13708,7 +13747,7 @@ with declarations.
@emph{Check separate specs.}
-Separate declarations ('specs') are required for subprograms (a
+Separate declarations (‘specs’) are required for subprograms (a
body is not allowed to serve as its own declaration). The only
exception is that parameterless library level procedures are
not required to have a separate declaration. This exception covers
@@ -13884,7 +13923,7 @@ a requirement for no following space.
If any of these style rules is violated, a message is generated giving
details on the violation. The initial characters of such messages are
-always '@cite{(style)}'. Note that these messages are treated as warning
+always ‘@cite{(style)}’. Note that these messages are treated as warning
messages, so they normally do not prevent the generation of an object
file. The @code{-gnatwe} switch can be used to treat warning messages,
including style messages, as fatal errors.
@@ -13897,7 +13936,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{ea}@anchor{gnat_ugn/building_executable_programs_with_gnat id19}@anchor{f5}
+@anchor{gnat_ugn/building_executable_programs_with_gnat id19}@anchor{f5}@anchor{gnat_ugn/building_executable_programs_with_gnat run-time-checks}@anchor{ea}
@subsection Run-Time Checks
@@ -13945,7 +13984,7 @@ required, to omit the checking code. If the run-time cost of the
checking code is zero or near-zero, the compiler will generate it even
if checks are suppressed. In particular, if the compiler can prove
that a certain check will necessarily fail, it will generate code to
-do an unconditional 'raise', even if checks are suppressed. The
+do an unconditional ‘raise’, even if checks are suppressed. The
compiler warns in this case. Another case in which checks may not be
eliminated is when they are embedded in certain run-time routines such
as math library routines.
@@ -14011,8 +14050,8 @@ This switch cancels the effect of a previous @code{gnatp} switch.
This switch controls the mode used for computing intermediate
arithmetic integer operations, and also enables overflow checking.
For a full description of overflow mode and checking control, see
-the 'Overflow Check Handling in GNAT' appendix in this
-User's Guide.
+the ‘Overflow Check Handling in GNAT’ appendix in this
+User’s Guide.
Overflow checks are always enabled by this switch. The argument
controls the mode, using the codes
@@ -14129,7 +14168,7 @@ the program source.
@item @code{-gnats}
-The @code{s} stands for 'syntax'.
+The @code{s} stands for ‘syntax’.
Run GNAT in syntax checking only mode. For
example, the command
@@ -14186,7 +14225,7 @@ together. This is primarily used by the @code{gnatchop} utility
@item @code{-gnatc}
-The @code{c} stands for 'check'.
+The @code{c} stands for ‘check’.
Causes the compiler to operate in semantic check mode,
with full checking for all illegalities specified in the
Ada Reference Manual, but without generation of any object code
@@ -14338,6 +14377,19 @@ may generally be compiled using this switch (see the description of the
for further information).
@end table
+@geindex -gnat2022 (gcc)
+
+@geindex Ada 2022 mode
+
+
+@table @asis
+
+@item @code{-gnat2022} (Ada 2022 mode)
+
+This switch directs the compiler to implement the Ada 2022 version of the
+language.
+@end table
+
@geindex -gnatX (gcc)
@geindex Ada language extensions
@@ -14350,13 +14402,13 @@ for further information).
@item @code{-gnatX} (Enable GNAT Extensions)
This switch directs the compiler to implement the latest version of the
-language (currently Ada 2012) and also to enable certain GNAT implementation
+language (currently Ada 2022) and also to enable certain GNAT implementation
extensions that are not part of any Ada standard. For a full list of these
-extensions, see the GNAT reference manual.
+extensions, see the GNAT reference manual, @code{Pragma Extensions_Allowed}.
@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{fb}@anchor{gnat_ugn/building_executable_programs_with_gnat character-set-control}@anchor{31}
+@anchor{gnat_ugn/building_executable_programs_with_gnat character-set-control}@anchor{31}@anchor{gnat_ugn/building_executable_programs_with_gnat id23}@anchor{fb}
@subsection Character Set Control
@@ -14539,7 +14591,7 @@ 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
-with'ed directly or indirectly will be scanned using the specified
+with’ed directly or indirectly will be scanned using the specified
representation scheme, and so if one of the non-brackets scheme is
used, it must be used consistently throughout the program. However,
since brackets encoding is always recognized, it may be conveniently
@@ -14594,7 +14646,7 @@ This is a common mode for many programs with foreign language comments.
@item @code{-gnatk@emph{n}}
-Activates file name 'krunching'. @code{n}, a decimal integer in the range
+Activates file name ‘krunching’. @code{n}, a decimal integer in the range
1-999, indicates the maximum allowable length of a file name (not
including the @code{.ads} or @code{.adb} extension). The default is not
to enable file name krunching.
@@ -14603,7 +14655,7 @@ 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{fe}@anchor{gnat_ugn/building_executable_programs_with_gnat id25}@anchor{ff}
+@anchor{gnat_ugn/building_executable_programs_with_gnat id25}@anchor{fe}@anchor{gnat_ugn/building_executable_programs_with_gnat subprogram-inlining-control}@anchor{ff}
@subsection Subprogram Inlining Control
@@ -14614,7 +14666,7 @@ For the source file naming rules, @ref{3b,,File Naming Rules}.
@item @code{-gnatn[12]}
-The @code{n} here is intended to suggest the first syllable of the word 'inline'.
+The @code{n} here is intended to suggest the first syllable of the word ‘inline’.
GNAT recognizes and processes @code{Inline} pragmas. However, for inlining to
actually occur, optimization must be enabled and, by default, inlining of
subprograms across units is not performed. If you want to additionally
@@ -14649,8 +14701,7 @@ see @ref{100,,Inlining of Subprograms}.
This switch activates front-end inlining which also
generates additional dependencies.
-When using a gcc-based back end (in practice this means using any version
-of GNAT other than the JGNAT, .NET or GNAAMP versions), then the use of
+When using a gcc-based back end, then the use of
@code{-gnatN} is deprecated, and the use of @code{-gnatn} is preferred.
Historically front end inlining was more extensive than the gcc back end
inlining, but that is no longer the case.
@@ -14969,7 +15020,7 @@ is set).
For @code{-gnatR3}, symbolic expressions for values that are computed
at run time for records are included. These symbolic expressions have
a mostly obvious format with #n being used to represent the value of the
-n'th discriminant. See source files @code{repinfo.ads/adb} in the
+n’th discriminant. See source files @code{repinfo.ads/adb} in the
GNAT sources for full details on the format of @code{-gnatR3} output.
For @code{-gnatR4}, information for relevant compiler-generated types
@@ -15046,10 +15097,10 @@ emitted in the debug information.
Historically, old debug formats like stabs were not powerful enough to
express some Ada types (for instance, variant records or fixed-point types).
To work around this, GNAT introduced proprietary encodings that embed the
-missing information ("GNAT encodings").
+missing information (“GNAT encodings”).
Recent versions of the DWARF debug information format are now able to
-correctly describe most of these Ada constructs ("standard DWARF"). As
+correctly describe most of these Ada constructs (“standard DWARF”). As
third-party tools started to use this format, GNAT has been enhanced to
generate it. However, most tools (including GDB) are still relying on GNAT
encodings.
@@ -15076,7 +15127,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{105}@anchor{gnat_ugn/building_executable_programs_with_gnat exception-handling-control}@anchor{106}
+@anchor{gnat_ugn/building_executable_programs_with_gnat exception-handling-control}@anchor{105}@anchor{gnat_ugn/building_executable_programs_with_gnat id28}@anchor{106}
@subsection Exception Handling Control
@@ -15088,7 +15139,7 @@ need for tracing stack frames. This method provides very fast
exception propagation, but introduces significant overhead for
the use of exception handlers, even if no exception is raised.
-The other approach is called 'zero cost' exception handling.
+The other approach is called ‘zero cost’ exception handling.
With this method, the compiler builds static tables to describe
the exception ranges. No dynamic code is required when entering
a frame containing an exception handler. When an exception is
@@ -15099,7 +15150,7 @@ the propagation of exceptions, but there is no overhead for
exception handlers if no exception is raised. Note that in this
mode and in the context of mixed Ada and C/C++ programming,
to propagate an exception through a C/C++ code, the C/C++ code
-must be compiled with the @code{-funwind-tables} GCC's
+must be compiled with the @code{-funwind-tables} GCC’s
option.
The following switches may be used to control which of the
@@ -15144,7 +15195,7 @@ 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{cd,,Switches for gnatmake}) will ensure the required consistency
+(@ref{ce,,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
@@ -15229,7 +15280,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{10a}@anchor{gnat_ugn/building_executable_programs_with_gnat id31}@anchor{10b}
+@anchor{gnat_ugn/building_executable_programs_with_gnat id31}@anchor{10a}@anchor{gnat_ugn/building_executable_programs_with_gnat linker-switches}@anchor{10b}
@section Linker Switches
@@ -15300,7 +15351,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{10d}@anchor{gnat_ugn/building_executable_programs_with_gnat id33}@anchor{10e}
+@anchor{gnat_ugn/building_executable_programs_with_gnat id33}@anchor{10d}@anchor{gnat_ugn/building_executable_programs_with_gnat running-gnatbind}@anchor{10e}
@subsection Running @code{gnatbind}
@@ -15543,7 +15594,7 @@ Output complete list of elaboration-order dependencies.
@item @code{-Ea}
Store tracebacks in exception occurrences when the target supports it.
-The "a" is for "address"; tracebacks will contain hexadecimal addresses,
+The “a” is for “address”; tracebacks will contain hexadecimal addresses,
unless symbolic tracebacks are enabled.
See also the packages @code{GNAT.Traceback} and
@@ -15560,7 +15611,7 @@ Note that on x86 ports, you must not use @code{-fomit-frame-pointer}
@item @code{-Es}
Store tracebacks in exception occurrences when the target supports it.
-The "s" is for "symbolic"; symbolic tracebacks are enabled.
+The “s” is for “symbolic”; symbolic tracebacks are enabled.
@end table
@geindex -E (gnatbind)
@@ -15708,10 +15759,10 @@ limitations:
@itemize *
@item
-Starting the program's execution in the debugger will cause it to
+Starting the program’s execution in the debugger will cause it to
stop at the start of the @code{main} function instead of the main subprogram.
This can be worked around by manually inserting a breakpoint on that
-subprogram and resuming the program's execution until reaching that breakpoint.
+subprogram and resuming the program’s execution until reaching that breakpoint.
@item
Programs using GNAT.Compiler_Version will not link.
@@ -15740,7 +15791,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{cd,,Switches for gnatmake}).
+equivalent @code{gnatmake} flag (@ref{ce,,Switches for gnatmake}).
@geindex -o (gnatbind)
@@ -15892,7 +15943,7 @@ scheduling policy to @code{FIFO_Within_Priorities}.
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
+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{113,,Dynamic Stack Usage Analysis} for details.)
@@ -16028,7 +16079,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{116}@anchor{gnat_ugn/building_executable_programs_with_gnat binder-error-message-control}@anchor{117}
+@anchor{gnat_ugn/building_executable_programs_with_gnat binder-error-message-control}@anchor{116}@anchor{gnat_ugn/building_executable_programs_with_gnat id36}@anchor{117}
@subsubsection Binder Error Message Control
@@ -16138,7 +16189,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{118}@anchor{gnat_ugn/building_executable_programs_with_gnat elaboration-control}@anchor{111}
+@anchor{gnat_ugn/building_executable_programs_with_gnat elaboration-control}@anchor{111}@anchor{gnat_ugn/building_executable_programs_with_gnat id37}@anchor{118}
@subsubsection Elaboration Control
@@ -16154,10 +16205,10 @@ order. For further details see @ref{f,,Elaboration Order Handling in GNAT}.
Force elaboration order.
-@code{elab-order} should be the name of a "forced elaboration order file", that
+@code{elab-order} should be the name of a “forced elaboration order file”, that
is, a text file containing library item names, one per line. A name of the
-form "some.unit%s" or "some.unit (spec)" denotes the spec of Some.Unit. A
-name of the form "some.unit%b" or "some.unit (body)" denotes the body of
+form “some.unit%s” or “some.unit (spec)” denotes the spec of Some.Unit. A
+name of the form “some.unit%b” or “some.unit (body)” denotes the body of
Some.Unit. Each pair of lines is taken to mean that there is an elaboration
dependence of the second line on the first. For example, if the file
contains:
@@ -16178,11 +16229,11 @@ forcing the body of This to be elaborated before the spec of That.
The given order must be consistent with Ada rules, or else @code{gnatbind} will
give elaboration cycle errors. For example, if you say x (body) should be
elaborated before x (spec), there will be a cycle, because Ada rules require
-x (spec) to be elaborated before x (body); you can't have the spec and body
+x (spec) to be elaborated before x (body); you can’t have the spec and body
both elaborated before each other.
-If you later add "with That;" to the body of This, there will be a cycle, in
-which case you should erase either "this (body)" or "that (spec)" from the
+If you later add “with That;” to the body of This, there will be a cycle, in
+which case you should erase either “this (body)” or “that (spec)” from the
above forced elaboration order file.
Blank lines and Ada-style comments are ignored. Unit names that do not exist
@@ -16223,7 +16274,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{119}@anchor{gnat_ugn/building_executable_programs_with_gnat id38}@anchor{11a}
+@anchor{gnat_ugn/building_executable_programs_with_gnat id38}@anchor{119}@anchor{gnat_ugn/building_executable_programs_with_gnat output-control}@anchor{11a}
@subsubsection Output Control
@@ -16308,7 +16359,7 @@ be used to improve code generation in some cases.
@subsubsection Dynamic Allocation Control
-The heap control switches -- @code{-H32} and @code{-H64} --
+The heap control switches – @code{-H32} and @code{-H64} –
determine whether dynamic allocation uses 32-bit or 64-bit memory.
They only affect compiler-generated allocations via @code{__gnat_malloc};
explicit calls to @code{malloc} and related functions from the C
@@ -16457,7 +16508,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{11f}@anchor{gnat_ugn/building_executable_programs_with_gnat command-line-access}@anchor{120}
+@anchor{gnat_ugn/building_executable_programs_with_gnat command-line-access}@anchor{11f}@anchor{gnat_ugn/building_executable_programs_with_gnat id42}@anchor{120}
@subsection Command-Line Access
@@ -16487,7 +16538,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{76}@anchor{gnat_ugn/building_executable_programs_with_gnat id43}@anchor{121}
+@anchor{gnat_ugn/building_executable_programs_with_gnat id43}@anchor{121}@anchor{gnat_ugn/building_executable_programs_with_gnat search-paths-for-gnatbind}@anchor{76}
@subsection Search Paths for @code{gnatbind}
@@ -16544,7 +16595,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{71,,Installing a library}
+specified. See @ref{72,,Installing a library}
@end itemize
@geindex -I (gnatbind)
@@ -16591,7 +16642,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{122}@anchor{gnat_ugn/building_executable_programs_with_gnat examples-of-gnatbind-usage}@anchor{123}
+@anchor{gnat_ugn/building_executable_programs_with_gnat examples-of-gnatbind-usage}@anchor{122}@anchor{gnat_ugn/building_executable_programs_with_gnat id44}@anchor{123}
@subsection Examples of @code{gnatbind} Usage
@@ -16844,7 +16895,7 @@ for further details. You would normally use the @code{-b} or
@item @code{-M}
When linking an executable, create a map file. The name of the map file
-has the same name as the executable with extension ".map".
+has the same name as the executable with extension “.map”.
@end table
@geindex -M= (gnatlink)
@@ -16905,7 +16956,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{70}@anchor{gnat_ugn/building_executable_programs_with_gnat id48}@anchor{12b}
+@anchor{gnat_ugn/building_executable_programs_with_gnat id48}@anchor{12b}@anchor{gnat_ugn/building_executable_programs_with_gnat using-the-gnu-make-utility}@anchor{70}
@section Using the GNU @code{make} Utility
@@ -16930,7 +16981,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{12c}@anchor{gnat_ugn/building_executable_programs_with_gnat id49}@anchor{12d}
+@anchor{gnat_ugn/building_executable_programs_with_gnat id49}@anchor{12c}@anchor{gnat_ugn/building_executable_programs_with_gnat using-gnatmake-in-a-makefile}@anchor{12d}
@subsection Using gnatmake in a Makefile
@@ -17029,7 +17080,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{12f}@anchor{gnat_ugn/building_executable_programs_with_gnat automatically-creating-a-list-of-directories}@anchor{12e}
+@anchor{gnat_ugn/building_executable_programs_with_gnat automatically-creating-a-list-of-directories}@anchor{12e}@anchor{gnat_ugn/building_executable_programs_with_gnat id50}@anchor{12f}
@subsection Automatically Creating a List of Directories
@@ -17102,7 +17153,7 @@ 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{130}@anchor{gnat_ugn/building_executable_programs_with_gnat generating-the-command-line-switches}@anchor{131}
+@anchor{gnat_ugn/building_executable_programs_with_gnat generating-the-command-line-switches}@anchor{130}@anchor{gnat_ugn/building_executable_programs_with_gnat id51}@anchor{131}
@subsection Generating the Command Line Switches
@@ -17128,7 +17179,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{132}@anchor{gnat_ugn/building_executable_programs_with_gnat id52}@anchor{133}
+@anchor{gnat_ugn/building_executable_programs_with_gnat id52}@anchor{132}@anchor{gnat_ugn/building_executable_programs_with_gnat overcoming-command-line-length-limits}@anchor{133}
@subsection Overcoming Command Line Length Limits
@@ -17248,7 +17299,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{139}@anchor{gnat_ugn/gnat_utility_programs id3}@anchor{13a}
+@anchor{gnat_ugn/gnat_utility_programs id3}@anchor{139}@anchor{gnat_ugn/gnat_utility_programs running-gnatclean}@anchor{13a}
@subsection Running @code{gnatclean}
@@ -17474,7 +17525,7 @@ where @code{gnatclean} was invoked.
@end table
@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}
+@anchor{gnat_ugn/gnat_utility_programs id5}@anchor{13d}@anchor{gnat_ugn/gnat_utility_programs the-gnat-library-browser-gnatls}@anchor{137}
@section The GNAT Library Browser @code{gnatls}
@@ -17690,7 +17741,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{cd,,Switches for gnatmake}).
+flags (@ref{ce,,Switches for gnatmake}).
@end table
@geindex -aP (gnatls)
@@ -17711,7 +17762,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{cd,,Switches for gnatmake}).
+equivalent @code{gnatmake} flag (@ref{ce,,Switches for gnatmake}).
@end table
@geindex -v (gnatls)
@@ -17757,7 +17808,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{142}@anchor{gnat_ugn/gnat_utility_programs example-of-gnatls-usage}@anchor{143}
+@anchor{gnat_ugn/gnat_utility_programs example-of-gnatls-usage}@anchor{142}@anchor{gnat_ugn/gnat_utility_programs id8}@anchor{143}
@subsection Example of @code{gnatls} Usage
@@ -17846,7 +17897,7 @@ instr.ads
@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{144}@anchor{gnat_ugn/gnat_and_program_execution id1}@anchor{145}
+@anchor{gnat_ugn/gnat_and_program_execution doc}@anchor{144}@anchor{gnat_ugn/gnat_and_program_execution gnat-and-program-execution}@anchor{c}@anchor{gnat_ugn/gnat_and_program_execution id1}@anchor{145}
@chapter GNAT and Program Execution
@@ -17943,7 +17994,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{14e}@anchor{gnat_ugn/gnat_and_program_execution id3}@anchor{14f}
+@anchor{gnat_ugn/gnat_and_program_execution id3}@anchor{14e}@anchor{gnat_ugn/gnat_and_program_execution the-gnat-debugger-gdb}@anchor{14f}
@subsection The GNAT Debugger GDB
@@ -18027,7 +18078,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{152}@anchor{gnat_ugn/gnat_and_program_execution id5}@anchor{153}
+@anchor{gnat_ugn/gnat_and_program_execution id5}@anchor{152}@anchor{gnat_ugn/gnat_and_program_execution introduction-to-gdb-commands}@anchor{153}
@subsection Introduction to GDB Commands
@@ -18268,12 +18319,12 @@ Thus, for brevity, the debugger acts as if there were
implicit @code{with} and @code{use} clauses in effect for all user-written
packages, thus making it unnecessary to fully qualify most names with
their packages, regardless of context. Where this causes ambiguity,
-@code{GDB} asks the user's intent.
+@code{GDB} asks the user’s intent.
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{156}@anchor{gnat_ugn/gnat_and_program_execution calling-user-defined-subprograms}@anchor{157}
+@anchor{gnat_ugn/gnat_and_program_execution calling-user-defined-subprograms}@anchor{156}@anchor{gnat_ugn/gnat_and_program_execution id7}@anchor{157}
@subsection Calling User-Defined Subprograms
@@ -18332,7 +18383,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{158}@anchor{gnat_ugn/gnat_and_program_execution id8}@anchor{159}
+@anchor{gnat_ugn/gnat_and_program_execution id8}@anchor{158}@anchor{gnat_ugn/gnat_and_program_execution using-the-next-command-in-a-function}@anchor{159}
@subsection Using the @emph{next} Command in a Function
@@ -18340,7 +18391,7 @@ When you use the @code{next} command in a function, the current source
location will advance to the next statement as usual. A special case
arises in the case of a @code{return} statement.
-Part of the code for a return statement is the 'epilogue' of the function.
+Part of the code for a return statement is the ‘epilogue’ of the function.
This is the code that returns to the caller. There is only one copy of
this epilogue code, and it is typically associated with the last return
statement in the function if there is more than one return. In some
@@ -18355,7 +18406,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{15a}@anchor{gnat_ugn/gnat_and_program_execution id9}@anchor{15b}
+@anchor{gnat_ugn/gnat_and_program_execution id9}@anchor{15a}@anchor{gnat_ugn/gnat_and_program_execution stopping-when-ada-exceptions-are-raised}@anchor{15b}
@subsection Stopping When Ada Exceptions Are Raised
@@ -18450,7 +18501,7 @@ to refer to tasks in the following commands.
@itemize *
@item
-@code{break`@w{`}*linespec* `@w{`}task} @emph{taskid}, @code{break} @emph{linespec} @code{task} @emph{taskid} @code{if} ...
+@code{break`@w{`}*linespec* `@w{`}task} @emph{taskid}, @code{break} @emph{linespec} @code{task} @emph{taskid} @code{if} …
@quotation
@@ -18558,7 +18609,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{160}@anchor{gnat_ugn/gnat_and_program_execution id12}@anchor{161}
+@anchor{gnat_ugn/gnat_and_program_execution id12}@anchor{160}@anchor{gnat_ugn/gnat_and_program_execution remote-debugging-with-gdbserver}@anchor{161}
@subsection Remote Debugging with gdbserver
@@ -18671,7 +18722,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{14e,,The GNAT Debugger GDB} for caveats). The
+would on a C program (but @ref{14f,,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
@@ -18680,7 +18731,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{164}@anchor{gnat_ugn/gnat_and_program_execution id14}@anchor{165}
+@anchor{gnat_ugn/gnat_and_program_execution id14}@anchor{164}@anchor{gnat_ugn/gnat_and_program_execution naming-conventions-for-gnat-source-files}@anchor{165}
@subsection Naming Conventions for GNAT Source Files
@@ -18761,7 +18812,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{166}@anchor{gnat_ugn/gnat_and_program_execution getting-internal-debugging-information}@anchor{167}
+@anchor{gnat_ugn/gnat_and_program_execution getting-internal-debugging-information}@anchor{166}@anchor{gnat_ugn/gnat_and_program_execution id15}@anchor{167}
@subsection Getting Internal Debugging Information
@@ -18789,7 +18840,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{168}@anchor{gnat_ugn/gnat_and_program_execution id16}@anchor{169}
+@anchor{gnat_ugn/gnat_and_program_execution id16}@anchor{168}@anchor{gnat_ugn/gnat_and_program_execution stack-traceback}@anchor{169}
@subsection Stack Traceback
@@ -18818,7 +18869,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{16a}@anchor{gnat_ugn/gnat_and_program_execution id17}@anchor{16b}
+@anchor{gnat_ugn/gnat_and_program_execution id17}@anchor{16a}@anchor{gnat_ugn/gnat_and_program_execution non-symbolic-traceback}@anchor{16b}
@subsubsection Non-Symbolic Traceback
@@ -18945,7 +18996,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{10d,,Running gnatbind}. The remaining entries are assorted runtime routines,
+@ref{10e,,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
@@ -19097,7 +19148,7 @@ In STB.P1 : 16#0040_F1E4# 16#0040_14F2# 16#0040_170B# 16#0040_171C#
You can then get further information by invoking the @code{addr2line}
tool as described earlier (note that the hexadecimal addresses
-need to be specified in C format, with a leading '0x').
+need to be specified in C format, with a leading ‘0x’).
@geindex traceback
@geindex symbolic
@@ -19235,7 +19286,7 @@ program.
@subsection Pretty-Printers for the GNAT runtime
-As discussed in @cite{Calling User-Defined Subprograms}, GDB's
+As discussed in @cite{Calling User-Defined Subprograms}, GDB’s
@code{print} command only knows about the physical layout of program data
structures and therefore normally displays only low-level dumps, which
are often hard to understand.
@@ -19300,7 +19351,7 @@ python import gnatdbg; gnatdbg.setup()
@end example
@end quotation
-Once this is done, GDB's @code{print} command will automatically use
+Once this is done, GDB’s @code{print} command will automatically use
these pretty-printers when appropriate. Using the previous example:
@quotation
@@ -19317,8 +19368,8 @@ $1 = pp.int_to_nat.map of length 3 = @{
Pretty-printers are invoked each time GDB tries to display a value,
including when displaying the arguments of a called subprogram (in
-GDB's @code{backtrace} command) or when printing the value returned by a
-function (in GDB's @code{finish} command).
+GDB’s @code{backtrace} command) or when printing the value returned by a
+function (in GDB’s @code{finish} command).
To display a value without involving pretty-printers, @code{print} can be
invoked with its @code{/r} option:
@@ -19338,7 +19389,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{147}@anchor{gnat_ugn/gnat_and_program_execution id20}@anchor{170}
+@anchor{gnat_ugn/gnat_and_program_execution id20}@anchor{170}@anchor{gnat_ugn/gnat_and_program_execution profiling}@anchor{147}
@section Profiling
@@ -19359,7 +19410,7 @@ This section describes how to use the @code{gprof} profiler tool on Ada programs
This section is not meant to be an exhaustive documentation of @code{gprof}.
-Full documentation for it can be found in the @cite{GNU Profiler User's Guide}
+Full documentation for it can be found in the @cite{GNU Profiler User’s Guide}
documentation that is part of this GNAT distribution.
Profiling a program helps determine the parts of a program that are executed
@@ -19408,7 +19459,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{173}@anchor{gnat_ugn/gnat_and_program_execution compilation-for-profiling}@anchor{174}
+@anchor{gnat_ugn/gnat_and_program_execution compilation-for-profiling}@anchor{173}@anchor{gnat_ugn/gnat_and_program_execution id22}@anchor{174}
@subsubsection Compilation for profiling
@@ -19436,7 +19487,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{175}@anchor{gnat_ugn/gnat_and_program_execution id23}@anchor{176}
+@anchor{gnat_ugn/gnat_and_program_execution id23}@anchor{175}@anchor{gnat_ugn/gnat_and_program_execution program-execution}@anchor{176}
@subsubsection Program execution
@@ -19451,7 +19502,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{177}@anchor{gnat_ugn/gnat_and_program_execution id24}@anchor{178}
+@anchor{gnat_ugn/gnat_and_program_execution id24}@anchor{177}@anchor{gnat_ugn/gnat_and_program_execution running-gprof}@anchor{178}
@subsubsection Running gprof
@@ -19484,7 +19535,7 @@ $ gprof [switches] [executable [data-file]]
@code{gprof} supports numerous switches. The order of these
switch does not matter. The full list of options can be found in
-the GNU Profiler User's Guide documentation that comes with this documentation.
+the GNU Profiler User’s Guide documentation that comes with this documentation.
The following is the subset of those switches that is most relevant:
@@ -19513,7 +19564,7 @@ compiler, in particular Ada symbols generated by GNAT can be demangled using
The @code{-e @emph{function}} option tells @code{gprof} not to print
information about the function @code{function_name} (and its
-children...) in the call graph. The function will still be listed
+children…) in the call graph. The function will still be listed
as a child of any functions that call it, but its index number will be
shown as @code{[not printed]}. More than one @code{-e} option may be
given; only one @code{function_name} may be indicated with each @code{-e}
@@ -19543,7 +19594,7 @@ the call graph. More than one @code{-E} option may be given; only one
The @code{-f @emph{function}} option causes @code{gprof} to limit the
call graph to the function @code{function_name} and its children (and
-their children...). More than one @code{-f} option may be given;
+their children…). More than one @code{-f} option may be given;
only one @code{function_name} may be indicated with each @code{-f}
option.
@end table
@@ -19557,7 +19608,7 @@ option.
The @code{-F @emph{function}} option works like the @code{-f} option, but
only time spent in the function and its children (and their
-children...) will be used to determine total-time and
+children…) will be used to determine total-time and
percentages-of-time for the call graph. More than one @code{-F} option
may be given; only one @code{function_name} may be indicated with each
@code{-F} option. The @code{-F} option overrides the @code{-E} option.
@@ -19569,8 +19620,8 @@ may be given; only one @code{function_name} may be indicated with each
The results of the profiling analysis are represented by two arrays: the
-'flat profile' and the 'call graph'. Full documentation of those outputs
-can be found in the GNU Profiler User's Guide.
+‘flat profile’ and the ‘call graph’. Full documentation of those outputs
+can be found in the GNU Profiler User’s Guide.
The flat profile shows the time spent in each function of the program, and how
many time it has been called. This allows you to locate easily the most
@@ -19581,7 +19632,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{17b}@anchor{gnat_ugn/gnat_and_program_execution id26}@anchor{148}
+@anchor{gnat_ugn/gnat_and_program_execution id26}@anchor{148}@anchor{gnat_ugn/gnat_and_program_execution improving-performance}@anchor{17b}
@section Improving Performance
@@ -19602,7 +19653,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{17c}@anchor{gnat_ugn/gnat_and_program_execution id27}@anchor{17d}
+@anchor{gnat_ugn/gnat_and_program_execution id27}@anchor{17c}@anchor{gnat_ugn/gnat_and_program_execution performance-considerations}@anchor{17d}
@subsection Performance Considerations
@@ -19663,7 +19714,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{17e}@anchor{gnat_ugn/gnat_and_program_execution controlling-run-time-checks}@anchor{17f}
+@anchor{gnat_ugn/gnat_and_program_execution controlling-run-time-checks}@anchor{17e}@anchor{gnat_ugn/gnat_and_program_execution id28}@anchor{17f}
@subsubsection Controlling Run-Time Checks
@@ -19757,7 +19808,7 @@ possibility of an immediate abort at any point.
@geindex -O (gcc)
Without any optimization option,
-the compiler's goal is to reduce the cost of
+the compiler’s goal is to reduce the cost of
compilation and to make debugging produce the expected results.
Statements are independent: if you stop the program with a breakpoint between
statements, you can then assign a new value to any variable or change
@@ -19794,7 +19845,7 @@ generates unoptimized code but has
the fastest compilation time.
Note that many other compilers do substantial optimization even
-if 'no optimization' is specified. With gcc, it is very unusual
+if ‘no optimization’ is specified. With gcc, it is very unusual
to use @code{-O0} for production if execution time is of any concern,
since @code{-O0} means (almost) no optimization. This difference
between gcc and other compilers should be kept in mind when
@@ -19912,7 +19963,7 @@ These are the most common cases:
@itemize *
@item
-@emph{The 'hopping Program Counter':} Repeated @code{step} or @code{next}
+@emph{The ‘hopping Program Counter’:} Repeated @code{step} or @code{next}
commands show
the PC bouncing back and forth in the code. This may result from any of
the following optimizations:
@@ -19941,7 +19992,7 @@ expected side-effects.
@end itemize
@item
-@emph{The 'big leap':} More commonly known as @emph{cross-jumping}, in which
+@emph{The ‘big leap’:} More commonly known as @emph{cross-jumping}, in which
two identical pieces of code are merged and the program counter suddenly
jumps to a statement that is not supposed to be executed, simply because
it (and the code following) translates to the same thing as the code
@@ -19950,7 +20001,7 @@ sequences that end in a jump, such as a @code{goto}, a @code{return}, or
a @code{break} in a C @code{switch} statement.
@item
-@emph{The 'roving variable':} The symptom is an unexpected value in a variable.
+@emph{The ‘roving variable’:} The symptom is an unexpected value in a variable.
There are various reasons for this effect:
@@ -19958,7 +20009,7 @@ There are various reasons for this effect:
@item
In a subprogram prologue, a parameter may not yet have been moved to its
-'home'.
+‘home’.
@item
A variable may be dead, and its register re-used. This is
@@ -19987,7 +20038,7 @@ values (one must apply the procedure recursively to those
other values); or re-running the code and stopping a little earlier
(perhaps before the call) and stepping to better see how the variable obtained
the value in question; or continuing to step @emph{from} the point of the
-strange value to see if code motion had simply moved the variable's
+strange value to see if code motion had simply moved the variable’s
assignments later.
@end itemize
@@ -20203,7 +20254,7 @@ by default at this level, using @code{-O3} directly is recommended.
You also need to make sure that the target architecture features a supported
SIMD instruction set. For example, for the x86 architecture, you should at
-least specify @code{-msse2} to get significant vectorization (but you don't
+least specify @code{-msse2} to get significant vectorization (but you don’t
need to specify it for x86-64 as it is part of the base 64-bit architecture).
Similarly, for the PowerPC architecture, you should specify @code{-maltivec}.
@@ -20340,7 +20391,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{18a}@anchor{gnat_ugn/gnat_and_program_execution id35}@anchor{18b}
+@anchor{gnat_ugn/gnat_and_program_execution id35}@anchor{18a}@anchor{gnat_ugn/gnat_and_program_execution other-optimization-switches}@anchor{18b}
@subsubsection Other Optimization Switches
@@ -20357,7 +20408,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{e4}@anchor{gnat_ugn/gnat_and_program_execution id36}@anchor{18c}
+@anchor{gnat_ugn/gnat_and_program_execution id36}@anchor{18c}@anchor{gnat_ugn/gnat_and_program_execution optimization-and-strict-aliasing}@anchor{e4}
@subsubsection Optimization and Strict Aliasing
@@ -20400,7 +20451,7 @@ In this example, since the variable @code{Int1V} can only access objects
of type @code{Int1}, and @code{Int2V} can only access objects of type
@code{Int2}, there is no possibility that the assignment to
@code{Int2V.all} affects the value of @code{Int1V.all}. This means that
-the compiler optimizer can "know" that the value @code{Int1V.all} is constant
+the compiler optimizer can “know” that the value @code{Int1V.all} is constant
for all iterations of the loop and avoid the extra memory reference
required to dereference it each time through the loop.
@@ -20454,7 +20505,7 @@ end;
@end quotation
This program prints out 0 in @code{-O0} or @code{-O1}
-mode, but it prints out 1 in @code{-O2} mode. That's
+mode, but it prints out 1 in @code{-O2} mode. That’s
because in strict aliasing mode, the compiler can and
does assume that the assignment to @code{v2.all} could not
affect the value of @code{v1.all}, since different types
@@ -20464,7 +20515,7 @@ This behavior is not a case of non-conformance with the standard, since
the Ada RM specifies that an unchecked conversion where the resulting
bit pattern is not a correct value of the target type can result in an
abnormal value and attempting to reference an abnormal value makes the
-execution of a program erroneous. That's the case here since the result
+execution of a program erroneous. That’s the case here since the result
does not point to an object of type @code{int2}. This means that the
effect is entirely unpredictable.
@@ -20487,7 +20538,7 @@ p2.adb:5:07: warning: or use "pragma No_Strict_Aliasing (a2);"
@end quotation
Unfortunately the problem is recognized when compiling the body of
-package @code{p2}, but the actual "bad" code is generated while
+package @code{p2}, but the actual “bad” code is generated while
compiling the body of @code{m} and this latter compilation does not see
the suspicious @code{Unchecked_Conversion}.
@@ -20508,7 +20559,7 @@ the switch can be painful, so a more reasonable approach
is to compile the entire program with options @code{-O2}
and @code{-fno-strict-aliasing}. If the performance is
satisfactory with this combination of options, then the
-advantage is that the entire issue of possible "wrong"
+advantage is that the entire issue of possible “wrong”
optimization due to strict aliasing is avoided.
To avoid the use of compiler switches, the configuration
@@ -20546,7 +20597,7 @@ conversion to the unit in which the type is declared. In
this example, we would move the instantiation of
@code{Unchecked_Conversion} from the body of package
@code{p2} to the spec of package @code{p1}. Now the
-warning disappears. That's because any use of the
+warning disappears. That’s because any use of the
access type knows there is a suspicious unchecked
conversion, and the strict aliasing optimization
is automatically suppressed for the type.
@@ -20587,7 +20638,7 @@ application code where the time is increased by up to 5% by turning
this optimization off. If you have code that includes significant
usage of unchecked conversion, you might want to just stick with
@code{-O1} and avoid the entire issue. If you get adequate
-performance at this level of optimization level, that's probably
+performance at this level of optimization level, that’s probably
the safest approach. If tests show that you really need higher
levels of optimization, then you can experiment with @code{-O2}
and @code{-O2 -fno-strict-aliasing} to see how much effect this
@@ -20597,7 +20648,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{18d}@anchor{gnat_ugn/gnat_and_program_execution aliased-variables-and-optimization}@anchor{18e}
+@anchor{gnat_ugn/gnat_and_program_execution aliased-variables-and-optimization}@anchor{18d}@anchor{gnat_ugn/gnat_and_program_execution id37}@anchor{18e}
@subsubsection Aliased Variables and Optimization
@@ -20608,7 +20659,7 @@ use low level techniques to modify variables
that otherwise might be considered to be unassigned. For example,
a variable can be passed to a procedure by reference, which takes
the address of the parameter and uses the address to modify the
-variable's value, even though it is passed as an IN parameter.
+variable’s value, even though it is passed as an IN parameter.
Consider the following example:
@quotation
@@ -20648,10 +20699,10 @@ seems to work with no optimization to start failing at high
levels of optimzization.
What the compiler does for such cases is to assume that marking
-a variable as aliased indicates that some "funny business" may
+a variable as aliased indicates that some “funny business” may
be going on. The optimizer recognizes the aliased keyword and
inhibits optimizations that assume the value cannot be assigned.
-This means that the above example will in fact "work" reliably,
+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
@@ -20722,7 +20773,7 @@ Now the reference to RV must read the whole variable.
Actually one can imagine some compiler which figures
out that the whole copy is not required (because only
the B field is actually accessed), but GNAT
-certainly won't do that, and we don't know of any
+certainly won’t do that, and we don’t know of any
compiler that would not handle this right, and the
above code will in practice work portably across
all architectures (that permit the Atomic declaration).
@@ -20736,7 +20787,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{191}@anchor{gnat_ugn/gnat_and_program_execution id39}@anchor{192}
+@anchor{gnat_ugn/gnat_and_program_execution id39}@anchor{191}@anchor{gnat_ugn/gnat_and_program_execution passive-task-optimization}@anchor{192}
@subsubsection Passive Task Optimization
@@ -20760,7 +20811,7 @@ operations will be optimized, and furthermore this optimized
performance is fully portable.
Although it would theoretically be possible for GNAT to attempt to
-do this optimization, but it really doesn't make sense in the
+do this optimization, but it really doesn’t make sense in the
context of Ada 95, and none of the Ada 95 compilers implement
this optimization as far as we know. In particular GNAT never
attempts to perform this optimization.
@@ -20781,7 +20832,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{193}@anchor{gnat_ugn/gnat_and_program_execution id40}@anchor{194}
+@anchor{gnat_ugn/gnat_and_program_execution id40}@anchor{193}@anchor{gnat_ugn/gnat_and_program_execution text-io-suggestions}@anchor{194}
@subsection @code{Text_IO} Suggestions
@@ -20821,7 +20872,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{197}@anchor{gnat_ugn/gnat_and_program_execution about-unused-subprogram-data-elimination}@anchor{198}
+@anchor{gnat_ugn/gnat_and_program_execution about-unused-subprogram-data-elimination}@anchor{197}@anchor{gnat_ugn/gnat_and_program_execution id42}@anchor{198}
@subsubsection About unused subprogram/data elimination
@@ -20837,7 +20888,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{199}@anchor{gnat_ugn/gnat_and_program_execution compilation-options}@anchor{19a}
+@anchor{gnat_ugn/gnat_and_program_execution compilation-options}@anchor{199}@anchor{gnat_ugn/gnat_and_program_execution id43}@anchor{19a}
@subsubsection Compilation options
@@ -20962,7 +21013,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{19e}@anchor{gnat_ugn/gnat_and_program_execution background}@anchor{19f}
+@anchor{gnat_ugn/gnat_and_program_execution background}@anchor{19e}@anchor{gnat_ugn/gnat_and_program_execution id46}@anchor{19f}
@subsection Background
@@ -21039,7 +21090,7 @@ and then the application is moved to a compiler where the check is
performed on the intermediate result and an unexpected exception is
raised.
-Furthermore, when using Ada 2012's preconditions and other
+Furthermore, when using Ada 2012’s preconditions and other
assertion forms, another issue arises. Consider:
@quotation
@@ -21097,7 +21148,7 @@ mathematical versus run-time interpretation of the expressions in
assertions, GNAT provides comprehensive control over the handling
of intermediate overflow. GNAT can operate in three modes, and
furthemore, permits separate selection of operating modes for
-the expressions within assertions (here the term 'assertions'
+the expressions within assertions (here the term ‘assertions’
is used in the technical sense, which includes preconditions and so forth)
and for expressions appearing outside assertions.
@@ -21202,7 +21253,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{e9}@anchor{gnat_ugn/gnat_and_program_execution id48}@anchor{1a2}
+@anchor{gnat_ugn/gnat_and_program_execution id48}@anchor{1a2}@anchor{gnat_ugn/gnat_and_program_execution specifying-the-desired-mode}@anchor{e9}
@subsection Specifying the Desired Mode
@@ -21251,8 +21302,8 @@ pragma Overflow_Mode
@end quotation
specifies that general expressions outside assertions be evaluated
-in 'minimize intermediate overflows' mode, and expressions within
-assertions be evaluated in 'eliminate intermediate overflows' mode.
+in ‘minimize intermediate overflows’ mode, and expressions within
+assertions be evaluated in ‘eliminate intermediate overflows’ mode.
This is often a reasonable choice, avoiding excessive overhead
outside assertions, but assuring a high degree of portability
when importing code from another compiler, while incurring
@@ -21326,7 +21377,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{1a3}@anchor{gnat_ugn/gnat_and_program_execution default-settings}@anchor{1a4}
+@anchor{gnat_ugn/gnat_and_program_execution default-settings}@anchor{1a3}@anchor{gnat_ugn/gnat_and_program_execution id49}@anchor{1a4}
@subsection Default Settings
@@ -21373,7 +21424,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{1a5}@anchor{gnat_ugn/gnat_and_program_execution id50}@anchor{1a6}
+@anchor{gnat_ugn/gnat_and_program_execution id50}@anchor{1a5}@anchor{gnat_ugn/gnat_and_program_execution implementation-notes}@anchor{1a6}
@subsection Implementation Notes
@@ -21421,7 +21472,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{1a7}@anchor{gnat_ugn/gnat_and_program_execution id51}@anchor{14a}
+@anchor{gnat_ugn/gnat_and_program_execution id51}@anchor{14a}@anchor{gnat_ugn/gnat_and_program_execution performing-dimensionality-analysis-in-gnat}@anchor{1a7}
@section Performing Dimensionality Analysis in GNAT
@@ -21655,7 +21706,7 @@ aspect.
@end quotation
The @code{Dimension} aspect of a dimensioned subtype @code{S} defines a mapping
-from the base type's Unit_Names to integer (or, more generally, rational)
+from the base type’s Unit_Names to integer (or, more generally, rational)
values. This mapping is the @emph{dimension vector} (also referred to as the
@emph{dimensionality}) for that subtype, denoted by @code{DV(S)}, and thus for each
object of that subtype. Intuitively, the value specified for each
@@ -21698,7 +21749,7 @@ then @emph{expr} is dimensionless; @code{DV(@emph{expr})} is the empty vector.
@code{DV(@emph{op expr})}, where @emph{op} is a unary operator, is @code{DV(@emph{expr})}
@item
-@code{DV(@emph{expr1 op expr2})} where @emph{op} is "+" or "-" is @code{DV(@emph{expr1})}
+@code{DV(@emph{expr1 op expr2})} where @emph{op} is “+” or “-” is @code{DV(@emph{expr1})}
provided that @code{DV(@emph{expr1})} = @code{DV(@emph{expr2})}.
If this condition is not met then the construct is illegal.
@@ -21714,13 +21765,13 @@ provided that @emph{power} is a static rational value. If this condition is not
met then the construct is illegal.
@end itemize
-Note that, by the above rules, it is illegal to use binary "+" or "-" to
+Note that, by the above rules, it is illegal to use binary “+” or “-” to
combine a dimensioned and dimensionless value. Thus an expression such as
@code{acc-10.0} is illegal, where @code{acc} is an object of subtype
@code{Acceleration}.
The dimensionality checks for relationals use the same rules as
-for "+" and "-", except when comparing to a literal; thus
+for “+” and “-“, except when comparing to a literal; thus
@quotation
@@ -21775,7 +21826,7 @@ converted, for example, to a mass in pounds.
If @code{T} is the base type for @emph{expr} (and the dimensionless root type of
the dimension system), then @code{DV(T(@emph{expr}))} is @code{DV(expr)}.
Thus, if @emph{expr} is of a dimensioned subtype of @code{T}, the conversion may
-be regarded as a "view conversion" that preserves dimensionality.
+be regarded as a “view conversion” that preserves dimensionality.
This rule makes it possible to write generic code that can be instantiated
with compatible dimensioned subtypes. The generic unit will contain
@@ -21808,7 +21859,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{1a8}@anchor{gnat_ugn/gnat_and_program_execution id52}@anchor{14b}
+@anchor{gnat_ugn/gnat_and_program_execution id52}@anchor{14b}@anchor{gnat_ugn/gnat_and_program_execution stack-related-facilities}@anchor{1a8}
@section Stack Related Facilities
@@ -21838,7 +21889,7 @@ some other task exceeds the available stack space, then unpredictable
behavior will occur. Most native systems offer some level of protection by
adding a guard page at the end of each task stack. This mechanism is usually
not enough for dealing properly with stack overflow situations because
-a large local variable could "jump" above the guard page.
+a large local variable could “jump” above the guard page.
Furthermore, when the
guard page is hit, there may not be any space left on the stack for executing
the exception propagation code. Enabling stack checking avoids
@@ -21918,7 +21969,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{1ab}@anchor{gnat_ugn/gnat_and_program_execution dynamic-stack-usage-analysis}@anchor{113}
+@anchor{gnat_ugn/gnat_and_program_execution dynamic-stack-usage-analysis}@anchor{113}@anchor{gnat_ugn/gnat_and_program_execution id55}@anchor{1ab}
@subsection Dynamic Stack Usage Analysis
@@ -21977,7 +22028,7 @@ where:
@item
@emph{Stack Usage} is the measure done by the stack analyzer.
In order to prevent overflow, the stack
-is not entirely analyzed, and it's not possible to know exactly how
+is not entirely analyzed, and it’s not possible to know exactly how
much has actually been used.
@end itemize
@@ -22006,7 +22057,7 @@ stack-usage reports at run time. See its body for the details.
This section describes some useful memory pools provided in the GNAT library
and in particular the GNAT Debug Pool facility, which can be used to detect
-incorrect uses of access values (including 'dangling references').
+incorrect uses of access values (including ‘dangling references’).
@menu
@@ -22260,7 +22311,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{1b1}@anchor{gnat_ugn/platform_specific_information id1}@anchor{1b2}
+@anchor{gnat_ugn/platform_specific_information doc}@anchor{1b1}@anchor{gnat_ugn/platform_specific_information id1}@anchor{1b2}@anchor{gnat_ugn/platform_specific_information platform-specific-information}@anchor{d}
@chapter Platform-Specific Information
@@ -22306,7 +22357,7 @@ For exception handling, either or both of two models are supplied:
@itemize *
@item
-@strong{Zero-Cost Exceptions} ("ZCX"),
+@strong{Zero-Cost Exceptions} (“ZCX”),
which uses binder-generated tables that
are interrogated at run time to locate a handler.
@@ -22315,7 +22366,7 @@ are interrogated at run time to locate a handler.
@geindex SJLJ (setjmp/longjmp Exception Model)
@item
-@strong{setjmp / longjmp} ('SJLJ'),
+@strong{setjmp / longjmp} (‘SJLJ’),
which uses dynamically-set data to establish
the set of handlers
@end itemize
@@ -22339,7 +22390,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{1b5}@anchor{gnat_ugn/platform_specific_information id3}@anchor{1b6}
+@anchor{gnat_ugn/platform_specific_information id3}@anchor{1b5}@anchor{gnat_ugn/platform_specific_information summary-of-run-time-configurations}@anchor{1b6}
@subsection Summary of Run-Time Configurations
@@ -22439,7 +22490,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{1b7}@anchor{gnat_ugn/platform_specific_information id4}@anchor{1b8}
+@anchor{gnat_ugn/platform_specific_information id4}@anchor{1b7}@anchor{gnat_ugn/platform_specific_information specifying-a-run-time-library}@anchor{1b8}
@section Specifying a Run-Time Library
@@ -22590,7 +22641,7 @@ Ignore : constant Boolean :=
@end example
@end quotation
-It gets the effective user id, and if it's not 0 (i.e. root), it raises
+It gets the effective user id, and if it’s not 0 (i.e. root), it raises
Program_Error.
@geindex Linux
@@ -22598,7 +22649,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{1bb}@anchor{gnat_ugn/platform_specific_information gnu-linux-topics}@anchor{1bc}
+@anchor{gnat_ugn/platform_specific_information gnu-linux-topics}@anchor{1bb}@anchor{gnat_ugn/platform_specific_information id6}@anchor{1bc}
@section GNU/Linux Topics
@@ -22614,7 +22665,7 @@ This section describes topics that are specific to GNU/Linux platforms.
@subsection Required Packages on GNU/Linux
-GNAT requires the C library developer's package to be installed.
+GNAT requires the C library developer’s package to be installed.
The name of of that package depends on your GNU/Linux distribution:
@@ -22628,7 +22679,7 @@ Debian, Ubuntu: @code{libc6-dev} (normally installed by default).
@end itemize
If using the 32-bit version of GNAT on a 64-bit version of GNU/Linux,
-you'll need the 32-bit version of the following packages:
+you’ll need the 32-bit version of the following packages:
@itemize *
@@ -22646,7 +22697,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{1bf}@anchor{gnat_ugn/platform_specific_information id8}@anchor{1c0}
+@anchor{gnat_ugn/platform_specific_information id8}@anchor{1bf}@anchor{gnat_ugn/platform_specific_information microsoft-windows-topics}@anchor{1c0}
@section Microsoft Windows Topics
@@ -22667,7 +22718,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{1c1}@anchor{gnat_ugn/platform_specific_information id9}@anchor{1c2}
+@anchor{gnat_ugn/platform_specific_information id9}@anchor{1c1}@anchor{gnat_ugn/platform_specific_information using-gnat-on-windows}@anchor{1c2}
@subsection Using GNAT on Windows
@@ -22726,7 +22777,7 @@ import libraries. Interfacing must be done by the mean of DLLs.
@item
It is possible to link against Microsoft C libraries. Yet the preferred
solution is to use C/C++ compiler that comes with GNAT, since it
-doesn't require having two different development environments and makes the
+doesn’t require having two different development environments and makes the
inter-language debugging experience smoother.
@item
@@ -22771,7 +22822,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{1c5}@anchor{gnat_ugn/platform_specific_information console-and-windows-subsystems}@anchor{1c6}
+@anchor{gnat_ugn/platform_specific_information console-and-windows-subsystems}@anchor{1c5}@anchor{gnat_ugn/platform_specific_information id11}@anchor{1c6}
@subsection CONSOLE and WINDOWS subsystems
@@ -23036,7 +23087,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{1cf}@anchor{gnat_ugn/platform_specific_information id14}@anchor{1d0}
+@anchor{gnat_ugn/platform_specific_information id14}@anchor{1cf}@anchor{gnat_ugn/platform_specific_information windows-calling-conventions}@anchor{1d0}
@subsubsection Windows Calling Conventions
@@ -23049,9 +23100,9 @@ calling convention. All convention specifiers are ignored on this
platform.
When a subprogram @code{F} (caller) calls a subprogram @code{G}
-(callee), there are several ways to push @code{G}'s parameters on the
+(callee), there are several ways to push @code{G}’s parameters on the
stack and there are several possible scenarios to clean up the stack
-upon @code{G}'s return. A calling convention is an agreed upon software
+upon @code{G}’s return. A calling convention is an agreed upon software
protocol whereby the responsibilities between the caller (@code{F}) and
the callee (@code{G}) are clearly defined. Several calling conventions
are available for Windows:
@@ -23126,7 +23177,7 @@ DLL (in which case you should use the @code{Stdcall} calling
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{1d3}@anchor{gnat_ugn/platform_specific_information id16}@anchor{1d4}
+@anchor{gnat_ugn/platform_specific_information id16}@anchor{1d4}@anchor{gnat_ugn/platform_specific_information stdcall-calling-convention}@anchor{1d3}
@subsubsection @code{Stdcall} Calling Convention
@@ -23194,7 +23245,7 @@ then the imported routine is @code{retrieve_val}, that is, there is no
decoration at all. No leading underscore and no Stdcall suffix
@code{@@@emph{nn}}.
-This is especially important as in some special cases a DLL's entry
+This is especially important as in some special cases a DLL’s entry
point name lacks a trailing @code{@@@emph{nn}} while the exported
name generated for a call has it.
@@ -23223,7 +23274,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{1d5}@anchor{gnat_ugn/platform_specific_information id17}@anchor{1d6}
+@anchor{gnat_ugn/platform_specific_information id17}@anchor{1d5}@anchor{gnat_ugn/platform_specific_information win32-calling-convention}@anchor{1d6}
@subsubsection @code{Win32} Calling Convention
@@ -23231,7 +23282,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{1d7}@anchor{gnat_ugn/platform_specific_information dll-calling-convention}@anchor{1d8}
+@anchor{gnat_ugn/platform_specific_information dll-calling-convention}@anchor{1d7}@anchor{gnat_ugn/platform_specific_information id18}@anchor{1d8}
@subsubsection @code{DLL} Calling Convention
@@ -23316,7 +23367,7 @@ application, a conflict will occur and the application will run
incorrectly. Hence, when possible, it is always preferable to use and
build relocatable DLLs. Both relocatable and non-relocatable DLLs are
supported by GNAT. Note that the @code{-s} linker option (see GNU Linker
-User's Guide) removes the debugging symbols from the DLL but the DLL can
+User’s Guide) removes the debugging symbols from the DLL but the DLL can
still be relocated.
As a side note, an interesting difference between Microsoft DLLs and
@@ -23345,7 +23396,7 @@ header files provided with the DLL.
The import library (@code{libAPI.dll.a} or @code{API.lib}). As previously
mentioned an import library is a statically linked library containing the
import table which will be filled at load time to point to the actual
-@code{API.dll} routines. Sometimes you don't have an import library for the
+@code{API.dll} routines. Sometimes you don’t have an import library for the
DLL you want to use. The following sections will explain how to build
one. Note that this is optional.
@@ -23417,7 +23468,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{1dd}@anchor{gnat_ugn/platform_specific_information creating-an-ada-spec-for-the-dll-services}@anchor{1de}
+@anchor{gnat_ugn/platform_specific_information creating-an-ada-spec-for-the-dll-services}@anchor{1dd}@anchor{gnat_ugn/platform_specific_information id21}@anchor{1de}
@subsubsection Creating an Ada Spec for the DLL Services
@@ -23457,7 +23508,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{1df}@anchor{gnat_ugn/platform_specific_information creating-an-import-library}@anchor{1e0}
+@anchor{gnat_ugn/platform_specific_information creating-an-import-library}@anchor{1df}@anchor{gnat_ugn/platform_specific_information id22}@anchor{1e0}
@subsubsection Creating an Import Library
@@ -23519,7 +23570,7 @@ EXPORTS
@end table
Note that you must specify the correct suffix (@code{@@@emph{nn}})
-(see @ref{1cf,,Windows Calling Conventions}) for a Stdcall
+(see @ref{1d0,,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
@@ -23539,8 +23590,8 @@ $ 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{1cf,,Windows Calling Conventions}) with stripped @code{@@@emph{nn}}
-suffix then you'll have to edit @code{api.def} to add it, and specify
+(@ref{1d0,,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.
Here are some hints to find the right @code{@@@emph{nn}} suffix.
@@ -23597,7 +23648,7 @@ 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
-Microsoft's @code{lib} utility:
+Microsoft’s @code{lib} utility:
@quotation
@@ -23617,7 +23668,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{1e5}@anchor{gnat_ugn/platform_specific_information building-dlls-with-gnat-project-files}@anchor{1ce}
+@anchor{gnat_ugn/platform_specific_information building-dlls-with-gnat-project-files}@anchor{1ce}@anchor{gnat_ugn/platform_specific_information id23}@anchor{1e5}
@subsubsection Building DLLs with GNAT Project files
@@ -23626,7 +23677,7 @@ See the Microsoft documentation for further details about the usage of
There is nothing specific to Windows in the build process.
See the @emph{Library Projects} section in the @emph{GNAT Project Manager}
-chapter of the @emph{GPRbuild User's Guide}.
+chapter of the @emph{GPRbuild User’s Guide}.
Due to a system limitation, it is not possible under Windows to create threads
when inside the @code{DllMain} routine which is used for auto-initialization
@@ -23673,7 +23724,7 @@ $ gcc -shared -shared-libgcc -o api.dll api.def obj1.o obj2.o ...
If you use a definition file you must export the elaboration procedures
for every package that required one. Elaboration procedures are named
-using the package name followed by "_E".
+using the package name followed by “_E”.
@item
Preparing DLL to be used.
@@ -23762,7 +23813,7 @@ binutils tool will not be relocatable anymore. To build a DLL without
debug information pass @code{-largs -s} to @code{gnatdll}. This
restriction does not apply to a DLL built using a Library Project.
See the @emph{Library Projects} section in the @emph{GNAT Project Manager}
-chapter of the @emph{GPRbuild User's Guide}.
+chapter of the @emph{GPRbuild User’s Guide}.
@c Limitations_When_Using_Ada_DLLs_from Ada:
@@ -23924,12 +23975,12 @@ directly from @code{DllMain} without having to provide an explicit
initialization routine. Unfortunately, it is not possible to call
@code{adainit} from the @code{DllMain} if your program has library level
tasks because access to the @code{DllMain} entry point is serialized by
-the system (that is, only a single thread can execute 'through' it at a
+the system (that is, only a single thread can execute ‘through’ it at a
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{1f1}@anchor{gnat_ugn/platform_specific_information ada-dlls-and-finalization}@anchor{1ec}
+@anchor{gnat_ugn/platform_specific_information ada-dlls-and-finalization}@anchor{1ec}@anchor{gnat_ugn/platform_specific_information id28}@anchor{1f1}
@subsubsection Ada DLLs and Finalization
@@ -23947,7 +23998,7 @@ during the DLL build process by the @code{gnatdll} tool
(@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{1f2}@anchor{gnat_ugn/platform_specific_information creating-a-spec-for-ada-dlls}@anchor{1f3}
+@anchor{gnat_ugn/platform_specific_information creating-a-spec-for-ada-dlls}@anchor{1f2}@anchor{gnat_ugn/platform_specific_information id29}@anchor{1f3}
@subsubsection Creating a Spec for Ada DLLs
@@ -24041,7 +24092,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{1e3}@anchor{gnat_ugn/platform_specific_information id31}@anchor{1f5}
+@anchor{gnat_ugn/platform_specific_information id31}@anchor{1f5}@anchor{gnat_ugn/platform_specific_information using-gnatdll}@anchor{1e3}
@subsubsection Using @code{gnatdll}
@@ -24145,7 +24196,7 @@ object files needed to build the DLL.
@item @code{-k}
-Removes the @code{@@@emph{nn}} suffix from the import library's exported
+Removes the @code{@@@emph{nn}} suffix from the import library’s exported
names, but keeps them for the link names. You must specify this
option if you want to use a @code{Stdcall} function in a DLL for which
the @code{@@@emph{nn}} suffix has been removed. This is the case for most
@@ -24350,7 +24401,7 @@ DLL in the static import library generated by @code{dlltool} with switch
@item @code{-k}
Kill @code{@@@emph{nn}} from exported names
-(@ref{1cf,,Windows Calling Conventions}
+(@ref{1d0,,Windows Calling Conventions}
for a discussion about @code{Stdcall}-style symbols.
@end table
@@ -24563,7 +24614,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{1fd}@anchor{gnat_ugn/platform_specific_information id35}@anchor{1fe}
+@anchor{gnat_ugn/platform_specific_information id35}@anchor{1fd}@anchor{gnat_ugn/platform_specific_information using-resources}@anchor{1fe}
@subsubsection Using Resources
@@ -24601,7 +24652,7 @@ cookbook-style sequence of steps to follow:
@item
First develop and build the GNAT shared library using a library project
-(let's assume the project is @code{mylib.gpr}, producing the library @code{libmylib.dll}):
+(let’s assume the project is @code{mylib.gpr}, producing the library @code{libmylib.dll}):
@end enumerate
@quotation
@@ -24644,7 +24695,7 @@ $ lib -machine:IX86 -def:libmylib.def -out:libmylib.lib
@end example
@end quotation
-If you are using a 64-bit toolchain, the above becomes...
+If you are using a 64-bit toolchain, the above becomes…
@quotation
@@ -24676,7 +24727,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{201}@anchor{gnat_ugn/platform_specific_information debugging-a-dll}@anchor{202}
+@anchor{gnat_ugn/platform_specific_information debugging-a-dll}@anchor{201}@anchor{gnat_ugn/platform_specific_information id36}@anchor{202}
@subsubsection Debugging a DLL
@@ -24720,7 +24771,7 @@ tools suite used to build the DLL.
This is the simplest case. Both the DLL and the program have @code{GDB}
compatible debugging information. It is then possible to break anywhere in
-the process. Let's suppose here that the main procedure is named
+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}.
@@ -24764,7 +24815,7 @@ you can use the standard approach to debug the whole program
(@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{205}@anchor{gnat_ugn/platform_specific_information id38}@anchor{206}
+@anchor{gnat_ugn/platform_specific_information id38}@anchor{205}@anchor{gnat_ugn/platform_specific_information program-built-with-foreign-tools-and-dll-built-with-gcc-gnat}@anchor{206}
@subsubsection Program Built with Foreign Tools and DLL Built with GCC/GNAT
@@ -24875,7 +24926,7 @@ $ main
@end example
@item
-Use the Windows @emph{Task Manager} to find the process ID. Let's say
+Use the Windows @emph{Task Manager} to find the process ID. Let’s say
that the process PID for @code{main.exe} is 208.
@item
@@ -24920,7 +24971,7 @@ approach to debug a program as described in
@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{127}@anchor{gnat_ugn/platform_specific_information id39}@anchor{207}
+@anchor{gnat_ugn/platform_specific_information id39}@anchor{207}@anchor{gnat_ugn/platform_specific_information setting-stack-size-from-gnatlink}@anchor{127}
@subsubsection Setting Stack Size from @code{gnatlink}
@@ -24963,7 +25014,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{128}@anchor{gnat_ugn/platform_specific_information id40}@anchor{208}
+@anchor{gnat_ugn/platform_specific_information id40}@anchor{208}@anchor{gnat_ugn/platform_specific_information setting-heap-size-from-gnatlink}@anchor{128}
@subsubsection Setting Heap Size from @code{gnatlink}
@@ -24996,7 +25047,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{209}@anchor{gnat_ugn/platform_specific_information win32-specific-addons}@anchor{20a}
+@anchor{gnat_ugn/platform_specific_information win32-specific-addons}@anchor{209}@anchor{gnat_ugn/platform_specific_information windows-specific-add-ons}@anchor{20a}
@subsection Windows Specific Add-Ons
@@ -25009,7 +25060,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{20b}@anchor{gnat_ugn/platform_specific_information id41}@anchor{20c}
+@anchor{gnat_ugn/platform_specific_information id41}@anchor{20b}@anchor{gnat_ugn/platform_specific_information win32ada}@anchor{20c}
@subsubsection Win32Ada
@@ -25030,7 +25081,7 @@ end P;
@end quotation
To build the application you just need to call gprbuild for the
-application's project, here p.gpr:
+application’s project, here p.gpr:
@quotation
@@ -25063,7 +25114,7 @@ end P;
@end quotation
To build the application you just need to call gprbuild for the
-application's project, here p.gpr:
+application’s project, here p.gpr:
@quotation
@@ -25073,13 +25124,13 @@ 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{20f}@anchor{gnat_ugn/platform_specific_information id43}@anchor{210}
+@anchor{gnat_ugn/platform_specific_information id43}@anchor{20f}@anchor{gnat_ugn/platform_specific_information mac-os-topics}@anchor{210}
@section Mac OS Topics
@geindex OS X
-This section describes topics that are specific to Apple's OS X
+This section describes topics that are specific to Apple’s OS X
platform.
@menu
@@ -25115,7 +25166,7 @@ Start the Keychain Access application (in
@item
Select the Keychain Access -> Certificate Assistant ->
-Create a Certificate... menu
+Create a Certificate… menu
@item
Then:
@@ -25125,28 +25176,28 @@ Then:
@item
Choose a name for the new certificate (this procedure will use
-"gdb-cert" as an example)
+“gdb-cert” as an example)
@item
-Set "Identity Type" to "Self Signed Root"
+Set “Identity Type” to “Self Signed Root”
@item
-Set "Certificate Type" to "Code Signing"
+Set “Certificate Type” to “Code Signing”
@item
-Activate the "Let me override defaults" option
+Activate the “Let me override defaults” option
@end itemize
@item
-Click several times on "Continue" until the "Specify a Location
-For The Certificate" screen appears, then set "Keychain" to "System"
+Click several times on “Continue” until the “Specify a Location
+For The Certificate” screen appears, then set “Keychain” to “System”
@item
-Click on "Continue" until the certificate is created
+Click on “Continue” until the certificate is created
@item
Finally, in the view, double-click on the new certificate,
-and set "When using this certificate" to "Always Trust"
+and set “When using this certificate” to “Always Trust”
@item
Exit the Keychain Access application and restart the computer
@@ -25163,20 +25214,20 @@ $ codesign -f -s "gdb-cert" <gnat_install_prefix>/bin/gdb
@end example
@end quotation
-where "gdb-cert" should be replaced by the actual certificate
+where “gdb-cert” should be replaced by the actual certificate
name chosen above, and <gnat_install_prefix> should be replaced by
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{212}@anchor{gnat_ugn/example_of_binder_output id1}@anchor{213}
+@anchor{gnat_ugn/example_of_binder_output doc}@anchor{212}@anchor{gnat_ugn/example_of_binder_output example-of-binder-output-file}@anchor{e}@anchor{gnat_ugn/example_of_binder_output id1}@anchor{213}
@chapter Example of Binder Output File
@geindex Binder output (example)
This Appendix displays the source code for the output file
-generated by @emph{gnatbind} for a simple 'Hello World' program.
+generated by @emph{gnatbind} for a simple ‘Hello World’ program.
Comments have been added for clarification purposes.
@example
@@ -25921,7 +25972,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{214}@anchor{gnat_ugn/elaboration_order_handling_in_gnat id1}@anchor{215}
+@anchor{gnat_ugn/elaboration_order_handling_in_gnat doc}@anchor{214}@anchor{gnat_ugn/elaboration_order_handling_in_gnat elaboration-order-handling-in-gnat}@anchor{f}@anchor{gnat_ugn/elaboration_order_handling_in_gnat id1}@anchor{215}
@chapter Elaboration Order Handling in GNAT
@@ -26233,11 +26284,11 @@ body of Main
@end example
@end quotation
-The elaboration of @code{Server}'s spec materializes function @code{Func}, making it
-callable. The elaboration of @code{Client}'s spec elaborates the declaration of
+The elaboration of @code{Server}’s spec materializes function @code{Func}, making it
+callable. The elaboration of @code{Client}’s spec elaborates the declaration of
@code{Val}. This invokes function @code{Server.Func}, however the body of
-@code{Server.Func} has not been elaborated yet because @code{Server}'s body comes
-after @code{Client}'s spec in the elaboration order. As a result, the value of
+@code{Server.Func} has not been elaborated yet because @code{Server}’s body comes
+after @code{Client}’s spec in the elaboration order. As a result, the value of
constant @code{Val} is now undefined.
Without any guarantees from the language, an undetected ABE problem may hinder
@@ -26268,7 +26319,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{21a}@anchor{gnat_ugn/elaboration_order_handling_in_gnat checking-the-elaboration-order}@anchor{21b}
+@anchor{gnat_ugn/elaboration_order_handling_in_gnat checking-the-elaboration-order}@anchor{21a}@anchor{gnat_ugn/elaboration_order_handling_in_gnat id4}@anchor{21b}
@section Checking the Elaboration Order
@@ -26396,7 +26447,7 @@ but still strong enough to prevent ABE problems within a unit.
Pragma @code{Elaborate_Body} requires that the body of a unit is elaborated
immediately after its spec. This restriction guarantees that no client
scenario can invoke a server target before the target body has been
-elaborated because the spec and body are effectively "glued" together.
+elaborated because the spec and body are effectively “glued” together.
@example
package Server is
@@ -26657,7 +26708,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{21e}@anchor{gnat_ugn/elaboration_order_handling_in_gnat controlling-the-elaboration-order-in-gnat}@anchor{21f}
+@anchor{gnat_ugn/elaboration_order_handling_in_gnat controlling-the-elaboration-order-in-gnat}@anchor{21e}@anchor{gnat_ugn/elaboration_order_handling_in_gnat id6}@anchor{21f}
@section Controlling the Elaboration Order in GNAT
@@ -26787,7 +26838,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{220}@anchor{gnat_ugn/elaboration_order_handling_in_gnat id7}@anchor{221}
+@anchor{gnat_ugn/elaboration_order_handling_in_gnat id7}@anchor{220}@anchor{gnat_ugn/elaboration_order_handling_in_gnat mixing-elaboration-models}@anchor{221}
@section Mixing Elaboration Models
@@ -26867,7 +26918,7 @@ end Guaranteed_ABE;
@end example
@end quotation
-In the example above, the elaboration of @code{Guaranteed_ABE}'s body elaborates
+In the example above, the elaboration of @code{Guaranteed_ABE}’s body elaborates
the declaration of @code{Val}. This invokes function @code{ABE}, however the body of
@code{ABE} has not been elaborated yet. GNAT emits the following diagnostic:
@@ -26941,7 +26992,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{224}@anchor{gnat_ugn/elaboration_order_handling_in_gnat id9}@anchor{225}
+@anchor{gnat_ugn/elaboration_order_handling_in_gnat id9}@anchor{224}@anchor{gnat_ugn/elaboration_order_handling_in_gnat spark-diagnostics}@anchor{225}
@section SPARK Diagnostics
@@ -26967,7 +27018,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{226}@anchor{gnat_ugn/elaboration_order_handling_in_gnat elaboration-circularities}@anchor{227}
+@anchor{gnat_ugn/elaboration_order_handling_in_gnat elaboration-circularities}@anchor{226}@anchor{gnat_ugn/elaboration_order_handling_in_gnat id10}@anchor{227}
@section Elaboration Circularities
@@ -27338,7 +27389,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{22a}@anchor{gnat_ugn/elaboration_order_handling_in_gnat elaboration-related-compiler-switches}@anchor{22b}
+@anchor{gnat_ugn/elaboration_order_handling_in_gnat elaboration-related-compiler-switches}@anchor{22a}@anchor{gnat_ugn/elaboration_order_handling_in_gnat id12}@anchor{22b}
@section Elaboration-related Compiler Switches
@@ -27442,7 +27493,7 @@ eliminate some diagnostics and run-time checks.
@item @code{-gnatw.f}
-Turn on warnings for suspicious Subp'Access
+Turn on warnings for suspicious Subp’Access
When this switch is in effect, GNAT will treat @code{'Access} of an entry,
operator, or subprogram as a potential call to the target and issue warnings:
@@ -27720,7 +27771,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{230}@anchor{gnat_ugn/inline_assembler id1}@anchor{231}
+@anchor{gnat_ugn/inline_assembler doc}@anchor{230}@anchor{gnat_ugn/inline_assembler id1}@anchor{231}@anchor{gnat_ugn/inline_assembler inline-assembler}@anchor{10}
@chapter Inline Assembler
@@ -27779,13 +27830,13 @@ 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{232}@anchor{gnat_ugn/inline_assembler basic-assembler-syntax}@anchor{233}
+@anchor{gnat_ugn/inline_assembler basic-assembler-syntax}@anchor{232}@anchor{gnat_ugn/inline_assembler id2}@anchor{233}
@section Basic Assembler Syntax
The assembler used by GNAT and gcc is based not on the Intel assembly
language, but rather on a language that descends from the AT&T Unix
-assembler @code{as} (and which is often referred to as 'AT&T syntax').
+assembler @code{as} (and which is often referred to as ‘AT&T syntax’).
The following table summarizes the main features of @code{as} syntax
and points out the differences from the Intel conventions.
See the gcc @code{as} and @code{gas} (an @code{as} macro
@@ -27795,7 +27846,7 @@ pre-processor) documentation for further information.
@display
@emph{Register names}@w{ }
@display
-gcc / @code{as}: Prefix with '%'; for example @code{%eax}@w{ }
+gcc / @code{as}: Prefix with ‘%’; for example @code{%eax}@w{ }
Intel: No extra punctuation; for example @code{eax}@w{ }
@end display
@end display
@@ -27806,7 +27857,7 @@ Intel: No extra punctuation; for example @code{eax}@w{ }
@display
@emph{Immediate operand}@w{ }
@display
-gcc / @code{as}: Prefix with '$'; for example @code{$4}@w{ }
+gcc / @code{as}: Prefix with ‘$’; for example @code{$4}@w{ }
Intel: No extra punctuation; for example @code{4}@w{ }
@end display
@end display
@@ -27817,7 +27868,7 @@ Intel: No extra punctuation; for example @code{4}@w{ }
@display
@emph{Address}@w{ }
@display
-gcc / @code{as}: Prefix with '$'; for example @code{$loc}@w{ }
+gcc / @code{as}: Prefix with ‘$’; for example @code{$loc}@w{ }
Intel: No extra punctuation; for example @code{loc}@w{ }
@end display
@end display
@@ -27850,8 +27901,8 @@ Intel: Square brackets; for example @code{[eax]}@w{ }
@display
@emph{Hexadecimal numbers}@w{ }
@display
-gcc / @code{as}: Leading '0x' (C language syntax); for example @code{0xA0}@w{ }
-Intel: Trailing 'h'; for example @code{A0h}@w{ }
+gcc / @code{as}: Leading ‘0x’ (C language syntax); for example @code{0xA0}@w{ }
+Intel: Trailing ‘h’; for example @code{A0h}@w{ }
@end display
@end display
@@ -28018,9 +28069,9 @@ L1:
The assembly code you included is clearly indicated by
the compiler, between the @code{#APP} and @code{#NO_APP}
-delimiters. The character before the 'APP' and 'NOAPP'
-can differ on different targets. For example, GNU/Linux uses '#APP' while
-on NT you will see '/APP'.
+delimiters. The character before the ‘APP’ and ‘NOAPP’
+can differ on different targets. For example, GNU/Linux uses ‘#APP’ while
+on NT you will see ‘/APP’.
If you make a mistake in your assembler code (such as using the
wrong size modifier, or using a wrong operand for the instruction) GNAT
@@ -28184,7 +28235,7 @@ Unsigned_32'Asm_Output ("=r", Flags);
uses the @code{"r"} (register) constraint, telling the compiler to
store the variable in a register.
-If the constraint is preceded by the equal character '=', it tells
+If the constraint is preceded by the equal character ‘=’, it tells
the compiler that the variable will be used to store data into it.
In the @code{Get_Flags} example, we used the @code{"g"} (global) constraint,
@@ -28507,7 +28558,7 @@ _increment__incr.1:
For a short subprogram such as the @code{Incr} function in the previous
section, the overhead of the call and return (creating / deleting the stack
frame) can be significant, compared to the amount of code in the subprogram
-body. A solution is to apply Ada's @code{Inline} pragma to the subprogram,
+body. A solution is to apply Ada’s @code{Inline} pragma to the subprogram,
which directs the compiler to expand invocations of the subprogram at the
point(s) of call, instead of setting up a stack frame for out-of-line calls.
Here is the resulting program:
@@ -28571,7 +28622,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{23c}@anchor{gnat_ugn/inline_assembler id7}@anchor{23d}
+@anchor{gnat_ugn/inline_assembler id7}@anchor{23c}@anchor{gnat_ugn/inline_assembler other-asm-functionality}@anchor{23d}
@section Other @code{Asm} Functionality
@@ -28586,7 +28637,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{23e}@anchor{gnat_ugn/inline_assembler id8}@anchor{23f}
+@anchor{gnat_ugn/inline_assembler id8}@anchor{23e}@anchor{gnat_ugn/inline_assembler the-clobber-parameter}@anchor{23f}
@subsection The @code{Clobber} Parameter
@@ -28599,7 +28650,7 @@ the eax register). But more generally, the compiler needs an explicit
identification of the registers that are used by the Inline Assembly
statements.
-Using a register that the compiler doesn't know about
+Using a register that the compiler doesn’t know about
could be a side effect of an instruction (like @code{mull}
storing its result in both eax and edx).
It can also arise from explicit register usage in your
@@ -28643,14 +28694,14 @@ The @code{Clobber} parameter has several additional uses:
@itemize *
@item
-Use 'register' name @code{cc} to indicate that flags might have changed
+Use ‘register’ name @code{cc} to indicate that flags might have changed
@item
-Use 'register' name @code{memory} if you changed a memory location
+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{240}@anchor{gnat_ugn/inline_assembler id9}@anchor{241}
+@anchor{gnat_ugn/inline_assembler id9}@anchor{240}@anchor{gnat_ugn/inline_assembler the-volatile-parameter}@anchor{241}
@subsection The @code{Volatile} Parameter
@@ -28682,11 +28733,11 @@ By default, @code{Volatile} is set to @code{False} unless there is no
Although setting @code{Volatile} to @code{True} prevents unwanted
optimizations, it will also disable other optimizations that might be
important for efficiency. In general, you should set @code{Volatile}
-to @code{True} only if the compiler's optimizations have created
+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{242}@anchor{share/gnu_free_documentation_license gnu-free-documentation-license}@anchor{243}
+@anchor{share/gnu_free_documentation_license doc}@anchor{242}@anchor{share/gnu_free_documentation_license gnu-fdl}@anchor{1}@anchor{share/gnu_free_documentation_license gnu-free-documentation-license}@anchor{243}
@chapter GNU Free Documentation License
@@ -28701,14 +28752,14 @@ license document, but changing it is not allowed.
@strong{Preamble}
The purpose of this License is to make a manual, textbook, or other
-functional and useful document "free" in the sense of freedom: to
+functional and useful document “free” in the sense of freedom: to
assure everyone the effective freedom to copy and redistribute it,
with or without modifying it, either commercially or noncommercially.
Secondarily, this License preserves for the author and publisher a way
to get credit for their work, while not being considered responsible
for modifications made by others.
-This License is a kind of "copyleft", which means that derivative
+This License is a kind of “copyleft”, which means that derivative
works of the document must themselves be free in the same sense. It
complements the GNU General Public License, which is a copyleft
license designed for free software.
@@ -28729,17 +28780,17 @@ distributed under the terms of this License. Such a notice grants a
world-wide, royalty-free license, unlimited in duration, to use that
work under the conditions stated herein. The @strong{Document}, below,
refers to any such manual or work. Any member of the public is a
-licensee, and is addressed as "@strong{you}". You accept the license if you
+licensee, and is addressed as “@strong{you}”. You accept the license if you
copy, modify or distribute the work in a way requiring permission
under copyright law.
-A "@strong{Modified Version}" of the Document means any work containing the
+A “@strong{Modified Version}” of the Document means any work containing the
Document or a portion of it, either copied verbatim, or with
modifications and/or translated into another language.
-A "@strong{Secondary Section}" is a named appendix or a front-matter section of
+A “@strong{Secondary Section}” is a named appendix or a front-matter section of
the Document that deals exclusively with the relationship of the
-publishers or authors of the Document to the Document's overall subject
+publishers or authors of the Document to the Document’s overall subject
(or to related matters) and contains nothing that could fall directly
within that overall subject. (Thus, if the Document is in part a
textbook of mathematics, a Secondary Section may not explain any
@@ -28748,7 +28799,7 @@ connection with the subject or with related matters, or of legal,
commercial, philosophical, ethical or political position regarding
them.
-The "@strong{Invariant Sections}" are certain Secondary Sections whose titles
+The “@strong{Invariant Sections}” are certain Secondary Sections whose titles
are designated, as being those of Invariant Sections, in the notice
that says that the Document is released under this License. If a
section does not fit the above definition of Secondary then it is not
@@ -28756,12 +28807,12 @@ allowed to be designated as Invariant. The Document may contain zero
Invariant Sections. If the Document does not identify any Invariant
Sections then there are none.
-The "@strong{Cover Texts}" are certain short passages of text that are listed,
+The “@strong{Cover Texts}” are certain short passages of text that are listed,
as Front-Cover Texts or Back-Cover Texts, in the notice that says that
the Document is released under this License. A Front-Cover Text may
be at most 5 words, and a Back-Cover Text may be at most 25 words.
-A "@strong{Transparent}" copy of the Document means a machine-readable copy,
+A “@strong{Transparent}” copy of the Document means a machine-readable copy,
represented in a format whose specification is available to the
general public, that is suitable for revising the document
straightforwardly with generic text editors or (for images composed of
@@ -28772,7 +28823,7 @@ to text formatters. A copy made in an otherwise Transparent file
format whose markup, or absence of markup, has been arranged to thwart
or discourage subsequent modification by readers is not Transparent.
An image format is not Transparent if used for any substantial amount
-of text. A copy that is not "Transparent" is called @strong{Opaque}.
+of text. A copy that is not “Transparent” is called @strong{Opaque}.
Examples of suitable formats for Transparent copies include plain
ASCII without markup, Texinfo input format, LaTeX input format, SGML
@@ -28785,24 +28836,24 @@ processing tools are not generally available, and the
machine-generated HTML, PostScript or PDF produced by some word
processors for output purposes only.
-The "@strong{Title Page}" means, for a printed book, the title page itself,
+The “@strong{Title Page}” means, for a printed book, the title page itself,
plus such following pages as are needed to hold, legibly, the material
this License requires to appear in the title page. For works in
-formats which do not have any title page as such, "Title Page" means
-the text near the most prominent appearance of the work's title,
+formats which do not have any title page as such, “Title Page” means
+the text near the most prominent appearance of the work’s title,
preceding the beginning of the body of the text.
-The "@strong{publisher}" means any person or entity that distributes
+The “@strong{publisher}” means any person or entity that distributes
copies of the Document to the public.
-A section "@strong{Entitled XYZ}" means a named subunit of the Document whose
+A section “@strong{Entitled XYZ}” means a named subunit of the Document whose
title either is precisely XYZ or contains XYZ in parentheses following
text that translates XYZ in another language. (Here XYZ stands for a
-specific section name mentioned below, such as "@strong{Acknowledgements}",
-"@strong{Dedications}", "@strong{Endorsements}", or "@strong{History}".)
-To "@strong{Preserve the Title}"
+specific section name mentioned below, such as “@strong{Acknowledgements}”,
+“@strong{Dedications}”, “@strong{Endorsements}”, or “@strong{History}”.)
+To “@strong{Preserve the Title}”
of such a section when you modify the Document means that it remains a
-section "Entitled XYZ" according to this definition.
+section “Entitled XYZ” according to this definition.
The Document may include Warranty Disclaimers next to the notice which
states that this License applies to the Document. These Warranty
@@ -28830,7 +28881,7 @@ you may publicly display copies.
If you publish printed copies (or copies in media that commonly have
printed covers) of the Document, numbering more than 100, and the
-Document's license notice requires Cover Texts, you must enclose the
+Document’s license notice requires Cover Texts, you must enclose the
copies in covers that carry, clearly and legibly, all these Cover
Texts: Front-Cover Texts on the front cover, and Back-Cover Texts on
the back cover. Both covers must also clearly and legibly identify
@@ -28907,16 +28958,16 @@ terms of this License, in the form shown in the Addendum below.
@item
Preserve in that license notice the full lists of Invariant Sections
-and required Cover Texts given in the Document's license notice.
+and required Cover Texts given in the Document’s license notice.
@item
Include an unaltered copy of this License.
@item
-Preserve the section Entitled "History", Preserve its Title, and add
+Preserve the section Entitled “History”, Preserve its Title, and add
to it an item stating at least the title, year, new authors, and
publisher of the Modified Version as given on the Title Page. If
-there is no section Entitled "History" in the Document, create one
+there is no section Entitled “History” in the Document, create one
stating the title, year, authors, and publisher of the Document as
given on its Title Page, then add an item describing the Modified
Version as stated in the previous sentence.
@@ -28925,13 +28976,13 @@ Version as stated in the previous sentence.
Preserve the network location, if any, given in the Document for
public access to a Transparent copy of the Document, and likewise
the network locations given in the Document for previous versions
-it was based on. These may be placed in the "History" section.
+it was based on. These may be placed in the “History” section.
You may omit a network location for a work that was published at
least four years before the Document itself, or if the original
publisher of the version it refers to gives permission.
@item
-For any section Entitled "Acknowledgements" or "Dedications",
+For any section Entitled “Acknowledgements” or “Dedications”,
Preserve the Title of the section, and preserve in the section all
the substance and tone of each of the contributor acknowledgements
and/or dedications given therein.
@@ -28942,11 +28993,11 @@ unaltered in their text and in their titles. Section numbers
or the equivalent are not considered part of the section titles.
@item
-Delete any section Entitled "Endorsements". Such a section
+Delete any section Entitled “Endorsements”. Such a section
may not be included in the Modified Version.
@item
-Do not retitle any existing section to be Entitled "Endorsements"
+Do not retitle any existing section to be Entitled “Endorsements”
or to conflict in title with any Invariant Section.
@item
@@ -28957,12 +29008,12 @@ If the Modified Version includes new front-matter sections or
appendices that qualify as Secondary Sections and contain no material
copied from the Document, you may at your option designate some or all
of these sections as invariant. To do this, add their titles to the
-list of Invariant Sections in the Modified Version's license notice.
+list of Invariant Sections in the Modified Version’s license notice.
These titles must be distinct from any other section titles.
-You may add a section Entitled "Endorsements", provided it contains
+You may add a section Entitled “Endorsements”, provided it contains
nothing but endorsements of your Modified Version by various
-parties---for example, statements of peer review or that the text has
+parties—for example, statements of peer review or that the text has
been approved by an organization as the authoritative definition of a
standard.
@@ -28998,11 +29049,11 @@ author or publisher of that section if known, or else a unique number.
Make the same adjustment to the section titles in the list of
Invariant Sections in the license notice of the combined work.
-In the combination, you must combine any sections Entitled "History"
+In the combination, you must combine any sections Entitled “History”
in the various original documents, forming one section Entitled
-"History"; likewise combine any sections Entitled "Acknowledgements",
-and any sections Entitled "Dedications". You must delete all sections
-Entitled "Endorsements".
+“History”; likewise combine any sections Entitled “Acknowledgements”,
+and any sections Entitled “Dedications”. You must delete all sections
+Entitled “Endorsements”.
@strong{6. COLLECTIONS OF DOCUMENTS}
@@ -29021,16 +29072,16 @@ other respects regarding verbatim copying of that document.
A compilation of the Document or its derivatives with other separate
and independent documents or works, in or on a volume of a storage or
-distribution medium, is called an "aggregate" if the copyright
+distribution medium, is called an “aggregate” if the copyright
resulting from the compilation is not used to limit the legal rights
-of the compilation's users beyond what the individual works permit.
+of the compilation’s users beyond what the individual works permit.
When the Document is included in an aggregate, this License does not
apply to the other works in the aggregate which are not themselves
derivative works of the Document.
If the Cover Text requirement of section 3 is applicable to these
copies of the Document, then if the Document is less than one half of
-the entire aggregate, the Document's Cover Texts may be placed on
+the entire aggregate, the Document’s Cover Texts may be placed on
covers that bracket the Document within the aggregate, or the
electronic equivalent of covers if the Document is in electronic form.
Otherwise they must appear on printed covers that bracket the whole
@@ -29051,8 +29102,8 @@ of those notices and disclaimers. In case of a disagreement between
the translation and the original version of this License or a notice
or disclaimer, the original version will prevail.
-If a section in the Document is Entitled "Acknowledgements",
-"Dedications", or "History", the requirement (section 4) to Preserve
+If a section in the Document is Entitled “Acknowledgements”,
+“Dedications”, or “History”, the requirement (section 4) to Preserve
its Title (section 1) will typically require changing the actual
title.
@@ -29093,37 +29144,37 @@ differ in detail to address new problems or concerns. See
Each version of the License is given a distinguishing version number.
If the Document specifies that a particular numbered version of this
-License "or any later version" applies to it, you have the option of
+License “or any later version” applies to it, you have the option of
following the terms and conditions either of that specified version or
of any later version that has been published (not as a draft) by the
Free Software Foundation. If the Document does not specify a version
number of this License, you may choose any version ever published (not
as a draft) by the Free Software Foundation. If the Document
specifies that a proxy can decide which future versions of this
-License can be used, that proxy's public statement of acceptance of a
+License can be used, that proxy’s public statement of acceptance of a
version permanently authorizes you to choose that version for the
Document.
@strong{11. RELICENSING}
-"Massive Multiauthor Collaboration Site" (or "MMC Site") means any
+“Massive Multiauthor Collaboration Site” (or “MMC Site”) means any
World Wide Web server that publishes copyrightable works and also
provides prominent facilities for anybody to edit those works. A
public wiki that anybody can edit is an example of such a server. A
-"Massive Multiauthor Collaboration" (or "MMC") contained in the
+“Massive Multiauthor Collaboration” (or “MMC”) contained in the
site means any set of copyrightable works thus published on the MMC
site.
-"CC-BY-SA" means the Creative Commons Attribution-Share Alike 3.0
+“CC-BY-SA” means the Creative Commons Attribution-Share Alike 3.0
license published by Creative Commons Corporation, a not-for-profit
corporation with a principal place of business in San Francisco,
California, as well as future copyleft versions of that license
published by that same organization.
-"Incorporate" means to publish or republish a Document, in whole or
+“Incorporate” means to publish or republish a Document, in whole or
in part, as part of another Document.
-An MMC is "eligible for relicensing" if it is licensed under this
+An MMC is “eligible for relicensing” if it is licensed under this
License, and if all works that were first published under this License
somewhere other than this MMC, and subsequently incorporated in whole
or in part into the MMC, (1) had no cover texts or invariant sections,
@@ -29146,12 +29197,12 @@ Permission is granted to copy, distribute and/or modify this document
under the terms of the GNU Free Documentation License, Version 1.3
or any later version published by the Free Software Foundation;
with no Invariant Sections, no Front-Cover Texts, and no Back-Cover Texts.
-A copy of the license is included in the section entitled "GNU
-Free Documentation License".
+A copy of the license is included in the section entitled “GNU
+Free Documentation License”.
@end quotation
If you have Invariant Sections, Front-Cover Texts and Back-Cover Texts,
-replace the "with ... Texts." line with this:
+replace the “with … Texts.” line with this:
@quotation
@@ -29174,8 +29225,8 @@ to permit their use in free software.
@printindex ge
-@anchor{gnat_ugn/gnat_utility_programs switches-related-to-project-files}@w{ }
@anchor{cf}@w{ }
+@anchor{gnat_ugn/gnat_utility_programs switches-related-to-project-files}@w{ }
@c %**end of body
@bye
diff --git a/gcc/ada/gnatbind.adb b/gcc/ada/gnatbind.adb
index be087af..5cb2df0 100644
--- a/gcc/ada/gnatbind.adb
+++ b/gcc/ada/gnatbind.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/gnatbind.ads b/gcc/ada/gnatbind.ads
index 503ba33..e38f13d 100644
--- a/gcc/ada/gnatbind.ads
+++ b/gcc/ada/gnatbind.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute 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 f98d93a..8f3048c 100644
--- a/gcc/ada/gnatchop.adb
+++ b/gcc/ada/gnatchop.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1998-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1998-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -995,9 +995,8 @@ procedure Gnatchop is
Buffer (Read_Ptr) := EOF;
- -- Comment needed for the following ???
- -- Under what circumstances can the test fail ???
- -- What is copy doing in that case???
+ -- The following test can fail if there was an I/O error, in which case
+ -- Success will be set to False.
if Read_Ptr = Length then
Contents := Buffer;
diff --git a/gcc/ada/gnatclean.adb b/gcc/ada/gnatclean.adb
index 1777967..83b7afb 100644
--- a/gcc/ada/gnatclean.adb
+++ b/gcc/ada/gnatclean.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2003-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2003-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute 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 4e644e3..94da878 100644
--- a/gcc/ada/gnatcmd.adb
+++ b/gcc/ada/gnatcmd.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1996-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1996-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -472,6 +472,15 @@ begin
Program := new String'(Command_List (The_Command).Unixcmd.all);
+ elsif The_Command in Check | Test then
+ Program := new String'(Command_List (The_Command).Unixcmd.all);
+ Find_Program_Name;
+
+ if Name_Len > 5 then
+ First_Switches.Append
+ (new String'
+ ("--target=" & Name_Buffer (1 .. Name_Len - 5)));
+ end if;
else
Program :=
Program_Name (Command_List (The_Command).Unixcmd.all, "gnat");
@@ -481,13 +490,7 @@ begin
-- instead of gnatmake/gnatclean.
-- Ditto for gnatname -> gprname and gnatls -> gprls.
- if The_Command = Make
- or else The_Command = Compile
- or else The_Command = Bind
- or else The_Command = Link
- or else The_Command = Clean
- or else The_Command = Name
- or else The_Command = List
+ if The_Command in Make | Compile | Bind | Link | Clean | Name | List
then
declare
Switch : String_Access;
@@ -588,23 +591,23 @@ begin
end if;
-- For FIND and XREF, look for switch -P. If it is specified, then
- -- report an error indicating that the command is no longer supporting
- -- project files.
+ -- report an error indicating that the command does not support project
+ -- files.
- if The_Command = Find or else The_Command = Xref then
+ if The_Command in Find | Xref then
declare
Argv : String_Access;
begin
for Arg_Num in 1 .. Last_Switches.Last loop
Argv := Last_Switches.Table (Arg_Num);
- if Argv'Length >= 2 and then
- Argv (Argv'First .. Argv'First + 1) = "-P"
+ if Argv'Length >= 2
+ and then Argv (Argv'First .. Argv'First + 1) = "-P"
then
if The_Command = Find then
- Fail ("'gnat find -P' is no longer supported;");
+ Fail ("'gnat find -P' is not supported;");
else
- Fail ("'gnat xref -P' is no longer supported;");
+ Fail ("'gnat xref -P' is not supported;");
end if;
end if;
end loop;
diff --git a/gcc/ada/gnatcmd.ads b/gcc/ada/gnatcmd.ads
index 0808fa1..17683a5 100644
--- a/gcc/ada/gnatcmd.ads
+++ b/gcc/ada/gnatcmd.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1996-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1996-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute 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 2de9373..ce90cc2 100644
--- a/gcc/ada/gnatdll.adb
+++ b/gcc/ada/gnatdll.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1997-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1997-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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,11 +172,8 @@ procedure Gnatdll is
-- Add the files listed in List_Filename (one by line) to the list
-- of file to handle
- Max_Files : constant := 5_000;
- Max_Options : constant := 100;
- -- These are arbitrary limits, a better way will be to use linked list.
- -- No, a better choice would be to use tables ???
- -- Limits on what???
+ Max_Files : constant := 50_000;
+ Max_Options : constant := 1_000;
Ofiles : Argument_List (1 .. Max_Files);
O : Positive := Ofiles'First;
diff --git a/gcc/ada/gnatfind.adb b/gcc/ada/gnatfind.adb
index 27af4db..c3fc25e 100644
--- a/gcc/ada/gnatfind.adb
+++ b/gcc/ada/gnatfind.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1998-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1998-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute 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 5373248..45b2856 100644
--- a/gcc/ada/gnatkr.adb
+++ b/gcc/ada/gnatkr.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute 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 194ad27..d3a5a8d 100644
--- a/gcc/ada/gnatkr.ads
+++ b/gcc/ada/gnatkr.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute 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 def37f3..52e714a 100644
--- a/gcc/ada/gnatlink.adb
+++ b/gcc/ada/gnatlink.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1996-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1996-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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 @@ procedure Gnatlink is
Table_Initial => 20,
Table_Increment => 100,
Table_Name => "Gnatlink.Gcc_Linker_Options");
- -- Comments needed ???
+ -- Options to be passed to the gcc linker
package Libpath is new Table.Table (
Table_Component_Type => Character,
@@ -78,7 +78,7 @@ procedure Gnatlink is
Table_Initial => 4096,
Table_Increment => 100,
Table_Name => "Gnatlink.Libpath");
- -- Comments needed ???
+ -- Library search path
package Linker_Options is new Table.Table (
Table_Component_Type => String_Access,
@@ -87,7 +87,7 @@ procedure Gnatlink is
Table_Initial => 20,
Table_Increment => 100,
Table_Name => "Gnatlink.Linker_Options");
- -- Comments needed ???
+ -- Options to be passed to gnatlink
package Linker_Objects is new Table.Table (
Table_Component_Type => String_Access,
@@ -204,12 +204,45 @@ procedure Gnatlink is
-- Indicates wether libgcc should be statically linked (use 'T') or
-- dynamically linked (use 'H') by default.
+ Link_Max : Integer;
+ pragma Import (C, Link_Max, "__gnat_link_max");
+ -- Maximum number of bytes on the command line supported by the OS
+ -- linker. Passed this limit the response file mechanism must be used
+ -- if supported.
+
+ Run_Path_Option_Ptr : Interfaces.C.Strings.chars_ptr;
+ pragma Import (C, Run_Path_Option_Ptr, "__gnat_run_path_option");
+ -- Pointer to string representing the native linker option which
+ -- specifies the path where the dynamic loader should find shared
+ -- libraries. Equal to null string if this system doesn't support it.
+
+ Libgcc_Subdir_Ptr : Interfaces.C.Strings.chars_ptr;
+ pragma Import (C, Libgcc_Subdir_Ptr, "__gnat_default_libgcc_subdir");
+ -- Pointer to string indicating the installation subdirectory where
+ -- a default shared libgcc might be found.
+
+ Object_Library_Ext_Ptr : Interfaces.C.Strings.chars_ptr;
+ pragma Import
+ (C, Object_Library_Ext_Ptr, "__gnat_object_library_extension");
+ -- Pointer to string specifying the default extension for
+ -- object libraries, e.g. Unix uses ".a".
+
+ Separate_Run_Path_Options : Boolean;
+ for Separate_Run_Path_Options'Size use Character'Size;
+ pragma Import
+ (C, Separate_Run_Path_Options, "__gnat_separate_run_path_options");
+ -- Whether separate rpath options should be emitted for each directory
+
+ function Get_Maximum_File_Name_Length return Integer;
+ pragma Import (C, Get_Maximum_File_Name_Length,
+ "__gnat_get_maximum_file_name_length");
+
function Base_Name (File_Name : String) return String;
-- Return just the file name part without the extension (if present)
procedure Check_Existing_Executable (File_Name : String);
-- Delete any existing executable to avoid accidentally updating the target
- -- of a symbolic link, but produce a Fatail_Error if File_Name matches any
+ -- of a symbolic link, but produce a Fatal_Error if File_Name matches any
-- of the source file names. This avoids overwriting of extensionless
-- source files by accident on systems where executables do not have
-- extensions.
@@ -229,6 +262,19 @@ procedure Gnatlink is
procedure Process_Binder_File (Name : String);
-- Reads the binder file and extracts linker arguments
+ function Index (S, Pattern : String) return Natural;
+ -- Return the last occurrence of Pattern in S, or 0 if none
+
+ procedure Search_Library_Path
+ (Next_Line : String;
+ Nfirst : Integer;
+ Nlast : Integer;
+ Last : Integer;
+ GNAT_Static : Boolean;
+ GNAT_Shared : Boolean);
+ -- Given a Gnat standard library, search the library path to find the
+ -- library location. Parameters are documented in Process_Binder_File.
+
procedure Usage;
-- Display usage
@@ -307,7 +353,6 @@ procedure Gnatlink is
pragma Unreferenced (Status);
begin
Status := unlink (Name'Address);
- -- Is it really right to ignore an error here ???
end Delete;
---------------
@@ -332,6 +377,23 @@ procedure Gnatlink is
Exit_Program (E_Fatal);
end Exit_With_Error;
+ -----------
+ -- Index --
+ -----------
+
+ function Index (S, Pattern : String) return Natural is
+ Len : constant Natural := Pattern'Length;
+
+ begin
+ for J in reverse S'First .. S'Last - Len + 1 loop
+ if Pattern = S (J .. J + Len - 1) then
+ return J;
+ end if;
+ end loop;
+
+ return 0;
+ end Index;
+
------------------
-- Process_Args --
------------------
@@ -362,21 +424,19 @@ procedure Gnatlink is
Arg : constant String := Argument (Next_Arg);
begin
- -- Case of argument which is a switch
-
- -- We definitely need section by section comments here ???
+ -- This argument must not be parsed, just add it to the list of
+ -- linker's options.
if Skip_Next then
- -- This argument must not be parsed, just add it to the
- -- list of linker's options.
-
Skip_Next := False;
Linker_Options.Increment_Last;
Linker_Options.Table (Linker_Options.Last) :=
new String'(Arg);
+ -- Case of argument which is a switch
+
elsif Arg'Length /= 0 and then Arg (1) = '-' then
if Arg'Length > 4 and then Arg (2 .. 5) = "gnat" then
Exit_With_Error
@@ -689,12 +749,6 @@ procedure Gnatlink is
Link_Bytes : Integer := 0;
-- Projected number of bytes for the linker command line
- Link_Max : Integer;
- pragma Import (C, Link_Max, "__gnat_link_max");
- -- Maximum number of bytes on the command line supported by the OS
- -- linker. Passed this limit the response file mechanism must be used
- -- if supported.
-
Next_Line : String (1 .. 1000);
-- Current line value
@@ -752,36 +806,10 @@ procedure Gnatlink is
RB_Nlast : Integer; -- Slice last index
RB_Nfirst : Integer; -- Slice first index
- Run_Path_Option_Ptr : Interfaces.C.Strings.chars_ptr;
- pragma Import (C, Run_Path_Option_Ptr, "__gnat_run_path_option");
- -- Pointer to string representing the native linker option which
- -- specifies the path where the dynamic loader should find shared
- -- libraries. Equal to null string if this system doesn't support it.
-
- Libgcc_Subdir_Ptr : Interfaces.C.Strings.chars_ptr;
- pragma Import (C, Libgcc_Subdir_Ptr, "__gnat_default_libgcc_subdir");
- -- Pointer to string indicating the installation subdirectory where
- -- a default shared libgcc might be found.
-
- Object_Library_Ext_Ptr : Interfaces.C.Strings.chars_ptr;
- pragma Import
- (C, Object_Library_Ext_Ptr, "__gnat_object_library_extension");
- -- Pointer to string specifying the default extension for
- -- object libraries, e.g. Unix uses ".a".
-
- Separate_Run_Path_Options : Boolean;
- for Separate_Run_Path_Options'Size use Character'Size;
- pragma Import
- (C, Separate_Run_Path_Options, "__gnat_separate_run_path_options");
- -- Whether separate rpath options should be emitted for each directory
-
procedure Get_Next_Line;
-- Read the next line from the binder file without the line
-- terminator.
- function Index (S, Pattern : String) return Natural;
- -- Return the last occurrence of Pattern in S, or 0 if none
-
procedure Store_File_Context;
-- Store current file context, Fd position and current line data.
-- The file context is stored into the rollback data above (RB_*).
@@ -823,23 +851,6 @@ procedure Gnatlink is
Nlast := Nlast - 1;
end Get_Next_Line;
- -----------
- -- Index --
- -----------
-
- function Index (S, Pattern : String) return Natural is
- Len : constant Natural := Pattern'Length;
-
- begin
- for J in reverse S'First .. S'Last - Len + 1 loop
- if Pattern = S (J .. J + Len - 1) then
- return J;
- end if;
- end loop;
-
- return 0;
- end Index;
-
---------------------------
-- Rollback_File_Context --
---------------------------
@@ -1003,7 +1014,7 @@ procedure Gnatlink is
Create_Temp_File (Tname_FD, Tname);
-- ??? File descriptor should be checked to not be Invalid_FD.
- -- ??? Status of Write and Close operations should be checked, and
+ -- Status of Write and Close operations should be checked, and
-- failure should occur if a status is wrong.
for J in Objs_Begin .. Objs_End loop
@@ -1115,268 +1126,262 @@ procedure Gnatlink is
Last := Nlast;
end if;
- -- Given a Gnat standard library, search the library path to
- -- find the library location.
+ Search_Library_Path
+ (Next_Line => Next_Line,
+ Nfirst => Nfirst,
+ Nlast => Nlast,
+ Last => Last,
+ GNAT_Static => GNAT_Static,
+ GNAT_Shared => GNAT_Shared);
- -- Shouldn't we abstract a proc here, we are getting awfully
- -- heavily nested ???
+ else
+ Linker_Options.Increment_Last;
+ Linker_Options.Table (Linker_Options.Last) :=
+ new String'(Next_Line (Nfirst .. Nlast));
+ end if;
+ end if;
- declare
- File_Path : String_Access;
+ Xlinker_Was_Previous := Next_Line (Nfirst .. Nlast) = "-Xlinker";
+
+ Get_Next_Line;
+ exit when Next_Line (Nfirst .. Nlast) = End_Info;
+
+ Next_Line (Nfirst .. Nlast - 8) := Next_Line (Nfirst + 8 .. Nlast);
+ Nlast := Nlast - 8;
+ end loop;
+ end if;
+
+ -- If -shared was specified, invoke gcc with -shared-libgcc
+
+ if GNAT_Shared then
+ Linker_Options.Increment_Last;
+ Linker_Options.Table (Linker_Options.Last) := Shared_Libgcc;
+ end if;
- Object_Lib_Extension : constant String :=
- Value (Object_Library_Ext_Ptr);
+ Status := fclose (Fd);
+ end Process_Binder_File;
+
+ -------------------------
+ -- Search_Library_Path --
+ -------------------------
+
+ procedure Search_Library_Path
+ (Next_Line : String;
+ Nfirst : Integer;
+ Nlast : Integer;
+ Last : Integer;
+ GNAT_Static : Boolean;
+ GNAT_Shared : Boolean)
+ is
+ File_Path : String_Access;
- File_Name : constant String := "lib" &
- Next_Line (Nfirst + 2 .. Last) & Object_Lib_Extension;
+ Object_Lib_Extension : constant String :=
+ Value (Object_Library_Ext_Ptr);
- Run_Path_Opt : constant String :=
- Value (Run_Path_Option_Ptr);
+ File_Name : constant String := "lib" &
+ Next_Line (Nfirst + 2 .. Last) & Object_Lib_Extension;
- GCC_Index : Natural;
- Run_Path_Opt_Index : Natural := 0;
+ Run_Path_Opt : constant String :=
+ Value (Run_Path_Option_Ptr);
+
+ GCC_Index : Natural;
+ Run_Path_Opt_Index : Natural := 0;
+
+ begin
+ File_Path :=
+ Locate_Regular_File (File_Name,
+ String (Libpath.Table (1 .. Libpath.Last)));
+
+ if File_Path /= null then
+ if GNAT_Static then
+
+ -- If static gnatlib found, explicitly specify to overcome
+ -- possible linker default usage of shared version.
+
+ Linker_Options.Increment_Last;
+
+ Linker_Options.Table (Linker_Options.Last) :=
+ new String'(File_Path.all);
+
+ elsif GNAT_Shared then
+ if Opt.Run_Path_Option then
+
+ -- If shared gnatlib desired, add appropriate system specific
+ -- switch so that it can be located at runtime.
+
+ if Run_Path_Opt'Length /= 0 then
+
+ -- Output the system specific linker command that allows the
+ -- image activator to find the shared library at
+ -- runtime. Also add path to find libgcc_s.so, if relevant.
+
+ declare
+ Path : String (1 .. File_Path'Length + 15);
+
+ Path_Last : constant Natural := File_Path'Length;
begin
- File_Path :=
- Locate_Regular_File (File_Name,
- String (Libpath.Table (1 .. Libpath.Last)));
+ Path (1 .. File_Path'Length) := File_Path.all;
- if File_Path /= null then
- if GNAT_Static then
+ -- To find the location of the shared version of libgcc, we
+ -- look for "gcc-lib" in the path of the library. However,
+ -- this subdirectory is no longer present in recent versions
+ -- of GCC. So, we look for the last subdirectory "lib" in
+ -- the path.
- -- If static gnatlib found, explicitly specify to
- -- overcome possible linker default usage of shared
- -- version.
+ GCC_Index := Index (Path (1 .. Path_Last), "gcc-lib");
- Linker_Options.Increment_Last;
+ if GCC_Index /= 0 then
- Linker_Options.Table (Linker_Options.Last) :=
- new String'(File_Path.all);
-
- elsif GNAT_Shared then
- if Opt.Run_Path_Option then
-
- -- If shared gnatlib desired, add appropriate
- -- system specific switch so that it can be
- -- located at runtime.
-
- if Run_Path_Opt'Length /= 0 then
-
- -- Output the system specific linker command
- -- that allows the image activator to find
- -- the shared library at runtime. Also add
- -- path to find libgcc_s.so, if relevant.
-
- declare
- Path : String (1 .. File_Path'Length + 15);
-
- Path_Last : constant Natural :=
- File_Path'Length;
-
- begin
- Path (1 .. File_Path'Length) :=
- File_Path.all;
-
- -- To find the location of the shared version
- -- of libgcc, we look for "gcc-lib" in the
- -- path of the library. However, this
- -- subdirectory is no longer present in
- -- recent versions of GCC. So, we look for
- -- the last subdirectory "lib" in the path.
-
- GCC_Index :=
- Index (Path (1 .. Path_Last), "gcc-lib");
-
- if GCC_Index /= 0 then
-
- -- The shared version of libgcc is
- -- located in the parent directory.
-
- GCC_Index := GCC_Index - 1;
-
- else
- GCC_Index :=
- Index
- (Path (1 .. Path_Last),
- "/lib/");
-
- if GCC_Index = 0 then
- GCC_Index :=
- Index (Path (1 .. Path_Last),
- Directory_Separator & "lib"
- & Directory_Separator);
- end if;
-
- -- If we have found a "lib" subdir in
- -- the path to libgnat, the possible
- -- shared libgcc of interest by default
- -- is in libgcc_subdir at the same
- -- level.
-
- if GCC_Index /= 0 then
- declare
- Subdir : constant String :=
- Value (Libgcc_Subdir_Ptr);
- begin
- Path
- (GCC_Index + 1 ..
- GCC_Index + Subdir'Length) :=
- Subdir;
- GCC_Index :=
- GCC_Index + Subdir'Length;
- end;
- end if;
- end if;
-
- -- Look for an eventual run_path_option in
- -- the linker switches.
-
- if Separate_Run_Path_Options then
- Linker_Options.Increment_Last;
- Linker_Options.Table
- (Linker_Options.Last) :=
- new String'
- (Run_Path_Opt
- & File_Path
- (1 .. File_Path'Length
- - File_Name'Length));
-
- if GCC_Index /= 0 then
- Linker_Options.Increment_Last;
- Linker_Options.Table
- (Linker_Options.Last) :=
- new String'
- (Run_Path_Opt
- & Path (1 .. GCC_Index));
- end if;
-
- else
- for J in reverse
- 1 .. Linker_Options.Last
- loop
- if Linker_Options.Table (J) /= null
- and then
- Linker_Options.Table (J)'Length
- > Run_Path_Opt'Length
- and then
- Linker_Options.Table (J)
- (1 .. Run_Path_Opt'Length) =
- Run_Path_Opt
- then
- -- We have found an already
- -- specified run_path_option:
- -- we will add to this
- -- switch, because only one
- -- run_path_option should be
- -- specified.
-
- Run_Path_Opt_Index := J;
- exit;
- end if;
- end loop;
-
- -- If there is no run_path_option, we
- -- need to add one.
-
- if Run_Path_Opt_Index = 0 then
- Linker_Options.Increment_Last;
- end if;
-
- if GCC_Index = 0 then
- if Run_Path_Opt_Index = 0 then
- Linker_Options.Table
- (Linker_Options.Last) :=
- new String'
- (Run_Path_Opt
- & File_Path
- (1 .. File_Path'Length
- - File_Name'Length));
-
- else
- Linker_Options.Table
- (Run_Path_Opt_Index) :=
- new String'
- (Linker_Options.Table
- (Run_Path_Opt_Index).all
- & Path_Separator
- & File_Path
- (1 .. File_Path'Length
- - File_Name'Length));
- end if;
-
- else
- if Run_Path_Opt_Index = 0 then
- Linker_Options.Table
- (Linker_Options.Last) :=
- new String'
- (Run_Path_Opt
- & File_Path
- (1 .. File_Path'Length
- - File_Name'Length)
- & Path_Separator
- & Path (1 .. GCC_Index));
-
- else
- Linker_Options.Table
- (Run_Path_Opt_Index) :=
- new String'
- (Linker_Options.Table
- (Run_Path_Opt_Index).all
- & Path_Separator
- & File_Path
- (1 .. File_Path'Length
- - File_Name'Length)
- & Path_Separator
- & Path (1 .. GCC_Index));
- end if;
- end if;
- end if;
- end;
- end if;
- end if;
+ -- The shared version of libgcc is located in the
+ -- parent directory.
- -- Then we add the appropriate -l switch
+ GCC_Index := GCC_Index - 1;
+ else
+ GCC_Index := Index (Path (1 .. Path_Last), "/lib/");
+
+ if GCC_Index = 0 then
+ GCC_Index :=
+ Index (Path (1 .. Path_Last),
+ Directory_Separator & "lib"
+ & Directory_Separator);
+ end if;
+
+ -- If we have found a "lib" subdir in the path to
+ -- libgnat, the possible shared libgcc of interest by
+ -- default is in libgcc_subdir at the same level.
+
+ if GCC_Index /= 0 then
+ declare
+ Subdir : constant String :=
+ Value (Libgcc_Subdir_Ptr);
+
+ begin
+ Path (GCC_Index + 1 .. GCC_Index + Subdir'Length)
+ := Subdir;
+ GCC_Index := GCC_Index + Subdir'Length;
+ end;
+ end if;
+ end if;
+
+ -- Look for an eventual run_path_option in
+ -- the linker switches.
+
+ if Separate_Run_Path_Options then
+ Linker_Options.Increment_Last;
+ Linker_Options.Table
+ (Linker_Options.Last) :=
+ new String'
+ (Run_Path_Opt
+ & File_Path
+ (1 .. File_Path'Length
+ - File_Name'Length));
+
+ if GCC_Index /= 0 then
Linker_Options.Increment_Last;
Linker_Options.Table (Linker_Options.Last) :=
- new String'(Next_Line (Nfirst .. Nlast));
+ new String'
+ (Run_Path_Opt
+ & Path (1 .. GCC_Index));
end if;
else
- -- If gnatlib library not found, then add it anyway in
- -- case some other mechanism may find it.
+ for J in reverse 1 .. Linker_Options.Last loop
+ if Linker_Options.Table (J) /= null
+ and then
+ Linker_Options.Table (J)'Length
+ > Run_Path_Opt'Length
+ and then
+ Linker_Options.Table (J)
+ (1 .. Run_Path_Opt'Length) =
+ Run_Path_Opt
+ then
+ -- We have found an already specified
+ -- run_path_option: we will add to this switch,
+ -- because only one run_path_option should be
+ -- specified.
- Linker_Options.Increment_Last;
- Linker_Options.Table (Linker_Options.Last) :=
- new String'(Next_Line (Nfirst .. Nlast));
+ Run_Path_Opt_Index := J;
+ exit;
+ end if;
+ end loop;
+
+ -- If there is no run_path_option, we need to add one.
+
+ if Run_Path_Opt_Index = 0 then
+ Linker_Options.Increment_Last;
+ end if;
+
+ if GCC_Index = 0 then
+ if Run_Path_Opt_Index = 0 then
+ Linker_Options.Table
+ (Linker_Options.Last) :=
+ new String'
+ (Run_Path_Opt
+ & File_Path
+ (1 .. File_Path'Length
+ - File_Name'Length));
+
+ else
+ Linker_Options.Table
+ (Run_Path_Opt_Index) :=
+ new String'
+ (Linker_Options.Table
+ (Run_Path_Opt_Index).all
+ & Path_Separator
+ & File_Path
+ (1 .. File_Path'Length
+ - File_Name'Length));
+ end if;
+
+ else
+ if Run_Path_Opt_Index = 0 then
+ Linker_Options.Table
+ (Linker_Options.Last) :=
+ new String'
+ (Run_Path_Opt
+ & File_Path
+ (1 .. File_Path'Length
+ - File_Name'Length)
+ & Path_Separator
+ & Path (1 .. GCC_Index));
+
+ else
+ Linker_Options.Table
+ (Run_Path_Opt_Index) :=
+ new String'
+ (Linker_Options.Table
+ (Run_Path_Opt_Index).all
+ & Path_Separator
+ & File_Path
+ (1 .. File_Path'Length
+ - File_Name'Length)
+ & Path_Separator
+ & Path (1 .. GCC_Index));
+ end if;
+ end if;
end if;
end;
- else
- Linker_Options.Increment_Last;
- Linker_Options.Table (Linker_Options.Last) :=
- new String'(Next_Line (Nfirst .. Nlast));
end if;
end if;
- Xlinker_Was_Previous := Next_Line (Nfirst .. Nlast) = "-Xlinker";
-
- Get_Next_Line;
- exit when Next_Line (Nfirst .. Nlast) = End_Info;
+ -- Then we add the appropriate -l switch
- Next_Line (Nfirst .. Nlast - 8) := Next_Line (Nfirst + 8 .. Nlast);
- Nlast := Nlast - 8;
- end loop;
- end if;
+ Linker_Options.Increment_Last;
+ Linker_Options.Table (Linker_Options.Last) :=
+ new String'(Next_Line (Nfirst .. Nlast));
+ end if;
- -- If -shared was specified, invoke gcc with -shared-libgcc
+ else
+ -- If gnatlib library not found, then add it anyway in
+ -- case some other mechanism may find it.
- if GNAT_Shared then
Linker_Options.Increment_Last;
- Linker_Options.Table (Linker_Options.Last) := Shared_Libgcc;
+ Linker_Options.Table (Linker_Options.Last) :=
+ new String'(Next_Line (Nfirst .. Nlast));
end if;
-
- Status := fclose (Fd);
- end Process_Binder_File;
+ end Search_Library_Path;
-----------
-- Usage --
@@ -1748,10 +1753,6 @@ begin
Fname : constant String := Base_Name (Ali_File_Name.all);
Fname_Len : Integer := Fname'Length;
- function Get_Maximum_File_Name_Length return Integer;
- pragma Import (C, Get_Maximum_File_Name_Length,
- "__gnat_get_maximum_file_name_length");
-
Maximum_File_Name_Length : constant Integer :=
Get_Maximum_File_Name_Length;
diff --git a/gcc/ada/gnatlink.ads b/gcc/ada/gnatlink.ads
index ed6d513..e0cadc7 100644
--- a/gcc/ada/gnatlink.ads
+++ b/gcc/ada/gnatlink.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1996-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1996-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute 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 3fa00eb..353e36d 100644
--- a/gcc/ada/gnatls.adb
+++ b/gcc/ada/gnatls.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute 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 5afb1f5..9148638 100644
--- a/gcc/ada/gnatls.ads
+++ b/gcc/ada/gnatls.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute 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 fe41ea1..105ab56 100644
--- a/gcc/ada/gnatmake.adb
+++ b/gcc/ada/gnatmake.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute 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 a197de7..f6ac952 100644
--- a/gcc/ada/gnatmake.ads
+++ b/gcc/ada/gnatmake.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute 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 cf5afd9..e1c3419 100644
--- a/gcc/ada/gnatname.adb
+++ b/gcc/ada/gnatname.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2001-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2001-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute 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.ads b/gcc/ada/gnatname.ads
index 7cbcd3b..cc74eae 100644
--- a/gcc/ada/gnatname.ads
+++ b/gcc/ada/gnatname.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2001-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2001-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute 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 926d148..e2efbb9 100644
--- a/gcc/ada/gnatprep.adb
+++ b/gcc/ada/gnatprep.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1996-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1996-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute 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 a2357d9..eff7a9e 100644
--- a/gcc/ada/gnatprep.ads
+++ b/gcc/ada/gnatprep.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute 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 e918540..d585c64 100644
--- a/gcc/ada/gnatvsn.adb
+++ b/gcc/ada/gnatvsn.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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,12 +48,11 @@ package body Gnatvsn is
end Gnat_Free_Software;
type char_array is array (Natural range <>) of aliased Character;
- Version_String : char_array (0 .. Ver_Len_Max - 1);
- -- Import the C string defined in the (language-independent) source file
- -- version.c using the zero-based convention of the C language.
- -- The size is not the real one, which does not matter since we will
- -- check for the nul character in Gnat_Version_String.
- pragma Import (C, Version_String, "version_string");
+ C_Version_String : char_array (0 .. Ver_Len_Max - 1);
+ pragma Import (C, C_Version_String, "gnat_version_string");
+ -- Import the C string defined in the source file version.c using the
+ -- zero-based convention of the C language. The size is not the real
+ -- one, which does not matter since we will check for the nul character.
-------------------------
-- Gnat_Version_String --
@@ -64,9 +63,9 @@ package body Gnatvsn is
Pos : Natural := 0;
begin
loop
- exit when Version_String (Pos) = ASCII.NUL;
+ exit when C_Version_String (Pos) = ASCII.NUL;
- S (Pos + 1) := Version_String (Pos);
+ S (Pos + 1) := C_Version_String (Pos);
Pos := Pos + 1;
exit when Pos = Ver_Len_Max;
diff --git a/gcc/ada/gnatvsn.ads b/gcc/ada/gnatvsn.ads
index bbfa9f5..d3678eb 100644
--- a/gcc/ada/gnatvsn.ads
+++ b/gcc/ada/gnatvsn.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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 @@ package Gnatvsn is
-- Static string identifying this version, that can be used as an argument
-- to e.g. pragma Ident.
- Library_Version : constant String := "11";
+ Library_Version : constant String := "12";
-- 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 7b7a4db..9a3935c 100644
--- a/gcc/ada/gnatxref.adb
+++ b/gcc/ada/gnatxref.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1998-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1998-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute 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 5ad1094..094756b 100644
--- a/gcc/ada/gprep.adb
+++ b/gcc/ada/gprep.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2002-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2002-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute 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 efc8c52..7cc0a51 100644
--- a/gcc/ada/gprep.ads
+++ b/gcc/ada/gprep.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2002-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2002-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute 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 ba51fb1..a987594 100644
--- a/gcc/ada/gsocket.h
+++ b/gcc/ada/gsocket.h
@@ -6,7 +6,7 @@
* *
* C Header File *
* *
- * Copyright (C) 2004-2020, Free Software Foundation, Inc. *
+ * Copyright (C) 2004-2021, Free Software Foundation, Inc. *
* *
* GNAT is free software; you can redistribute it and/or modify it under *
* terms of the GNU General Public License as published by the Free Soft- *
@@ -215,6 +215,7 @@
#if !(defined (VMS) || defined (__MINGW32__))
#include <sys/socket.h>
#include <sys/un.h>
+#include <net/if.h>
#include <netinet/in.h>
#include <netinet/tcp.h>
#include <sys/ioctl.h>
diff --git a/gcc/ada/hostparm.ads b/gcc/ada/hostparm.ads
index 603f401..4d128cc 100644
--- a/gcc/ada/hostparm.ads
+++ b/gcc/ada/hostparm.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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,9 +56,10 @@ package Hostparm is
-- of file names in the library, must be at least Max_Line_Length, but
-- can be larger.
- Tag_Errors : constant Boolean := False;
+ Tag_Errors : constant Boolean := True;
-- If set to true, then brief form error messages will be prefaced by
- -- the string "error:". Used as default for Opt.Unique_Error_Tag.
+ -- the string "error:". Used as default for Opt.Unique_Error_Tag. Disabled
+ -- by gnatd_U.
Exclude_Missing_Objects : constant Boolean := True;
-- If set to true, gnatbind will exclude from consideration all
diff --git a/gcc/ada/impunit.adb b/gcc/ada/impunit.adb
index e7262cd..b99f3fd 100644
--- a/gcc/ada/impunit.adb
+++ b/gcc/ada/impunit.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2000-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2000-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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,14 +23,14 @@
-- --
------------------------------------------------------------------------------
-with Atree; use Atree;
-with Errout; use Errout;
-with Sinfo; use Sinfo;
-with Fname.UF; use Fname.UF;
-with Lib; use Lib;
-with Namet; use Namet;
-with Opt; use Opt;
-with Uname; use Uname;
+with Errout; use Errout;
+with Sinfo; use Sinfo;
+with Sinfo.Nodes; use Sinfo.Nodes;
+with Fname.UF; use Fname.UF;
+with Lib; use Lib;
+with Namet; use Namet;
+with Opt; use Opt;
+with Uname; use Uname;
-- Note: this package body is used by GNAT Studio and GNATBench to supply a
-- list of entries for help on available library routines.
@@ -618,12 +618,12 @@ package body Impunit is
); -- GNATCOLL.OMP
--------------------
- -- Ada 202X Units --
+ -- Ada 2022 Units --
--------------------
- -- The following units should be used only in Ada 202X mode
+ -- The following units should be used only in Ada 2022 mode
- Non_Imp_File_Names_2X : constant File_List := (
+ Non_Imp_File_Names_22 : constant File_List := (
("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
@@ -632,16 +632,20 @@ package body Impunit is
("s-aotase", T), -- System.Atomic_Operations.Test_And_Set
("s-atoope", T), -- System.Atomic_Operations
("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-sttebu", T), -- Ada.Strings.Text_Buffers
+ ("a-stbuun", T), -- Ada.Strings.Text_Buffers.Unbounded
+ ("a-stbubo", T), -- Ada.Strings.Text_Buffers.Bounded
("a-strsto", T), -- Ada.Streams.Storage
("a-ststbo", T), -- Ada.Streams.Storage.Bounded
- ("a-ststun", T) -- Ada.Streams.Storage.Unbounded
+ ("a-ststun", T), -- Ada.Streams.Storage.Unbounded
+
+ ----------------------------------------
+ -- GNAT Defined Additions to Ada 2022 --
+ ----------------------------------------
+
+ ("a-stbufi", T), -- Ada.Strings.Text_Buffers.Files
+ ("a-stbufo", T), -- Ada.Strings.Text_Buffers.Formatting
+ ("a-stbuut", T) -- Ada.Strings.Text_Buffers.Utils
);
-----------------------
@@ -767,11 +771,11 @@ package body Impunit is
end if;
end loop;
- -- See if name is in 202X list
+ -- See if name is in 2022 list
- for J in Non_Imp_File_Names_2X'Range loop
- if Buffer (1 .. 8) = Non_Imp_File_Names_2X (J).Fname then
- return Ada_202X_Unit;
+ for J in Non_Imp_File_Names_22'Range loop
+ if Buffer (1 .. 8) = Non_Imp_File_Names_22 (J).Fname then
+ return Ada_2022_Unit;
end if;
end loop;
diff --git a/gcc/ada/impunit.ads b/gcc/ada/impunit.ads
index 7ed5c3a..7caa1ba 100644
--- a/gcc/ada/impunit.ads
+++ b/gcc/ada/impunit.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2000-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2000-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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,7 @@ package Impunit is
Ada_95_Unit,
Ada_2005_Unit,
Ada_2012_Unit,
- Ada_202X_Unit);
+ Ada_2022_Unit);
-- This unit is defined in the Ada RM of the given year. This is used to
-- give a warning when withing a unit from a wrong mode (e.g. withing an
-- Ada_2012_Unit when compiling with -gnat95). Note that in Ada 83 mode,
diff --git a/gcc/ada/indepsw-aix.adb b/gcc/ada/indepsw-aix.adb
index 21a4c17..078097a 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2009-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute 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 9da4f87..daa9c95 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2011-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute 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 de219b6..f624417 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2009-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute 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 d21bcfe..ad2bf5e 100644
--- a/gcc/ada/indepsw.adb
+++ b/gcc/ada/indepsw.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2009-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2009-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute 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 2fc13cb..8485df0 100644
--- a/gcc/ada/indepsw.ads
+++ b/gcc/ada/indepsw.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2004-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute 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 3ceb1a3..c48e244 100644
--- a/gcc/ada/init.c
+++ b/gcc/ada/init.c
@@ -6,7 +6,7 @@
* *
* C Implementation File *
* *
- * Copyright (C) 1992-2020, Free Software Foundation, Inc. *
+ * Copyright (C) 1992-2021, Free Software Foundation, Inc. *
* *
* GNAT is 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,7 +78,7 @@
extern "C" {
#endif
-extern void __gnat_raise_program_error (const char *, int);
+extern void __gnat_raise_program_error (const void *, int);
/* Addresses of exception data blocks for predefined exceptions. Tasking_Error
is not used in this unit, and the abort signal is only used on IRIX.
@@ -89,17 +89,16 @@ extern struct Exception_Data program_error;
extern struct Exception_Data storage_error;
/* For the Cert run time we use the regular raise exception routine because
- Raise_From_Signal_Handler is not available. */
+ __gnat_raise_from_signal_handler is not available. */
#ifdef CERT
-#define Raise_From_Signal_Handler \
- __gnat_raise_exception
-extern void Raise_From_Signal_Handler (struct Exception_Data *, const char *);
+#define Raise_From_Signal_Handler __gnat_raise_exception
#else
-#define Raise_From_Signal_Handler \
- ada__exceptions__raise_from_signal_handler
-extern void Raise_From_Signal_Handler (struct Exception_Data *, const char *);
+#define Raise_From_Signal_Handler __gnat_raise_from_signal_handler
#endif
+extern void Raise_From_Signal_Handler (struct Exception_Data *, const void *)
+ ATTRIBUTE_NORETURN;
+
/* Global values computed by the binder. Note that these variables are
declared here, not in the binder file, to avoid having unresolved
references in the shared libgnat. */
@@ -1990,7 +1989,7 @@ __gnat_error_handler (int sig, siginfo_t *si, void *sc)
anything else.
This mechanism is only need in kernel mode. */
#if !(defined (__RTP__) || defined (VTHREADS)) && ((CPU == PPCE500V2) || (CPU == PPC85XX))
- register unsigned msr;
+ unsigned msr;
/* Read the MSR value */
asm volatile ("mfmsr %0" : "=r" (msr));
/* Force the SPE bit if not set. */
@@ -2749,11 +2748,7 @@ __gnat_install_handler (void)
/* __gnat_init_float */
/*********************/
-/* This routine is called as each process thread is created, for possible
- initialization of the FP processor. This version is used under INTERIX
- and WIN32. */
-
-#if defined (_WIN32) || defined (__INTERIX) \
+#if defined (_WIN32) || defined (__INTERIX) || defined (__linux__) \
|| defined (__Lynx__) || defined(__NetBSD__) || defined(__FreeBSD__) \
|| defined (__OpenBSD__) || defined (__DragonFly__) || defined(__QNX__)
@@ -2763,13 +2758,10 @@ void
__gnat_init_float (void)
{
#if defined (__i386__) || defined (__x86_64__)
-
- /* This is used to properly initialize the FPU on an x86 for each
- process thread. */
-
+ /* This is used to properly initialize the FPU to 64-bit precision on an x86
+ for each process thread and also for floating-point I/O. */
asm ("finit");
-
-#endif /* Defined __i386__ */
+#endif
}
#endif
diff --git a/gcc/ada/initialize.c b/gcc/ada/initialize.c
index 7235af8..6bed668 100644
--- a/gcc/ada/initialize.c
+++ b/gcc/ada/initialize.c
@@ -6,7 +6,7 @@
* *
* C Implementation File *
* *
- * Copyright (C) 1992-2020, Free Software Foundation, Inc. *
+ * Copyright (C) 1992-2021, Free Software Foundation, Inc. *
* *
* GNAT is 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,29 +29,19 @@
* *
****************************************************************************/
-/* This unit provides default implementation for __gnat_initialize ()
- which is called before the elaboration of the partition. It is provided
- in a separate file/object so that users can replace it easily.
- The default implementation should be null on most targets. */
-
-/* The following include is here to meet the published VxWorks requirement
- that the __vxworks header appear before any other include. */
-#ifdef __vxworks
-#include "vxWorks.h"
-#endif
+/* This unit provides the default implementation of __gnat_initialize, which
+ is called before the elaboration of the partition. It is provided in a
+ separate file so that users can replace it easily. But the implementation
+ should be empty on most targets. */
#ifdef IN_RTS
#include "runtime.h"
-/* We don't have libiberty, so use malloc. */
-#define xmalloc(S) malloc (S)
-#define xrealloc(V,S) realloc (V,S)
#else
#include "config.h"
#include "system.h"
#endif
#include "raise.h"
-#include <fcntl.h>
#ifdef __cplusplus
extern "C" {
@@ -63,65 +53,16 @@ extern "C" {
#if defined (__MINGW32__)
-extern void __gnat_install_SEH_handler (void *);
-
void
-__gnat_initialize (void *eh ATTRIBUTE_UNUSED)
+__gnat_initialize (void *eh)
{
- /* Note that we do not activate this for the compiler itself to avoid a
- bootstrap path problem. Older version of gnatbind will generate a call
- to __gnat_initialize() without argument. Therefore we cannot use eh in
- this case. It will be possible to remove the following #ifdef at some
- point. */
-#ifdef IN_RTS
/* Install the Structured Exception handler. */
if (eh)
__gnat_install_SEH_handler (eh);
-#endif
-}
-
-/******************************************/
-/* __gnat_initialize (init_float version) */
-/******************************************/
-
-#elif defined (__Lynx__) || defined (__FreeBSD__) || defined(__NetBSD__) \
- || defined (__OpenBSD__) || defined (__DragonFly__)
-
-void
-__gnat_initialize (void *eh ATTRIBUTE_UNUSED)
-{
-}
-
-/***************************************/
-/* __gnat_initialize (VxWorks Version) */
-/***************************************/
-
-#elif defined(__vxworks)
-
-void
-__gnat_initialize (void *eh)
-{
-}
-
-#elif defined(_T_HPUX10) || (!defined(IN_RTS) && defined(_X_HPUX10))
-
-/************************************************/
-/* __gnat_initialize (PA-RISC HP-UX 10 Version) */
-/************************************************/
-
-extern void __main (void);
-
-void
-__gnat_initialize (void *eh ATTRIBUTE_UNUSED)
-{
- __main ();
}
#else
-/* For all other versions of GNAT, the initialize routine and handler
- installation do nothing */
-
/***************************************/
/* __gnat_initialize (Default Version) */
/***************************************/
@@ -130,6 +71,7 @@ void
__gnat_initialize (void *eh ATTRIBUTE_UNUSED)
{
}
+
#endif
#ifdef __cplusplus
diff --git a/gcc/ada/inline.adb b/gcc/ada/inline.adb
index bb4d97c..6c330b2 100644
--- a/gcc/ada/inline.adb
+++ b/gcc/ada/inline.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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,39 +24,43 @@
------------------------------------------------------------------------------
with Alloc;
-with Aspects; use Aspects;
-with Atree; use Atree;
-with Debug; use Debug;
-with Einfo; use Einfo;
-with Elists; use Elists;
-with Errout; use Errout;
-with Expander; use Expander;
-with Exp_Ch6; use Exp_Ch6;
-with Exp_Ch7; use Exp_Ch7;
-with Exp_Tss; use Exp_Tss;
-with Exp_Util; use Exp_Util;
-with Fname; use Fname;
-with Fname.UF; use Fname.UF;
-with Lib; use Lib;
-with Namet; use Namet;
-with Nmake; use Nmake;
-with Nlists; use Nlists;
-with Output; use Output;
-with Sem_Aux; use Sem_Aux;
-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;
-with Snames; use Snames;
-with Stand; use Stand;
+with Aspects; use Aspects;
+with Atree; use Atree;
+with Debug; use Debug;
+with Einfo; use Einfo;
+with Einfo.Entities; use Einfo.Entities;
+with Einfo.Utils; use Einfo.Utils;
+with Elists; use Elists;
+with Errout; use Errout;
+with Expander; use Expander;
+with Exp_Ch6; use Exp_Ch6;
+with Exp_Ch7; use Exp_Ch7;
+with Exp_Tss; use Exp_Tss;
+with Exp_Util; use Exp_Util;
+with Fname; use Fname;
+with Fname.UF; use Fname.UF;
+with Lib; use Lib;
+with Namet; use Namet;
+with Nmake; use Nmake;
+with Nlists; use Nlists;
+with Output; use Output;
+with Sem_Aux; use Sem_Aux;
+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 Sinfo.Nodes; use Sinfo.Nodes;
+with Sinfo.Utils; use Sinfo.Utils;
+with Sinput; use Sinput;
+with Snames; use Snames;
+with Stand; use Stand;
with Table;
-with Tbuild; use Tbuild;
-with Uintp; use Uintp;
-with Uname; use Uname;
+with Tbuild; use Tbuild;
+with Uintp; use Uintp;
+with Uname; use Uname;
with GNAT.HTable;
@@ -1451,7 +1455,7 @@ package body Inline is
-- Skip inlining if the function returns an unconstrained type
-- using an extended return statement, since this part of the
-- new inlining model is not yet supported by the current
- -- implementation. ???
+ -- implementation.
or else (Returns_Unconstrained_Type (Spec_Id)
and then Has_Extended_Return)
@@ -1469,7 +1473,7 @@ package body Inline is
end if;
Set_Body_To_Inline (Decl, Original_Body);
- Set_Ekind (Defining_Entity (Original_Body), Ekind (Spec_Id));
+ Mutate_Ekind (Defining_Entity (Original_Body), Ekind (Spec_Id));
Set_Is_Inlined (Spec_Id);
end Build_Body_To_Inline;
@@ -1531,7 +1535,6 @@ package body Inline is
function Is_Unit_Subprogram (Id : Entity_Id) return Boolean;
-- Return True if subprogram Id defines a compilation unit
- -- Shouldn't this be in Sem_Aux???
function In_Package_Spec (Id : Entity_Id) return Boolean;
-- Return True if subprogram Id is defined in the package specification,
@@ -2161,10 +2164,7 @@ package body Inline is
Body_To_Inline :=
Copy_Generic_Node (N, Empty, Instantiating => True);
else
- -- ??? Shouldn't this use New_Copy_Tree? What about global
- -- references captured in the body to inline?
-
- Body_To_Inline := Copy_Separate_Tree (N);
+ Body_To_Inline := New_Copy_Tree (N);
end if;
-- Remove aspects/pragmas that have no meaning in an inlined body
@@ -2251,7 +2251,7 @@ package body Inline is
pragma Assert (No (Body_To_Inline (Decl)));
Set_Body_To_Inline (Decl, Original_Body);
- Set_Ekind (Defining_Entity (Original_Body), Ekind (Spec_Id));
+ Mutate_Ekind (Defining_Entity (Original_Body), Ekind (Spec_Id));
end Build_Body_To_Inline;
--------------------------------
@@ -2827,7 +2827,7 @@ package body Inline is
-------------------------
function Formal_Is_Used_Once (Formal : Entity_Id) return Boolean is
- Use_Counter : Int := 0;
+ Use_Counter : Nat := 0;
function Count_Uses (N : Node_Id) return Traverse_Result;
-- Traverse the tree and count the uses of the formal parameter.
@@ -2856,13 +2856,10 @@ package body Inline is
then
Use_Counter := Use_Counter + 1;
- if Use_Counter > 1 then
-
- -- Denote more than one use and abandon the traversal
+ -- If this is a second use then abandon the traversal
- Use_Counter := 2;
+ if Use_Counter > 1 then
return Abandon;
-
end if;
end if;
@@ -3011,10 +3008,7 @@ package body Inline is
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)));
+ New_A := Unchecked_Convert_To (Etype (F), Expression (A));
-- In GNATprove mode, keep the most precise type of the actual for
-- the temporary variable, when the formal type is unconstrained.
@@ -3557,7 +3551,6 @@ package body Inline is
procedure Reset_Dispatching_Calls (N : Node_Id) is
function Do_Reset (N : Node_Id) return Traverse_Result;
- -- Comment required ???
--------------
-- Do_Reset --
@@ -3578,17 +3571,10 @@ package body Inline is
return OK;
end Do_Reset;
- function Do_Reset_Calls is new Traverse_Func (Do_Reset);
-
- -- Local variables
-
- Dummy : constant Traverse_Result := Do_Reset_Calls (N);
- pragma Unreferenced (Dummy);
-
- -- Start of processing for Reset_Dispatching_Calls
+ procedure Do_Reset_Calls is new Traverse_Proc (Do_Reset);
begin
- null;
+ Do_Reset_Calls (N);
end Reset_Dispatching_Calls;
---------------------------
@@ -3630,7 +3616,6 @@ package body Inline is
-- If the context is an assignment, and the left-hand side is free of
-- side-effects, the replacement is also safe.
- -- Can this be generalized further???
elsif Nkind (Parent (N)) = N_Assignment_Statement
and then
@@ -4821,7 +4806,7 @@ package body Inline is
end if;
end Instantiate_Body;
- J, K : Nat;
+ J, K : Nat;
Info : Pending_Body_Info;
-- Start of processing for Instantiate_Bodies
@@ -5168,17 +5153,12 @@ package body Inline is
--------------------------
procedure Remove_Dead_Instance (N : Node_Id) is
- J : Int;
-
begin
- J := 0;
- while J <= Pending_Instantiations.Last loop
+ for J in 0 .. Pending_Instantiations.Last loop
if Pending_Instantiations.Table (J).Inst_Node = N then
Pending_Instantiations.Table (J).Inst_Node := Empty;
return;
end if;
-
- J := J + 1;
end loop;
end Remove_Dead_Instance;
diff --git a/gcc/ada/inline.ads b/gcc/ada/inline.ads
index 6790f15..ad08e38 100644
--- a/gcc/ada/inline.ads
+++ b/gcc/ada/inline.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/itypes.adb b/gcc/ada/itypes.adb
index 991824c..f51b44a 100644
--- a/gcc/ada/itypes.adb
+++ b/gcc/ada/itypes.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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,12 +23,13 @@
-- --
------------------------------------------------------------------------------
-with Atree; use Atree;
-with Sem; use Sem;
-with Sinfo; use Sinfo;
-with Stand; use Stand;
-with Targparm; use Targparm;
-with Uintp; use Uintp;
+with Einfo.Utils; use Einfo.Utils;
+with Sem; use Sem;
+with Sinfo; use Sinfo;
+with Sinfo.Nodes; use Sinfo.Nodes;
+with Stand; use Stand;
+with Targparm; use Targparm;
+with Uintp; use Uintp;
package body Itypes is
@@ -110,6 +111,7 @@ package body Itypes is
Set_Is_Atomic (I_Typ, Is_Atomic (T));
Set_Is_Ada_2005_Only (I_Typ, Is_Ada_2005_Only (T));
Set_Is_Ada_2012_Only (I_Typ, Is_Ada_2012_Only (T));
+ Set_Is_Ada_2022_Only (I_Typ, Is_Ada_2022_Only (T));
Set_Can_Never_Be_Null (I_Typ);
return I_Typ;
diff --git a/gcc/ada/itypes.ads b/gcc/ada/itypes.ads
index 36fe2b3..91d8e6d 100644
--- a/gcc/ada/itypes.ads
+++ b/gcc/ada/itypes.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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,9 +25,10 @@
-- This package contains declarations for handling of implicit types
-with Einfo; use Einfo;
-with Sem_Util; use Sem_Util;
-with Types; use Types;
+with Einfo; use Einfo;
+with Einfo.Entities; use Einfo.Entities;
+with Sem_Util; use Sem_Util;
+with Types; use Types;
package Itypes is
diff --git a/gcc/ada/krunch.adb b/gcc/ada/krunch.adb
index 8ed239e..f698d88 100644
--- a/gcc/ada/krunch.adb
+++ b/gcc/ada/krunch.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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,15 +92,16 @@ begin
Startloc := 3;
Buffer (2 .. Len - 5) := Buffer (7 .. Len);
Curlen := Len - 5;
- if Buffer (Curlen - 2 .. Curlen) = "128"
- or else Buffer (3 .. 9) = "exn_lll"
- or else Buffer (3 .. 9) = "exp_lll"
- or else Buffer (3 .. 9) = "img_lll"
- or else Buffer (3 .. 9) = "val_lll"
- or else Buffer (3 .. 9) = "wid_lll"
- or else (Buffer (3 .. 6) = "pack" and then Curlen = 10)
+ if (Curlen >= 3 and then Buffer (Curlen - 2 .. Curlen) = "128")
+ or else (Len >= 9 and then
+ (Buffer (3 .. 9) = "exn_lll"
+ or else Buffer (3 .. 9) = "exp_lll"
+ or else Buffer (3 .. 9) = "img_lll"
+ or else Buffer (3 .. 9) = "val_lll"
+ or else Buffer (3 .. 9) = "wid_lll"))
+ or else (Curlen = 10 and then Buffer (3 .. 6) = "pack")
then
- if Buffer (3 .. 15) = "compare_array" then
+ if Len >= 15 and then Buffer (3 .. 15) = "compare_array" then
Buffer (3 .. 4) := "ca";
Buffer (5 .. Curlen - 11) := Buffer (16 .. Curlen);
Curlen := Curlen - 11;
diff --git a/gcc/ada/krunch.ads b/gcc/ada/krunch.ads
index 82dc612..f58b997 100644
--- a/gcc/ada/krunch.ads
+++ b/gcc/ada/krunch.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute 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 ad80849..e69386c 100644
--- a/gcc/ada/layout.adb
+++ b/gcc/ada/layout.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2001-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2001-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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,19 +23,23 @@
-- --
------------------------------------------------------------------------------
-with Atree; use Atree;
-with Debug; use Debug;
-with Einfo; use Einfo;
-with Errout; use Errout;
-with Opt; use Opt;
-with Sem_Aux; use Sem_Aux;
-with Sem_Ch13; use Sem_Ch13;
-with Sem_Eval; use Sem_Eval;
-with Sem_Util; use Sem_Util;
-with Sinfo; use Sinfo;
-with Snames; use Snames;
-with Ttypes; use Ttypes;
-with Uintp; use Uintp;
+with Atree; use Atree;
+with Debug; use Debug;
+with Einfo; use Einfo;
+with Einfo.Entities; use Einfo.Entities;
+with Einfo.Utils; use Einfo.Utils;
+with Errout; use Errout;
+with Opt; use Opt;
+with Sem_Aux; use Sem_Aux;
+with Sem_Ch13; use Sem_Ch13;
+with Sem_Eval; use Sem_Eval;
+with Sem_Util; use Sem_Util;
+with Sinfo; use Sinfo;
+with Sinfo.Nodes; use Sinfo.Nodes;
+with Sinfo.Utils; use Sinfo.Utils;
+with Snames; use Snames;
+with Ttypes; use Ttypes;
+with Uintp; use Uintp;
package body Layout is
@@ -73,7 +77,7 @@ package body Layout is
begin
-- Nothing to do if size unknown
- if Unknown_Esize (E) then
+ if not Known_Esize (E) then
return;
end if;
@@ -115,7 +119,7 @@ package body Layout is
-- Now we have the size set, it must be a multiple of the alignment
-- nothing more we can do here if the alignment is unknown here.
- if Unknown_Alignment (E) then
+ if not Known_Alignment (E) then
return;
end if;
@@ -235,8 +239,8 @@ package body Layout is
Desig_Type : Entity_Id;
begin
- -- For string literal types, for now, kill the size always, this is
- -- because gigi does not like or need the size to be set ???
+ -- For string literal types, kill the size always, because gigi does not
+ -- like or need the size to be set.
if Ekind (E) = E_String_Literal_Subtype then
Set_Esize (E, Uint_0);
@@ -266,15 +270,15 @@ package body Layout is
Desig_Type := Non_Limited_View (Designated_Type (E));
end if;
- -- If Esize already set (e.g. by a size clause), then nothing further
- -- to be done here.
+ -- If Esize already set (e.g. by a size or value size clause), then
+ -- nothing further to be done here.
if Known_Esize (E) then
null;
- -- Access to subprogram is a strange beast, and we let the backend
- -- figure out what is needed (it may be some kind of fat pointer,
- -- including the static link for example.
+ -- Access to protected subprogram is a strange beast, and we let the
+ -- backend figure out what is needed (it may be some kind of fat
+ -- pointer, including the static link for example).
elsif Is_Access_Protected_Subprogram_Type (E) then
null;
@@ -368,7 +372,7 @@ package body Layout is
if not Known_Esize (E) then
declare
- S : Int := 8;
+ S : Pos := 8;
begin
loop
@@ -381,7 +385,7 @@ package body Layout is
-- If the RM_Size is greater than System_Max_Integer_Size
-- (happens only when strange values are specified by the
-- user), then Esize is simply a copy of RM_Size, it will
- -- be further refined later on).
+ -- be further refined later on.
elsif S = System_Max_Integer_Size then
Set_Esize (E, RM_Size (E));
@@ -400,7 +404,7 @@ package body Layout is
-- it now to a copy of the Esize if the Esize is set.
else
- if Known_Esize (E) and then Unknown_RM_Size (E) then
+ if Known_Esize (E) and then not Known_RM_Size (E) then
Set_RM_Size (E, Esize (E));
end if;
end if;
@@ -421,15 +425,15 @@ package body Layout is
PAT : constant Entity_Id := Packed_Array_Impl_Type (E);
begin
- if Unknown_Esize (E) then
+ if not Known_Esize (E) then
Set_Esize (E, Esize (PAT));
end if;
- if Unknown_RM_Size (E) then
+ if not Known_RM_Size (E) then
Set_RM_Size (E, RM_Size (PAT));
end if;
- if Unknown_Alignment (E) then
+ if not Known_Alignment (E) and then Known_Alignment (PAT) then
Set_Alignment (E, Alignment (PAT));
end if;
end;
@@ -442,13 +446,13 @@ package body Layout is
-- gave up because, in this case, the object size is not a multiple
-- of the alignment and, therefore, cannot be the component size.
- if Ekind (E) = E_Array_Type and then Unknown_Component_Size (E) then
+ if Ekind (E) = E_Array_Type and then not Known_Component_Size (E) then
declare
CT : constant Entity_Id := Component_Type (E);
begin
-- For some reason, access types can cause trouble, So let's
- -- just do this for scalar types ???
+ -- just do this for scalar types.
if Present (CT)
and then Is_Scalar_Type (CT)
@@ -474,7 +478,7 @@ package body Layout is
if Is_Array_Type (E)
and then not Is_Packed (E)
- and then Unknown_Alignment (E)
+ and then not Known_Alignment (E)
and then Known_Alignment (Component_Type (E))
and then Known_Static_Component_Size (E)
and then Known_Static_Esize (Component_Type (E))
@@ -483,6 +487,59 @@ package body Layout is
then
Set_Alignment (E, Alignment (Component_Type (E)));
end if;
+
+ -- If packing was requested, the one-dimensional array is constrained
+ -- with static bounds, the component size was set explicitly, and
+ -- the alignment is known, we can set (if not set explicitly) the
+ -- RM_Size and the Esize of the array type, as RM_Size is equal to
+ -- (arr'length * arr'component_size) and Esize is the same value
+ -- rounded to the next multiple of arr'alignment. This is not
+ -- applicable to packed arrays that are implemented specially
+ -- in GNAT, i.e. when Packed_Array_Impl_Type is set.
+
+ if Is_Array_Type (E)
+ and then Present (First_Index (E)) -- Skip types in error
+ and then Number_Dimensions (E) = 1
+ and then not Present (Packed_Array_Impl_Type (E))
+ and then Has_Pragma_Pack (E)
+ and then Is_Constrained (E)
+ and then Compile_Time_Known_Bounds (E)
+ and then Known_Component_Size (E)
+ and then Known_Alignment (E)
+ then
+ declare
+ Abits : constant Int := UI_To_Int (Alignment (E)) * SSU;
+ Lo, Hi : Node_Id;
+ Siz : Uint;
+
+ begin
+ Get_Index_Bounds (First_Index (E), Lo, Hi);
+
+ -- Even if the bounds are known at compile time, they could
+ -- have been replaced by an error node. Check each bound
+ -- explicitly.
+
+ if Compile_Time_Known_Value (Lo)
+ and then Compile_Time_Known_Value (Hi)
+ then
+ Siz := (Expr_Value (Hi) - Expr_Value (Lo) + 1)
+ * Component_Size (E);
+
+ -- Do not overwrite a different value of 'Size specified
+ -- explicitly by the user. In that case, also do not set
+ -- Esize.
+
+ if not Known_RM_Size (E) or else RM_Size (E) = Siz then
+ Set_RM_Size (E, Siz);
+
+ if not Known_Esize (E) then
+ Siz := ((Siz + (Abits - 1)) / Abits) * Abits;
+ Set_Esize (E, Siz);
+ end if;
+ end if;
+ end if;
+ end;
+ end if;
end if;
-- Even if the backend performs the layout, we still do a little in
@@ -519,7 +576,7 @@ package body Layout is
-- arrays when passed to subprogram parameters (see special test
-- in Exp_Ch6.Expand_Actuals).
- if not Is_Packed (E) and then Unknown_Alignment (E) then
+ if not Is_Packed (E) and then not Known_Alignment (E) then
if Known_Static_Component_Size (E)
and then Component_Size (E) = 1
then
@@ -691,7 +748,7 @@ package body Layout is
if Known_Static_Esize (E) then
Siz := Esize (E);
- elsif Unknown_Esize (E) and then Known_Static_RM_Size (E) then
+ elsif not Known_Esize (E) and then Known_Static_RM_Size (E) then
Siz := RM_Size (E);
else
return;
@@ -796,7 +853,7 @@ package body Layout is
if Calign > Align
and then
- (Unknown_Esize (Comp)
+ (not Known_Esize (Comp)
or else (Known_Static_Esize (Comp)
and then
Esize (Comp) = Calign * SSU))
@@ -963,7 +1020,7 @@ package body Layout is
-- If alignment is currently not set, then we can safely set it to
-- this new calculated value.
- if Unknown_Alignment (E) then
+ if not Known_Alignment (E) then
Init_Alignment (E, A);
-- Cases where we have inherited an alignment
diff --git a/gcc/ada/layout.ads b/gcc/ada/layout.ads
index f145082..89ee5bd 100644
--- a/gcc/ada/layout.ads
+++ b/gcc/ada/layout.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2000-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2000-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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,10 +32,9 @@ with Types; use Types;
package Layout is
- -- The following procedures are called from Freeze, so all entities
- -- for types and objects that get frozen (which should be all such
- -- entities which are seen by the back end) will get laid out by one
- -- of these two procedures.
+ -- The following procedures are called from Freeze, so all entities for
+ -- types and objects that get frozen (i.e. all types and objects seen by
+ -- the back end) will get laid out by one of these two procedures.
procedure Layout_Type (E : Entity_Id);
-- This procedure may set or adjust the fields Esize, RM_Size and
diff --git a/gcc/ada/lib-list.adb b/gcc/ada/lib-list.adb
index 3733c0b..e4c2832 100644
--- a/gcc/ada/lib-list.adb
+++ b/gcc/ada/lib-list.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute 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 f8d632a..737762c 100644
--- a/gcc/ada/lib-load.adb
+++ b/gcc/ada/lib-load.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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,27 +23,30 @@
-- --
------------------------------------------------------------------------------
-with Atree; use Atree;
-with Debug; use Debug;
-with Einfo; use Einfo;
-with Errout; use Errout;
-with Fname; use Fname;
-with Fname.UF; use Fname.UF;
-with Nlists; use Nlists;
-with Nmake; use Nmake;
-with Opt; use Opt;
-with Osint; use Osint;
-with Osint.C; use Osint.C;
-with Output; use Output;
+with Atree; use Atree;
+with Debug; use Debug;
+with Einfo; use Einfo;
+with Einfo.Entities; use Einfo.Entities;
+with Errout; use Errout;
+with Fname; use Fname;
+with Fname.UF; use Fname.UF;
+with Nlists; use Nlists;
+with Nmake; use Nmake;
+with Opt; use Opt;
+with Osint; use Osint;
+with Osint.C; use Osint.C;
+with Output; use Output;
with Par;
-with Restrict; use Restrict;
-with Scn; use Scn;
-with Sinfo; use Sinfo;
-with Sinput; use Sinput;
-with Sinput.L; use Sinput.L;
-with Stand; use Stand;
-with Tbuild; use Tbuild;
-with Uname; use Uname;
+with Restrict; use Restrict;
+with Scn; use Scn;
+with Sinfo; use Sinfo;
+with Sinfo.Nodes; use Sinfo.Nodes;
+with Sinfo.Utils; use Sinfo.Utils;
+with Sinput; use Sinput;
+with Sinput.L; use Sinput.L;
+with Stand; use Stand;
+with Tbuild; use Tbuild;
+with Uname; use Uname;
package body Lib.Load is
@@ -85,7 +88,7 @@ package body Lib.Load is
-- Note: for the following we should really generalize and consult the
-- file name pattern data, but for now we just deal with the common
- -- naming cases, which is probably good enough in practice ???
+ -- naming cases, which is good enough in practice.
-- Change .adb to .ads
@@ -361,7 +364,7 @@ package body Lib.Load is
Error_Location => No_Location,
Expected_Unit => No_Unit_Name,
Fatal_Error => None,
- Generate_Code => False,
+ Generate_Code => True,
Has_RACW => False,
Filler => False,
Ident_String => Empty,
@@ -393,14 +396,14 @@ package body Lib.Load is
---------------
function Load_Unit
- (Load_Name : Unit_Name_Type;
- Required : Boolean;
- Error_Node : Node_Id;
- Subunit : Boolean;
- Corr_Body : Unit_Number_Type := No_Unit;
- Renamings : Boolean := False;
- With_Node : Node_Id := Empty;
- PMES : Boolean := False) return Unit_Number_Type
+ (Load_Name : Unit_Name_Type;
+ Required : Boolean;
+ Error_Node : Node_Id;
+ Subunit : Boolean;
+ Corr_Body : Unit_Number_Type := No_Unit;
+ Renamings : Boolean := False;
+ With_Node : Node_Id := Empty;
+ PMES : Boolean := False) return Unit_Number_Type
is
Calling_Unit : Unit_Number_Type;
Uname_Actual : Unit_Name_Type;
@@ -424,7 +427,7 @@ package body Lib.Load is
-- it is part of the main extended source, otherwise reset them.
-- Note: it's a bit odd but PMES is False for subunits, which is why
- -- we have the OR here. Should be investigated some time???
+ -- we have the OR here.
if PMES or Subunit then
Restore_Config_Cunit_Boolean_Restrictions;
@@ -448,8 +451,8 @@ package body Lib.Load is
With_Node => With_Node);
if Unump = No_Unit then
- Parsing_Main_Extended_Source := Save_PMES;
- return No_Unit;
+ Unum := No_Unit;
+ goto Done;
end if;
-- If parent is a renaming, then we use the renamed package as
@@ -478,7 +481,7 @@ package body Lib.Load is
-- installing the context. The implicit with is on this entity,
-- not on the package it renames. This is somewhat redundant given
-- the with_clause just created, but it simplifies subsequent
- -- expansion of the current with_clause. Optimizable ???
+ -- expansion of the current with_clause.
if Nkind (Error_Node) = N_With_Clause
and then Nkind (Name (Error_Node)) = N_Selected_Component
@@ -820,7 +823,7 @@ package body Lib.Load is
Units.Table (Calling_Unit).Fatal_Error := Error_Detected;
-- If with'ed unit had an ignored error, then propagate it
- -- but do not overide an existring setting.
+ -- but do not overide an existing setting.
when Error_Ignored =>
if Units.Table (Calling_Unit).Fatal_Error = None then
@@ -897,7 +900,7 @@ package body Lib.Load is
Remove_Unit (Unum);
-- If unit not required, remove load stack entry and the junk
- -- file table entry, and return No_Unit to indicate not found,
+ -- file table entry, and return No_Unit to indicate not found.
else
Load_Stack.Decrement_Last;
@@ -961,13 +964,12 @@ package body Lib.Load is
Units.Increment_Last;
if In_Main then
- Units.Table (Units.Last) := Units.Table (Main_Unit);
- Units.Table (Units.Last).Cunit := Library_Unit (N);
- Units.Table (Units.Last).Generate_Code := True;
+ Units.Table (Units.Last) := Units.Table (Main_Unit);
+ Units.Table (Units.Last).Cunit := Library_Unit (N);
Init_Unit_Name (Units.Last, Unit_Name (Main_Unit));
- Units.Table (Main_Unit).Cunit := N;
- Units.Table (Main_Unit).Version := Source_Checksum (Sind);
+ Units.Table (Main_Unit).Cunit := N;
+ Units.Table (Main_Unit).Version := Source_Checksum (Sind);
Init_Unit_Name (Main_Unit,
Get_Body_Name
(Unit_Name (Get_Cunit_Unit_Number (Library_Unit (N)))));
diff --git a/gcc/ada/lib-load.ads b/gcc/ada/lib-load.ads
index c252f1f..98b418c 100644
--- a/gcc/ada/lib-load.ads
+++ b/gcc/ada/lib-load.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute 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 5ed478b..1a8ba8b 100644
--- a/gcc/ada/lib-sort.adb
+++ b/gcc/ada/lib-sort.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute 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 a4772ab..2706e52 100644
--- a/gcc/ada/lib-util.adb
+++ b/gcc/ada/lib-util.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute 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 9b29298..8b0fbd3 100644
--- a/gcc/ada/lib-util.ads
+++ b/gcc/ada/lib-util.ads
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute 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 16449e8..738a91e 100644
--- a/gcc/ada/lib-writ.adb
+++ b/gcc/ada/lib-writ.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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,35 +23,39 @@
-- --
------------------------------------------------------------------------------
-with ALI; use ALI;
-with Atree; use Atree;
-with Casing; use Casing;
-with Debug; use Debug;
-with Einfo; use Einfo;
-with Errout; use Errout;
-with Fname; use Fname;
-with Fname.UF; use Fname.UF;
-with Lib.Util; use Lib.Util;
-with Lib.Xref; use Lib.Xref;
-with Nlists; use Nlists;
-with Gnatvsn; use Gnatvsn;
-with Opt; use Opt;
-with Osint; use Osint;
-with Osint.C; use Osint.C;
-with Output; use Output;
+with ALI; use ALI;
+with Atree; use Atree;
+with Casing; use Casing;
+with Debug; use Debug;
+with Einfo; use Einfo;
+with Einfo.Entities; use Einfo.Entities;
+with Einfo.Utils; use Einfo.Utils;
+with Errout; use Errout;
+with Fname; use Fname;
+with Fname.UF; use Fname.UF;
+with Lib.Util; use Lib.Util;
+with Lib.Xref; use Lib.Xref;
+with Nlists; use Nlists;
+with Gnatvsn; use Gnatvsn;
+with Opt; use Opt;
+with Osint; use Osint;
+with Osint.C; use Osint.C;
+with Output; use Output;
with Par;
-with Par_SCO; use Par_SCO;
-with Restrict; use Restrict;
-with Rident; use Rident;
-with Stand; use Stand;
-with Scn; use Scn;
-with Sem_Eval; use Sem_Eval;
-with Sinfo; use Sinfo;
-with Sinput; use Sinput;
-with Snames; use Snames;
-with Stringt; use Stringt;
-with Tbuild; use Tbuild;
-with Uname; use Uname;
+with Par_SCO; use Par_SCO;
+with Restrict; use Restrict;
+with Rident; use Rident;
+with Stand; use Stand;
+with Scn; use Scn;
+with Sem_Eval; use Sem_Eval;
+with Sinfo; use Sinfo;
+with Sinfo.Nodes; use Sinfo.Nodes;
+with Sinfo.Utils; use Sinfo.Utils;
+with Sinput; use Sinput;
+with Snames; use Snames;
+with Stringt; use Stringt;
+with Tbuild; use Tbuild;
+with Uname; use Uname;
with System.Case_Util; use System.Case_Util;
with System.WCh_Con; use System.WCh_Con;
@@ -133,7 +137,8 @@ package body Lib.Writ is
------------------------------
procedure Ensure_System_Dependency is
- System_Uname : Unit_Name_Type;
+ System_Uname : constant Unit_Name_Type :=
+ Name_To_Unit_Name (Name_System);
-- Unit name for system spec if needed for dummy entry
System_Fname : File_Name_Type;
@@ -142,11 +147,9 @@ package body Lib.Writ is
begin
-- Nothing to do if we already compiled System
- for Unum in Units.First .. Last_Unit loop
- if Source_Index (Unum) = System_Source_File_Index then
- return;
- end if;
- end loop;
+ if Is_Loaded (System_Uname) then
+ return;
+ end if;
-- If no entry for system.ads in the units table, then add a entry
-- to the units table for system.ads, which will be referenced when
@@ -154,9 +157,6 @@ package body Lib.Writ is
-- on system as a result of Targparm scanning the system.ads file to
-- determine the target dependent parameters for the compilation.
- Name_Len := 6;
- Name_Buffer (1 .. 6) := "system";
- System_Uname := Name_To_Unit_Name (Name_Enter);
System_Fname := File_Name (System_Source_File_Index);
Units.Increment_Last;
@@ -203,7 +203,7 @@ package body Lib.Writ is
Style_Check := False;
Initialize_Scanner (Units.Last, System_Source_File_Index);
Discard_List (Par (Configuration_Pragmas => False));
- Set_Ekind (Cunit_Entity (Units.Last), E_Package);
+ Mutate_Ekind (Cunit_Entity (Units.Last), E_Package);
Set_Scope (Cunit_Entity (Units.Last), Standard_Standard);
Style_Check := Save_Style;
Multiple_Unit_Index := Save_Mindex;
@@ -705,7 +705,7 @@ package body Lib.Writ is
Write_Info_Char (' ');
case Pragma_Name (N) is
- when Name_Annotate =>
+ when Name_Annotate | Name_GNAT_Annotate =>
C := 'A';
when Name_Comment =>
C := 'C';
@@ -1014,7 +1014,7 @@ package body Lib.Writ is
return;
end if;
- -- Build sorted source dependency table.
+ -- Build sorted source dependency table
for Unum in Units.First .. Last_Unit loop
if Cunit_Entity (Unum) = Empty
@@ -1251,9 +1251,10 @@ package body Lib.Writ is
-- for which we have generated code
for Unit in Units.First .. Last_Unit loop
- if Units.Table (Unit).Generate_Code or else Unit = Main_Unit then
+ if Units.Table (Unit).Generate_Code then
if not Has_No_Elaboration_Code (Cunit (Unit)) then
Main_Restrictions.Violated (No_Elaboration_Code) := True;
+ exit;
end if;
end if;
end loop;
diff --git a/gcc/ada/lib-writ.ads b/gcc/ada/lib-writ.ads
index 7ec57b4..ce5398b 100644
--- a/gcc/ada/lib-writ.ads
+++ b/gcc/ada/lib-writ.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -1053,6 +1053,9 @@ package Lib.Writ is
-- The Object parameter is true if an object file is created, and false
-- otherwise. Note that the pseudo-object file generated in GNATprove mode
-- does count as an object file from this point of view.
+ -- May output duplicate D lines caused by generic instantiations. This is
+ -- by design as GNATcoverage relies on them for its coverage of generic
+ -- instantiations, although this may be revisited in the future.
procedure Add_Preprocessing_Dependency (S : Source_File_Index);
-- Indicate that there is a dependency to be added on a preprocessing data
diff --git a/gcc/ada/lib-xref-spark_specific.adb b/gcc/ada/lib-xref-spark_specific.adb
index 269d8ee..1905f23 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2011-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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,9 +23,9 @@
-- --
------------------------------------------------------------------------------
-with Einfo; use Einfo;
-with Nmake; use Nmake;
-with SPARK_Xrefs; use SPARK_Xrefs;
+with Einfo.Entities; use Einfo.Entities;
+with Nmake; use Nmake;
+with SPARK_Xrefs; use SPARK_Xrefs;
separate (Lib.Xref)
package body SPARK_Specific is
@@ -187,6 +187,10 @@ package body SPARK_Specific is
| Generic_Subprogram_Kind
| Subprogram_Kind
then
+ if No (Unit_Declaration_Node (N)) then
+ return Empty;
+ end if;
+
Context := Parent (Unit_Declaration_Node (N));
-- If this was a library-level subprogram then replace Context with
@@ -296,7 +300,7 @@ package body SPARK_Specific is
(Standard_Location,
Name_Enter (Name_Of_Heap_Variable));
- Set_Ekind (Heap, E_Variable);
+ Mutate_Ekind (Heap, E_Variable);
Set_Is_Internal (Heap, True);
Set_Etype (Heap, Standard_Void_Type);
Set_Scope (Heap, Standard_Standard);
diff --git a/gcc/ada/lib-xref.adb b/gcc/ada/lib-xref.adb
index 0869906..17de886 100644
--- a/gcc/ada/lib-xref.adb
+++ b/gcc/ada/lib-xref.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1998-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1998-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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,26 +23,30 @@
-- --
------------------------------------------------------------------------------
-with Atree; use Atree;
-with Csets; use Csets;
-with Elists; use Elists;
-with Errout; use Errout;
-with Lib.Util; use Lib.Util;
-with Nlists; use Nlists;
-with Opt; use Opt;
-with Restrict; use Restrict;
-with Rident; use Rident;
-with Sem; use Sem;
-with Sem_Aux; use Sem_Aux;
-with Sem_Prag; use Sem_Prag;
-with Sem_Util; use Sem_Util;
-with Sem_Warn; use Sem_Warn;
-with Sinfo; use Sinfo;
-with Sinput; use Sinput;
-with Snames; use Snames;
-with Stringt; use Stringt;
-with Stand; use Stand;
-with Table; use Table;
+with Atree; use Atree;
+with Csets; use Csets;
+with Einfo; use Einfo;
+with Einfo.Utils; use Einfo.Utils;
+with Elists; use Elists;
+with Errout; use Errout;
+with Lib.Util; use Lib.Util;
+with Nlists; use Nlists;
+with Opt; use Opt;
+with Restrict; use Restrict;
+with Rident; use Rident;
+with Sem; use Sem;
+with Sem_Aux; use Sem_Aux;
+with Sem_Prag; use Sem_Prag;
+with Sem_Util; use Sem_Util;
+with Sem_Warn; use Sem_Warn;
+with Sinfo; use Sinfo;
+with Sinfo.Nodes; use Sinfo.Nodes;
+with Sinfo.Utils; use Sinfo.Utils;
+with Sinput; use Sinput;
+with Snames; use Snames;
+with Stringt; use Stringt;
+with Stand; use Stand;
+with Table; use Table;
with GNAT.Heap_Sort_G;
with GNAT.HTable;
@@ -699,6 +703,37 @@ package body Lib.Xref is
Error_Msg_NE ("& is only defined in Ada 2012?y?", N, E);
end if;
+ -- Warn if reference to Ada 2022 entity not in Ada 2022 mode. We only
+ -- detect real explicit references (modifications and references).
+
+ if Comes_From_Source (N)
+ and then Is_Ada_2022_Only (E)
+ and then not Is_Subprogram (E)
+ and then Ada_Version < Ada_2022
+ and then Warn_On_Ada_2022_Compatibility
+ and then (Typ = 'm' or else Typ = 'r')
+ then
+ Error_Msg_NE ("& is only defined in Ada 2022?y?", N, E);
+
+ -- Error on static and dispatching calls to Ada 2022 subprograms that
+ -- require overriding if we are not in Ada 2022 mode (since overriding
+ -- was skipped); warn if the subprogram does not require overriding.
+
+ elsif Comes_From_Source (N)
+ and then Is_Ada_2022_Only (E)
+ and then Ada_Version < Ada_2022
+ and then Is_Subprogram (E)
+ and then (Typ = 'r' or else Typ = 's' or else Typ = 'R')
+ then
+ if Requires_Overriding (E) then
+ Error_Msg_NE
+ ("& is only defined in Ada 2022 and requires overriding", N, E);
+
+ elsif Warn_On_Ada_2022_Compatibility then
+ Error_Msg_NE ("& is only defined in Ada 2022?y?", N, E);
+ end if;
+ end if;
+
-- Do not generate references if we are within a postcondition sub-
-- program, because the reference does not comes from source, and the
-- preanalysis of the aspect has already created an entry for the ALI
@@ -1277,18 +1312,8 @@ package body Lib.Xref is
Formal : Entity_Id;
begin
- if Is_Generic_Subprogram (E) then
- Formal := First_Entity (E);
-
- while Present (Formal)
- and then not Is_Formal (Formal)
- loop
- Next_Entity (Formal);
- end loop;
-
- elsif Ekind (E) in Access_Subprogram_Kind then
+ if Is_Access_Subprogram_Type (E) then
Formal := First_Formal (Designated_Type (E));
-
else
Formal := First_Formal (E);
end if;
diff --git a/gcc/ada/lib-xref.ads b/gcc/ada/lib-xref.ads
index 6a7a9e5..55a9251 100644
--- a/gcc/ada/lib-xref.ads
+++ b/gcc/ada/lib-xref.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1998-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1998-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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,7 +26,7 @@
-- This package contains for collecting and outputting cross-reference
-- information.
-with Einfo; use Einfo;
+with Einfo.Entities; use Einfo.Entities;
with SPARK_Xrefs;
package Lib.Xref is
diff --git a/gcc/ada/lib.adb b/gcc/ada/lib.adb
index d298267..44a4af0 100644
--- a/gcc/ada/lib.adb
+++ b/gcc/ada/lib.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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,18 +27,20 @@ pragma Style_Checks (All_Checks);
-- Subprogram ordering not enforced in this unit
-- (because of some logical groupings).
-with Atree; use Atree;
-with Csets; use Csets;
-with Einfo; use Einfo;
-with Nlists; use Nlists;
-with Opt; use Opt;
-with Output; use Output;
-with Sinfo; use Sinfo;
-with Sinput; use Sinput;
-with Stand; use Stand;
-with Stringt; use Stringt;
-with Uname; use Uname;
-with Widechar; use Widechar;
+with Atree; use Atree;
+with Csets; use Csets;
+with Einfo; use Einfo;
+with Einfo.Entities; use Einfo.Entities;
+with Nlists; use Nlists;
+with Opt; use Opt;
+with Output; use Output;
+with Sinfo; use Sinfo;
+with Sinfo.Nodes; use Sinfo.Nodes;
+with Sinput; use Sinput;
+with Stand; use Stand;
+with Stringt; use Stringt;
+with Uname; use Uname;
+with Widechar; use Widechar;
package body Lib is
@@ -126,12 +128,12 @@ package body Lib is
return Units.Table (U).Is_Predefined_Renaming;
end Is_Predefined_Renaming;
- function Is_Internal_Unit (U : Unit_Number_Type) return Boolean is
+ function Is_Internal_Unit (U : Unit_Number_Type) return Boolean is
begin
return Units.Table (U).Is_Internal_Unit;
end Is_Internal_Unit;
- function Is_Predefined_Unit (U : Unit_Number_Type) return Boolean is
+ function Is_Predefined_Unit (U : Unit_Number_Type) return Boolean is
begin
return Units.Table (U).Is_Predefined_Unit;
end Is_Predefined_Unit;
@@ -480,18 +482,12 @@ package body Lib is
-- body of the same unit. The location in the spec is considered
-- earlier.
- if Nkind (Unit1) = N_Subprogram_Body
- or else
- Nkind (Unit1) = N_Package_Body
- then
+ if Nkind (Unit1) in N_Subprogram_Body | N_Package_Body then
if Library_Unit (Cunit (Unum1)) = Cunit (Unum2) then
return Yes_After;
end if;
- elsif Nkind (Unit2) = N_Subprogram_Body
- or else
- Nkind (Unit2) = N_Package_Body
- then
+ elsif Nkind (Unit2) in N_Subprogram_Body | N_Package_Body then
if Library_Unit (Cunit (Unum2)) = Cunit (Unum1) then
return Yes_Before;
end if;
@@ -509,8 +505,8 @@ package body Lib is
if Counter > Max_Iterations then
- -- ??? Not quite right, but return a value to be able to generate
- -- SCIL files and hope for the best.
+ -- In CodePeer_Mode, return a value to be able to generate SCIL
+ -- files and hope for the best.
if CodePeer_Mode then
return No;
@@ -1178,10 +1174,9 @@ package body Lib is
procedure Remove_Unit (U : Unit_Number_Type) is
begin
- if U = Units.Last then
- Unit_Names.Set (Unit_Name (U), No_Unit);
- Units.Decrement_Last;
- end if;
+ pragma Assert (U = Units.Last);
+ Unit_Names.Set (Unit_Name (U), No_Unit);
+ Units.Decrement_Last;
end Remove_Unit;
----------------------------------
@@ -1266,10 +1261,16 @@ package body Lib is
-- Synchronize_Serial_Number --
-------------------------------
- procedure Synchronize_Serial_Number is
+ procedure Synchronize_Serial_Number (SN : Nat) is
TSN : Int renames Units.Table (Current_Sem_Unit).Serial_Number;
begin
- TSN := TSN + 1;
+ -- We should not be trying to synchronize downward
+
+ pragma Assert (TSN <= SN);
+
+ if TSN < SN then
+ TSN := SN;
+ end if;
end Synchronize_Serial_Number;
--------------------
diff --git a/gcc/ada/lib.ads b/gcc/ada/lib.ads
index be517c0..f2c6ef3 100644
--- a/gcc/ada/lib.ads
+++ b/gcc/ada/lib.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -741,13 +741,13 @@ package Lib is
-- This procedure is called to register a pragma N for which a notes
-- entry is required.
- procedure Synchronize_Serial_Number;
+ procedure Synchronize_Serial_Number (SN : Nat);
-- This function increments the Serial_Number field for the current unit
- -- but does not return the incremented value. This is used when there
- -- is a situation where one path of control increments a serial number
- -- (using Increment_Serial_Number), and the other path does not and it 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).
+ -- up to SN if it is initially lower and does nothing otherwise. This is
+ -- used in situations where one path of control increments serial numbers
+ -- and the other path does not and it is important to keep serial numbers
+ -- synchronized in the two cases (e.g. when the references in a package
+ -- and a client must be kept consistent).
procedure Unlock;
-- Unlock internal tables, in cases where the back end needs to modify them
@@ -926,7 +926,9 @@ private
-- The following table records a mapping between a name and the entry in
-- the units table whose Unit_Name is this name. It is used to speed up
-- the Is_Loaded function, whose original implementation (linear search)
- -- could account for 2% of the time spent in the front end. Note that, in
+ -- could account for 2% of the time spent in the front end. When the unit
+ -- is an instance of a generic, the unit might get duplicated in the unit
+ -- table - see Make_Instance_Unit for more information. Note that, in
-- the case of source files containing multiple units, the units table may
-- temporarily contain two entries with the same Unit_Name during parsing,
-- which means that the mapping must be to the first entry in the table.
diff --git a/gcc/ada/libgnarl/a-astaco.adb b/gcc/ada/libgnarl/a-astaco.adb
index 22ae7e2..176eefe 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute 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 9e9fb7e..052f4c5 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2015-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute 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 a7e11f3..04d5801 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, 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-etgrbu.ads b/gcc/ada/libgnarl/a-etgrbu.ads
index 5d8b9e0..e391961 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2015-2021, 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 6e6176a..1c75ee7 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2007-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute 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 4abe266..c699e4c 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2007-2021, 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 03b3468..bcf2424 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2007-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute 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 61a5f88..01d5009 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2009-2021, 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 0ba6742..bf9f9cf 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2007-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute 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 4cbad55..28a9d55 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-2020, AdaCore --
+-- Copyright (C) 1995-2021, 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 3fa18e2..e64f2e7 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, 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 f965f10..6f20488 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1995-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute 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 cb44dfb..f599b53 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1991-2021, 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 d28ac5e..26e85ba 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1991-2021, 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 74b6938..8f73419 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1991-2021, 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 9fb30834..ffc3167 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1991-2021, 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 c122735..976d67e 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1991-2021, 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 6485e71..931f4c1 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1991-2021, 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 68fc6f1..6908238 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1991-2021, 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 5acd701..bc2ed1e 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1991-2021, 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 9267e00..7d1c016 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1997-2021, 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 82825ca..e97c73e 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1991-2021, 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 4012611..89618f6 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1991-2021, 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 6a44f93..0aa6507 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1991-2021, 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 5876da1..a74f289 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1998-2021, 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 2881752..2fda415 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-2020, AdaCore --
+-- Copyright (C) 1995-2021, 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 a390107..e47ada9 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, 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 1415556..b903294 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, 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 4325b08..f0ea80a 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, 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 d049f16..5527e2f 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2005-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute 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 905e0cf..5074575 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2005-2021, 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 df4f9f4..e7d82d3 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, 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.ads b/gcc/ada/libgnarl/a-synbar.ads
index c423695..db97265 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, 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__posix.adb b/gcc/ada/libgnarl/a-synbar__posix.adb
index 96f4a7b..9148977 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, 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__posix.ads b/gcc/ada/libgnarl/a-synbar__posix.ads
index afbeb6b..5789902 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, 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-sytaco.adb b/gcc/ada/libgnarl/a-sytaco.adb
index 94788d5..7bdbec0 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute 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 906f60a..05e73c2 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, 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 af9575f..cf51f61 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2014-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute 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 e5394e1..6403185 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2014-2021, 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 9df547f..c513455 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute 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-taside.ads b/gcc/ada/libgnarl/a-taside.ads
index 537ea3e..a3b1e94 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, 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
index b1f898f..c0dfe70 100644
--- a/gcc/ada/libgnarl/a-tasini.adb
+++ b/gcc/ada/libgnarl/a-tasini.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2020-2021, 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-tasini.ads b/gcc/ada/libgnarl/a-tasini.ads
index 867f8c5..dd2a17c 100644
--- a/gcc/ada/libgnarl/a-tasini.ads
+++ b/gcc/ada/libgnarl/a-tasini.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2020-2021, 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-taster.adb b/gcc/ada/libgnarl/a-taster.adb
index fdf4811a..224fa86 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2005-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute 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.adb b/gcc/ada/libgnarl/g-boubuf.adb
index f9c1850a..0f5f4fa 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-2020, AdaCore --
+-- Copyright (C) 2003-2021, 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 c648333..f03af19 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-2020, AdaCore --
+-- Copyright (C) 2003-2021, 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 7a00ef3..016770b 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-2020, AdaCore --
+-- Copyright (C) 2003-2021, 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 1b93985..2276baf 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-2020, AdaCore --
+-- Copyright (C) 2003-2021, 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 5de7eef..13aa346 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-2020, AdaCore --
+-- Copyright (C) 2003-2021, 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 f961486..e50d1a1 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2003-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute 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 bb374e8..ad5b536 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2003-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute 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 e0475f7..ecdaaf4 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2009-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute 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 ff460d9..452a939 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-2020, AdaCore --
+-- Copyright (C) 1998-2021, 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 9d15dce..1b5534f 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-2020, AdaCore --
+-- Copyright (C) 1998-2021, 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 e722c4f..f9be306 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-2020, AdaCore --
+-- Copyright (C) 2016-2021, 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 73fd5da..f0f6f71 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-2020, AdaCore --
+-- Copyright (C) 2016-2021, 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-inmaop.ads b/gcc/ada/libgnarl/s-inmaop.ads
index dc9be2d..06d5f1f 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, 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 96c8d10..6a31dc7 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, 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 b538b69..60f6207 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-2020, AdaCore --
+-- Copyright (C) 1995-2021, 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 33c181f..8496c82 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-2020, AdaCore --
+-- Copyright (C) 1995-2021, 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 c386c47..7d36b9f 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, 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- --
@@ -473,7 +473,7 @@ package body System.Interrupts is
---------------------------------
procedure Install_Restricted_Handlers
- (Prio : Any_Priority;
+ (Prio : Interrupt_Priority;
Handlers : New_Handler_Array)
is
pragma Unreferenced (Prio);
@@ -783,7 +783,7 @@ package body System.Interrupts is
null;
when others =>
- pragma Assert (False);
+ pragma Assert (Standard.False);
null;
end case;
@@ -1228,7 +1228,7 @@ package body System.Interrupts is
when X : others =>
System.IO.Put_Line ("Exception in Interrupt_Manager");
System.IO.Put_Line (Ada.Exceptions.Exception_Information (X));
- pragma Assert (False);
+ pragma Assert (Standard.False);
end;
end loop;
end Interrupt_Manager;
diff --git a/gcc/ada/libgnarl/s-interr.ads b/gcc/ada/libgnarl/s-interr.ads
index 0f82beb..3252851 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, 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- --
@@ -267,7 +267,7 @@ package System.Interrupts is
-- the new static handlers.
procedure Install_Restricted_Handlers
- (Prio : Any_Priority;
+ (Prio : Interrupt_Priority;
Handlers : New_Handler_Array);
-- Install the static Handlers for the given interrupts and do not
-- store previously installed handlers. This procedure is used when
diff --git a/gcc/ada/libgnarl/s-interr__dummy.adb b/gcc/ada/libgnarl/s-interr__dummy.adb
index ffa0710..475a54e 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-2020, AdaCore --
+-- Copyright (C) 1995-2021, 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- --
@@ -188,7 +188,7 @@ package body System.Interrupts is
---------------------------------
procedure Install_Restricted_Handlers
- (Prio : Any_Priority;
+ (Prio : Interrupt_Priority;
Handlers : New_Handler_Array)
is
begin
diff --git a/gcc/ada/libgnarl/s-interr__hwint.adb b/gcc/ada/libgnarl/s-interr__hwint.adb
index 5c2c321..be6b559 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, 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- --
@@ -478,7 +478,7 @@ package body System.Interrupts is
---------------------------------
procedure Install_Restricted_Handlers
- (Prio : Any_Priority;
+ (Prio : Interrupt_Priority;
Handlers : New_Handler_Array)
is
pragma Unreferenced (Prio);
@@ -1023,7 +1023,7 @@ package body System.Interrupts is
null;
when others =>
- pragma Assert (False);
+ pragma Assert (Standard.False);
null;
end;
end loop;
diff --git a/gcc/ada/libgnarl/s-interr__sigaction.adb b/gcc/ada/libgnarl/s-interr__sigaction.adb
index 83bd36c..a2bde29 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1998-2021, 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- --
@@ -291,7 +291,7 @@ package body System.Interrupts is
---------------------------------
procedure Install_Restricted_Handlers
- (Prio : Any_Priority;
+ (Prio : Interrupt_Priority;
Handlers : New_Handler_Array)
is
pragma Unreferenced (Prio);
diff --git a/gcc/ada/libgnarl/s-interr__vxworks.adb b/gcc/ada/libgnarl/s-interr__vxworks.adb
index 157f82f..d496b74 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, 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- --
@@ -494,7 +494,7 @@ package body System.Interrupts is
---------------------------------
procedure Install_Restricted_Handlers
- (Prio : Any_Priority;
+ (Prio : Interrupt_Priority;
Handlers : New_Handler_Array)
is
pragma Unreferenced (Prio);
@@ -1040,7 +1040,7 @@ package body System.Interrupts is
null;
when others =>
- pragma Assert (False);
+ pragma Assert (Standard.False);
null;
end;
end loop;
diff --git a/gcc/ada/libgnarl/s-intman.ads b/gcc/ada/libgnarl/s-intman.ads
index 711ef9e..c493163 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, 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 54c40d4..6364ead 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2014-2021, 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 596cfe2..91f17b0 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1997-2021, 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 5f7d902..c2e8f8a 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, 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 636927b..252fc2a 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1991-2021, 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 8ec5787..b0b0146 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, 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 b4cae71..e983a9e 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, 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 08a15c9..3871457 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, 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 d20aaa6..b33d76d 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, 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 21ce62f..e9b5636 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, 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 2e885be..6ff7c41 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, 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 c06aebc..2251f2d 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2008-2021, 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- --
@@ -36,6 +36,7 @@
-- Preelaborate. This package is designed to be a bottom-level (leaf) package
with Interfaces.C;
+with System.Parameters;
package System.Linux is
pragma Preelaborate;
@@ -46,7 +47,8 @@ package System.Linux is
subtype long is Interfaces.C.long;
subtype suseconds_t is Interfaces.C.long;
- subtype time_t is Interfaces.C.long;
+ type time_t is range -2 ** (System.Parameters.time_t_bits - 1)
+ .. 2 ** (System.Parameters.time_t_bits - 1) - 1;
subtype clockid_t is Interfaces.C.int;
type timespec is record
diff --git a/gcc/ada/libgnarl/s-linux__alpha.ads b/gcc/ada/libgnarl/s-linux__alpha.ads
index 7ce73ff..06b12f2 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2009-2021, 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- --
@@ -36,6 +36,7 @@
-- Preelaborate. This package is designed to be a bottom-level (leaf) package.
with Interfaces.C;
+with System.Parameters;
package System.Linux is
pragma Preelaborate;
@@ -46,7 +47,8 @@ package System.Linux is
subtype long is Interfaces.C.long;
subtype suseconds_t is Interfaces.C.long;
- subtype time_t is Interfaces.C.long;
+ type time_t is range -2 ** (System.Parameters.time_t_bits - 1)
+ .. 2 ** (System.Parameters.time_t_bits - 1) - 1;
subtype clockid_t is Interfaces.C.int;
type timespec is record
diff --git a/gcc/ada/libgnarl/s-linux__android.ads b/gcc/ada/libgnarl/s-linux__android.ads
index 108251c..d2b689e 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2014-2021, 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- --
@@ -36,6 +36,7 @@
-- Preelaborate. This package is designed to be a bottom-level (leaf) package
with Interfaces.C;
+with System.Parameters;
package System.Linux is
pragma Preelaborate;
@@ -46,7 +47,8 @@ package System.Linux is
subtype long is Interfaces.C.long;
subtype suseconds_t is Interfaces.C.long;
- subtype time_t is Interfaces.C.long;
+ type time_t is range -2 ** (System.Parameters.time_t_bits - 1)
+ .. 2 ** (System.Parameters.time_t_bits - 1) - 1;
subtype clockid_t is Interfaces.C.int;
type timespec is record
diff --git a/gcc/ada/libgnarl/s-linux__hppa.ads b/gcc/ada/libgnarl/s-linux__hppa.ads
index 7796c41..03869df 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2008-2021, 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- --
@@ -36,6 +36,7 @@
-- Preelaborate. This package is designed to be a bottom-level (leaf) package.
with Interfaces.C;
+with System.Parameters;
package System.Linux is
pragma Preelaborate;
@@ -46,7 +47,8 @@ package System.Linux is
subtype long is Interfaces.C.long;
subtype suseconds_t is Interfaces.C.long;
- subtype time_t is Interfaces.C.long;
+ type time_t is range -2 ** (System.Parameters.time_t_bits - 1)
+ .. 2 ** (System.Parameters.time_t_bits - 1) - 1;
subtype clockid_t is Interfaces.C.int;
type timespec is record
diff --git a/gcc/ada/libgnarl/s-linux__mips.ads b/gcc/ada/libgnarl/s-linux__mips.ads
index bc67c12..3660ee9 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2009-2021, 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,6 +35,7 @@
-- Preelaborate. This package is designed to be a bottom-level (leaf) package
with Interfaces.C;
+with System.Parameters;
package System.Linux is
pragma Preelaborate;
@@ -46,7 +47,8 @@ package System.Linux is
subtype int is Interfaces.C.int;
subtype long is Interfaces.C.long;
subtype suseconds_t is Interfaces.C.long;
- subtype time_t is Interfaces.C.long;
+ type time_t is range -2 ** (System.Parameters.time_t_bits - 1)
+ .. 2 ** (System.Parameters.time_t_bits - 1) - 1;
subtype clockid_t is Interfaces.C.int;
type timespec is record
diff --git a/gcc/ada/libgnarl/s-linux__riscv.ads b/gcc/ada/libgnarl/s-linux__riscv.ads
index 56f9db3..e3f7cc3 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2009-2021, 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,6 +35,7 @@
-- Preelaborate. This package is designed to be a bottom-level (leaf) package
with Interfaces.C;
+with System.Parameters;
package System.Linux is
pragma Preelaborate;
@@ -46,7 +47,8 @@ package System.Linux is
subtype int is Interfaces.C.int;
subtype long is Interfaces.C.long;
subtype suseconds_t is Interfaces.C.long;
- subtype time_t is Interfaces.C.long;
+ type time_t is range -2 ** (System.Parameters.time_t_bits - 1)
+ .. 2 ** (System.Parameters.time_t_bits - 1) - 1;
subtype clockid_t is Interfaces.C.int;
type timespec is record
diff --git a/gcc/ada/libgnarl/s-linux__sparc.ads b/gcc/ada/libgnarl/s-linux__sparc.ads
index def0024..102e9ff 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2009-2021, 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- --
@@ -36,6 +36,7 @@
-- Preelaborate. This package is designed to be a bottom-level (leaf) package
with Interfaces.C;
+with System.Parameters;
package System.Linux is
pragma Preelaborate;
@@ -46,7 +47,8 @@ package System.Linux is
subtype long is Interfaces.C.long;
subtype suseconds_t is Interfaces.C.long;
- subtype time_t is Interfaces.C.long;
+ type time_t is range -2 ** (System.Parameters.time_t_bits - 1)
+ .. 2 ** (System.Parameters.time_t_bits - 1) - 1;
subtype clockid_t is Interfaces.C.int;
type timespec is record
diff --git a/gcc/ada/libgnarl/s-linux__x32.ads b/gcc/ada/libgnarl/s-linux__x32.ads
index 5e3b55d..3281235 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2013-2021, Free Software Foundation, Inc. --
--
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
@@ -38,6 +38,8 @@
with Interfaces.C;
+with System.Parameters;
+
package System.Linux is
pragma Preelaborate;
@@ -46,12 +48,15 @@ package System.Linux is
----------
subtype suseconds_t is Long_Long_Integer;
- subtype time_t is Long_Long_Integer;
+ -- Note that suseconds_t is 64 bits.
+ type time_t is range -2 ** (System.Parameters.time_t_bits - 1)
+ .. 2 ** (System.Parameters.time_t_bits - 1) - 1;
subtype clockid_t is Interfaces.C.int;
type timespec is record
tv_sec : time_t;
tv_nsec : Long_Long_Integer;
+ -- Note that tv_nsec is 64 bits.
end record;
pragma Convention (C, timespec);
diff --git a/gcc/ada/libgnarl/s-mudido.adb b/gcc/ada/libgnarl/s-mudido.adb
index 8796c08..eb5d742 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2011-2021, 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 05f4a03..5a9ccaf 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2011-2021, 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 91c4494..43cede7 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1997-2021, 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 ac1b595..bab03d0 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1995-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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,8 @@ with Ada.Unchecked_Conversion;
with Interfaces.C;
with Interfaces.C.Extensions;
+with System.Parameters;
+
package System.OS_Interface is
pragma Preelaborate;
@@ -540,7 +542,8 @@ private
type pid_t is new int;
- type time_t is new long;
+ type time_t is range -2 ** (System.Parameters.time_t_bits - 1)
+ .. 2 ** (System.Parameters.time_t_bits - 1) - 1;
type timespec is record
tv_sec : time_t;
diff --git a/gcc/ada/libgnarl/s-osinte__android.adb b/gcc/ada/libgnarl/s-osinte__android.adb
index 5895940..7a1d63a 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-2020, AdaCore --
+-- Copyright (C) 1995-2021, 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 7b0b6b0..27f7d9d 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1995-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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,6 +42,7 @@ with Ada.Unchecked_Conversion;
with Interfaces.C;
with System.Linux;
with System.OS_Constants;
+with System.Parameters;
package System.OS_Interface is
pragma Preelaborate;
@@ -593,7 +594,8 @@ private
type pid_t is new int;
- type time_t is new long;
+ type time_t is range -2 ** (System.Parameters.time_t_bits - 1)
+ .. 2 ** (System.Parameters.time_t_bits - 1) - 1;
type timespec is record
tv_sec : time_t;
diff --git a/gcc/ada/libgnarl/s-osinte__darwin.adb b/gcc/ada/libgnarl/s-osinte__darwin.adb
index b57a31a..f2c4ee1 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1999-2021, 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 0f2e52b..ac41d528 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1995-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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,6 +40,7 @@
with Interfaces.C;
with System.OS_Constants;
+with System.Parameters;
package System.OS_Interface is
pragma Preelaborate;
@@ -514,7 +515,8 @@ private
type pid_t is new int32_t;
- type time_t is new long;
+ type time_t is range -2 ** (System.Parameters.time_t_bits - 1)
+ .. 2 ** (System.Parameters.time_t_bits - 1) - 1;
type timespec is record
tv_sec : time_t;
diff --git a/gcc/ada/libgnarl/s-osinte__dragonfly.adb b/gcc/ada/libgnarl/s-osinte__dragonfly.adb
index f1c3599..895164e 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1991-2021, 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 6b3b631..515e1b3 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1995-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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,8 @@ with Ada.Unchecked_Conversion;
with Interfaces.C;
+with System.Parameters;
+
package System.OS_Interface is
pragma Preelaborate;
@@ -633,7 +635,8 @@ private
type pid_t is new int;
- type time_t is new long;
+ type time_t is range -2 ** (System.Parameters.time_t_bits - 1)
+ .. 2 ** (System.Parameters.time_t_bits - 1) - 1;
type timespec is record
ts_sec : time_t;
diff --git a/gcc/ada/libgnarl/s-osinte__dummy.ads b/gcc/ada/libgnarl/s-osinte__dummy.ads
index 0fbb816..28942e9 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1995-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute 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 728a723..036c616 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1991-2021, 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 a8122de..0dae1fb 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1995-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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,8 @@ with Ada.Unchecked_Conversion;
with Interfaces.C;
+with System.Parameters;
+
package System.OS_Interface is
pragma Preelaborate;
@@ -630,7 +632,8 @@ private
type pid_t is new int;
Self_PID : constant pid_t := 0;
- type time_t is new long;
+ type time_t is range -2 ** (System.Parameters.time_t_bits - 1)
+ .. 2 ** (System.Parameters.time_t_bits - 1) - 1;
type timespec is record
ts_sec : time_t;
diff --git a/gcc/ada/libgnarl/s-osinte__gnu.adb b/gcc/ada/libgnarl/s-osinte__gnu.adb
index dc0f4ec..ba21cf4 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2015-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute 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 1014cae..98eef86 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1995-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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,6 +39,7 @@
-- Preelaborate. This package is designed to be a bottom-level (leaf) package
with Interfaces.C;
+with System.Parameters;
with Unchecked_Conversion;
package System.OS_Interface is
@@ -652,7 +653,8 @@ private
type pid_t is new int;
- type time_t is new long;
+ type time_t is range -2 ** (System.Parameters.time_t_bits - 1)
+ .. 2 ** (System.Parameters.time_t_bits - 1) - 1;
type timespec is record
tv_sec : time_t;
diff --git a/gcc/ada/libgnarl/s-osinte__hpux-dce.adb b/gcc/ada/libgnarl/s-osinte__hpux-dce.adb
index bcfcf61..4c0c5a9 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-2020, AdaCore --
+-- Copyright (C) 1995-2021, 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 c439f00..ce8c5ab 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1995-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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,6 +42,8 @@ with Ada.Unchecked_Conversion;
with Interfaces.C;
+with System.Parameters;
+
package System.OS_Interface is
pragma Preelaborate;
@@ -444,7 +446,8 @@ private
type pid_t is new int;
- type time_t is new long;
+ type time_t is range -2 ** (System.Parameters.time_t_bits - 1)
+ .. 2 ** (System.Parameters.time_t_bits - 1) - 1;
type timespec is record
tv_sec : time_t;
diff --git a/gcc/ada/libgnarl/s-osinte__hpux.ads b/gcc/ada/libgnarl/s-osinte__hpux.ads
index 954b409..c94b84c 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1995-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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,6 +42,8 @@ with Ada.Unchecked_Conversion;
with Interfaces.C;
+with System.Parameters;
+
package System.OS_Interface is
pragma Preelaborate;
@@ -514,7 +516,8 @@ private
type pid_t is new int;
- type time_t is new long;
+ type time_t is range -2 ** (System.Parameters.time_t_bits - 1)
+ .. 2 ** (System.Parameters.time_t_bits - 1) - 1;
type timespec is record
tv_sec : time_t;
diff --git a/gcc/ada/libgnarl/s-osinte__kfreebsd-gnu.ads b/gcc/ada/libgnarl/s-osinte__kfreebsd-gnu.ads
index 36003eb..de91ee8 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1995-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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,6 +39,7 @@
-- Preelaborate. This package is designed to be a bottom-level (leaf) package
with Interfaces.C;
+with System.Parameters;
with Unchecked_Conversion;
package System.OS_Interface is
@@ -598,7 +599,8 @@ private
type pid_t is new int;
- type time_t is new long;
+ type time_t is range -2 ** (System.Parameters.time_t_bits - 1)
+ .. 2 ** (System.Parameters.time_t_bits - 1) - 1;
type timespec is record
tv_sec : time_t;
diff --git a/gcc/ada/libgnarl/s-osinte__linux.ads b/gcc/ada/libgnarl/s-osinte__linux.ads
index 2272f83..cda0f8e 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1995-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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,8 @@ package System.OS_Interface is
pragma Linker_Options ("-lpthread");
+ use type System.Linux.time_t;
+
subtype int is Interfaces.C.int;
subtype char is Interfaces.C.char;
subtype short is Interfaces.C.short;
diff --git a/gcc/ada/libgnarl/s-osinte__lynxos178.adb b/gcc/ada/libgnarl/s-osinte__lynxos178.adb
index 79099d7..25d9b23 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-2020, AdaCore --
+-- Copyright (C) 2001-2021, 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 6d84b35..4f38a53 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1995-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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,7 @@ with Ada.Unchecked_Conversion;
with Interfaces.C;
with System.Multiprocessors;
+with System.Parameters;
package System.OS_Interface is
pragma Preelaborate;
@@ -539,7 +540,8 @@ private
type pid_t is new long;
- type time_t is new int64;
+ type time_t is range -2 ** (System.Parameters.time_t_bits - 1)
+ .. 2 ** (System.Parameters.time_t_bits - 1) - 1;
type suseconds_t is new int;
diff --git a/gcc/ada/libgnarl/s-osinte__mingw.ads b/gcc/ada/libgnarl/s-osinte__mingw.ads
index 11c5776..affff6c 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1995-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute 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 4818162..182366f 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-2020, AdaCore --
+-- Copyright (C) 1995-2021, 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 45b7ea7..6612684 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-2020, AdaCore --
+-- Copyright (C) 1995-2021, 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 1855d3c..28abfbe 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1995-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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,6 +40,7 @@
with Ada.Unchecked_Conversion;
with Interfaces.C;
with System.OS_Constants;
+with System.Parameters;
package System.OS_Interface is
pragma Preelaborate;
@@ -566,7 +567,8 @@ private
type pid_t is new int;
- type time_t is new long;
+ type time_t is range -2 ** (System.Parameters.time_t_bits - 1)
+ .. 2 ** (System.Parameters.time_t_bits - 1) - 1;
type timespec is record
tv_sec : time_t;
diff --git a/gcc/ada/libgnarl/s-osinte__rtems.adb b/gcc/ada/libgnarl/s-osinte__rtems.adb
index 06cf1ab..cd977d0 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1995-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute 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 05a0c9e..ffbfc3a 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1997-2021, 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- --
@@ -52,6 +52,7 @@
with Interfaces.C;
with System.OS_Constants;
+with System.Parameters;
package System.OS_Interface is
pragma Preelaborate;
@@ -617,7 +618,8 @@ private
type pid_t is new int;
- type time_t is new Long_Long_Integer;
+ type time_t is range -2 ** (System.Parameters.time_t_bits - 1)
+ .. 2 ** (System.Parameters.time_t_bits - 1) - 1;
type timespec is record
tv_sec : time_t;
diff --git a/gcc/ada/libgnarl/s-osinte__solaris.adb b/gcc/ada/libgnarl/s-osinte__solaris.adb
index adfc386..65bd784 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-2020, AdaCore --
+-- Copyright (C) 1995-2021, 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 b9d6b88..29e1026 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1995-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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,6 +42,8 @@ with Interfaces.C;
with Ada.Unchecked_Conversion;
+with System.Parameters;
+
package System.OS_Interface is
pragma Preelaborate;
@@ -523,7 +525,8 @@ private
type pid_t is new long;
- type time_t is new long;
+ type time_t is range -2 ** (System.Parameters.time_t_bits - 1)
+ .. 2 ** (System.Parameters.time_t_bits - 1) - 1;
type timespec is record
tv_sec : time_t;
diff --git a/gcc/ada/libgnarl/s-osinte__vxworks.adb b/gcc/ada/libgnarl/s-osinte__vxworks.adb
index e88a9af..cf3ece3 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1997-2021, 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 3b39bce..a2d5620 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1995-2021, 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,6 +42,7 @@ with Interfaces.C;
with System.VxWorks;
with System.VxWorks.Ext;
with System.Multiprocessors;
+with System.Parameters;
package System.OS_Interface is
pragma Preelaborate;
@@ -239,7 +240,11 @@ package System.OS_Interface is
-- Time --
----------
- type time_t is new unsigned_long;
+ type time_t is range -2 ** (System.Parameters.time_t_bits - 1)
+ .. 2 ** (System.Parameters.time_t_bits - 1) - 1;
+ -- Time_t here used to be unsigned to match the VxWorks header declaration.
+ -- The header declaration has changed in newer releases and is now signed
+ -- for applications.
type timespec is record
ts_sec : time_t;
diff --git a/gcc/ada/libgnarl/s-osinte__x32.adb b/gcc/ada/libgnarl/s-osinte__x32.adb
index 8a7cb4c..58f5b2d 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-2020, AdaCore --
+-- Copyright (C) 1995-2021, 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 216ee42..b1fa4c2 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1996-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute 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 0248cb7..a8d9673 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1996-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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/libgnarl/s-putaim.adb
index 08fa7b7..687ac0e 100644
--- a/gcc/ada/libgnat/s-putaim.adb
+++ b/gcc/ada/libgnarl/s-putaim.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2020-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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 +29,10 @@
-- --
------------------------------------------------------------------------------
-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
+ use Ada.Strings.Text_Buffers;
+
procedure Put_Image_Protected (S : in out Sink'Class) is
begin
Put_UTF_8 (S, "(protected object)");
diff --git a/gcc/ada/libgnat/s-putaim.ads b/gcc/ada/libgnarl/s-putaim.ads
index b4dd8c2..ff0c344 100644
--- a/gcc/ada/libgnat/s-putaim.ads
+++ b/gcc/ada/libgnarl/s-putaim.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2020-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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,7 @@
-- --
------------------------------------------------------------------------------
-with Ada.Strings.Text_Output;
+with Ada.Strings.Text_Buffers;
with Ada.Task_Identification;
package System.Put_Task_Images is
@@ -39,7 +39,7 @@ package System.Put_Task_Images is
-- separate from System.Put_Images to avoid dragging the tasking runtimes
-- into nontasking programs.
- subtype Sink is Ada.Strings.Text_Output.Sink;
+ subtype Sink is Ada.Strings.Text_Buffers.Root_Buffer_Type;
procedure Put_Image_Protected (S : in out Sink'Class);
procedure Put_Image_Task
diff --git a/gcc/ada/libgnarl/s-qnx.ads b/gcc/ada/libgnarl/s-qnx.ads
index 00c4a7d..811c41c 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2017-2021, 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,6 +37,8 @@
with Interfaces.C;
+with System.Parameters;
+
package System.QNX is
pragma Preelaborate;
@@ -46,7 +48,8 @@ package System.QNX is
subtype long is Interfaces.C.long;
subtype suseconds_t is Interfaces.C.long;
- subtype time_t is Interfaces.C.long;
+ type time_t is range -2 ** (System.Parameters.time_t_bits - 1)
+ .. 2 ** (System.Parameters.time_t_bits - 1) - 1;
subtype clockid_t is Interfaces.C.int;
type timespec is record
diff --git a/gcc/ada/libgnarl/s-solita.adb b/gcc/ada/libgnarl/s-solita.adb
index ac35781..b1da6d8 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute 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 51dc585..92582a2 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2009-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute 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 80be087..959930b 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2009-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute 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 fd7088c..6ca8068 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2009-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute 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 9c4340c..67cd4a9 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1998-2021, 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-taasde.ads b/gcc/ada/libgnarl/s-taasde.ads
index 002ede9..c1b93e0 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1998-2021, 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 512e0ca..7badae8 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1998-2021, 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 7af3c06..22a9e08 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1998-2021, 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 bc8f09b..49460fa 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1998-2021, 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 db65536..5fa7a51 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1998-2021, 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 49c4c30..cd7a397 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, 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.ads b/gcc/ada/libgnarl/s-taenca.ads
index 2b013eb..72ad012 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, 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-taprob.adb b/gcc/ada/libgnarl/s-taprob.adb
index 6ce522a..754d175 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-2020, AdaCore --
+-- Copyright (C) 1995-2021, 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 c336225..5dce1e8 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, 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 32faac5..50d4708 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, 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__dummy.adb b/gcc/ada/libgnarl/s-taprop__dummy.adb
index 7e9093a..8a28ff7 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, 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 0e00511..ebd8941 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, 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__linux.adb b/gcc/ada/libgnarl/s-taprop__linux.adb
index 757a6cd..93ffb3a 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, 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__mingw.adb b/gcc/ada/libgnarl/s-taprop__mingw.adb
index 4405231..4d9b163 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, 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__posix.adb b/gcc/ada/libgnarl/s-taprop__posix.adb
index 8ecb293..3dc12c8 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, 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__qnx.adb b/gcc/ada/libgnarl/s-taprop__qnx.adb
index e3ad521..9446e37 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, 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__solaris.adb b/gcc/ada/libgnarl/s-taprop__solaris.adb
index 3084842..4c449b6 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, 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__vxworks.adb b/gcc/ada/libgnarl/s-taprop__vxworks.adb
index c9d019e..a87d1a0 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, 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-tarest.adb b/gcc/ada/libgnarl/s-tarest.adb
index 4555101..23c2cf7 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1999-2021, 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-tarest.ads b/gcc/ada/libgnarl/s-tarest.ads
index 9c67a83..265a26d 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, 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 f1f3989..d4f37f0 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1997-2021, 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 9e0f0ff..eebb2a9 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1997-2021, 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- --
@@ -65,9 +65,11 @@ package System.Tasking.Debug is
-- General GDB support --
-------------------------
- Known_Tasks : array (0 .. 999) of Task_Id := (others => null);
+ Known_Tasks : array (0 .. 999) of Task_Id := (others => null)
+ with Atomic_Components;
-- Global array of tasks read by gdb, and updated by Create_Task and
- -- Finalize_TCB
+ -- Finalize_TCB. Ensure access to its components is atomic to allow
+ -- lock-free concurrent access.
Debug_Event_Activating : constant := 1;
Debug_Event_Run : constant := 2;
diff --git a/gcc/ada/libgnarl/s-tasinf.adb b/gcc/ada/libgnarl/s-tasinf.adb
index 2636de9..12cefa7 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1998-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute 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 a05ddf5..39609c8 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute 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 ad0b422..a2938e2 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2009-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute 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 df25fbe..e6da750 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2007-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute 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 397cdfe..c67ea33 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2007-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute 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 9296345..184be2f 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2007-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute 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 91c849b..e4e0765 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute 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 58687fd..eed76c6 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute 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 52eb587..cb648be 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute 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 2080ac2..9acfa49 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, 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- --
@@ -420,7 +420,7 @@ package body System.Tasking.Initialization is
when Terminated
| Unactivated
=>
- pragma Assert (False);
+ pragma Assert (Standard.False);
null;
when Activating
@@ -535,7 +535,7 @@ package body System.Tasking.Initialization is
C := C.Common.All_Tasks_Link;
end loop;
- pragma Assert (False);
+ pragma Assert (Standard.False);
end Remove_From_All_Tasks_List;
---------------
diff --git a/gcc/ada/libgnarl/s-tasini.ads b/gcc/ada/libgnarl/s-tasini.ads
index f8fc3e9..f35df576 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, 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 16171c1..0090964 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, 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 db1e3b9..5c03829 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, 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- --
@@ -773,6 +773,9 @@ package System.Tasking is
Environment_Task_Level : constant Master_Level := 1;
Independent_Task_Level : constant Master_Level := 2;
Library_Task_Level : constant Master_Level := 3;
+ -- Note that the value of Library_Task_Level is also hard coded in the
+ -- compiler, see Rtsfind.Library_Task_Level. The two should be kept in
+ -- sync.
-------------------
-- Priority info --
diff --git a/gcc/ada/libgnarl/s-taspri__dummy.ads b/gcc/ada/libgnarl/s-taspri__dummy.ads
index 7d87e22..d26d93c 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1991-2021, 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 e5bb2eb..31c608e 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1991-2021, 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 36bb3a5..466bdda 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-2020, AdaCore --
+-- Copyright (C) 1995-2021, 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 8199a36..dfb40fd 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1991-2021, 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 6b19345..7fdae10 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-2020, AdaCore --
+-- Copyright (C) 1995-2021, 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 5621754..8859c5c 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-2020, AdaCore --
+-- Copyright (C) 1995-2021, 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 6e963d5..e390973 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, 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 2c7aadd..157361a 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2001-2021, 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 7a9211a..28f033a 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, 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.ads b/gcc/ada/libgnarl/s-tasque.ads
index 0754019..bb2f421 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, 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-tasren.adb b/gcc/ada/libgnarl/s-tasren.adb
index b7ee865..9498ca0 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, 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- --
@@ -165,7 +165,7 @@ package body System.Tasking.Rendezvous is
-- Should never get here ???
- pragma Assert (False);
+ pragma Assert (Standard.False);
raise Standard'Abort_Signal;
end if;
@@ -236,7 +236,7 @@ package body System.Tasking.Rendezvous is
-- Should never get here ???
- pragma Assert (False);
+ pragma Assert (Standard.False);
raise Standard'Abort_Signal;
end if;
@@ -646,7 +646,7 @@ package body System.Tasking.Rendezvous is
-- Should never get here ???
- pragma Assert (False);
+ pragma Assert (Standard.False);
raise Standard'Abort_Signal;
end if;
@@ -1251,7 +1251,7 @@ package body System.Tasking.Rendezvous is
-- Should never get here ???
- pragma Assert (False);
+ pragma Assert (Standard.False);
raise Standard'Abort_Signal;
end if;
@@ -1400,7 +1400,7 @@ package body System.Tasking.Rendezvous is
-- Should never get here
- pragma Assert (False);
+ pragma Assert (Standard.False);
null;
end case;
diff --git a/gcc/ada/libgnarl/s-tasren.ads b/gcc/ada/libgnarl/s-tasren.ads
index 52b21c3..0b1054d 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, 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-tasres.ads b/gcc/ada/libgnarl/s-tasres.ads
index b108e5b..57acd5d 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1998-2021, 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 900b3b7..88850c2 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, 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- --
@@ -578,7 +578,7 @@ package body System.Tasking.Stages is
-- ??? Should never get here
- pragma Assert (False);
+ pragma Assert (Standard.False);
raise Standard'Abort_Signal;
end if;
@@ -910,12 +910,12 @@ package body System.Tasking.Stages is
Self_Id : constant Task_Id := Self;
begin
+ Initialization.Task_Lock (Self_Id);
+
if T.Common.State = Terminated then
-- It is not safe to call Abort_Defer or Write_Lock at this stage
- Initialization.Task_Lock (Self_Id);
-
Lock_RTS;
Initialization.Finalize_Attributes (T);
Initialization.Remove_From_All_Tasks_List (T);
@@ -930,6 +930,7 @@ package body System.Tasking.Stages is
-- upon termination.
T.Free_On_Termination := True;
+ Initialization.Task_Unlock (Self_Id);
end if;
end Free_Task;
diff --git a/gcc/ada/libgnarl/s-tassta.ads b/gcc/ada/libgnarl/s-tassta.ads
index 772d058..9883b0c 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, 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 6dbd1f06..312ab0e 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, 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.ads b/gcc/ada/libgnarl/s-tasuti.ads
index 1ef237e..1162569 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, 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-tataat.adb b/gcc/ada/libgnarl/s-tataat.adb
index 8ca1b8e..d3b23bb 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2014-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute 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 5515edb4..590f770 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2014-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute 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 fbed553..1704691 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1998-2021, 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 1d91f19..b996d8f 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1998-2021, 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 44eb7c0..cf611ba 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2011-2021, 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 ae06ede..896ee0c 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1998-2021, 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.ads b/gcc/ada/libgnarl/s-tpoben.ads
index 0455f55..eb8bf79 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, 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 d5b6310..2c60dba 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-2020, AdaCore --
+-- Copyright (C) 2010-2021, 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- --
@@ -38,7 +38,7 @@ package body System.Tasking.Protected_Objects.Multiprocessors is
procedure Served (Entry_Call : Entry_Call_Link) is
pragma Unreferenced (Entry_Call);
begin
- pragma Assert (False, "Invalid operation");
+ pragma Assert (Standard.False, "Invalid operation");
end Served;
-------------------------
@@ -47,7 +47,7 @@ package body System.Tasking.Protected_Objects.Multiprocessors is
procedure Wakeup_Served_Entry is
begin
- pragma Assert (False, "Invalid operation");
+ pragma Assert (Standard.False, "Invalid operation");
end Wakeup_Served_Entry;
end System.Tasking.Protected_Objects.Multiprocessors;
diff --git a/gcc/ada/libgnarl/s-tpobmu.ads b/gcc/ada/libgnarl/s-tpobmu.ads
index 8487606..0b263a0 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-2020, AdaCore --
+-- Copyright (C) 2010-2021, 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 b123c19..5739eaa 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1998-2021, 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- --
@@ -601,7 +601,7 @@ package body System.Tasking.Protected_Objects.Operations is
when Asynchronous_Call
| Timed_Call
=>
- pragma Assert (False);
+ pragma Assert (Standard.False);
null;
end case;
end if;
diff --git a/gcc/ada/libgnarl/s-tpobop.ads b/gcc/ada/libgnarl/s-tpobop.ads
index 45bd936..2eea2f9 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, 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 ab70679..393c2a6 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, 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- --
@@ -208,7 +208,7 @@ package body Monotonic is
exit Inner;
when others =>
- pragma Assert (False);
+ pragma Assert (Standard.False);
end case;
@@ -292,7 +292,7 @@ package body Monotonic is
when 0 | EINTR => null;
when others =>
- pragma Assert (False);
+ pragma Assert (Standard.False);
end case;
diff --git a/gcc/ada/libgnarl/s-tpopsp__posix-foreign.adb b/gcc/ada/libgnarl/s-tpopsp__posix-foreign.adb
index e9fd0f9..119040b 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, 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 abe4079..6db716d 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, 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 d628f95..4e5cd5b 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, 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 26171b4..59ea2bc 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, 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 9459841..e5d4089 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute 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 e8fa9bd..5fe71d2 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute 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 265ea2f..2d7cf00 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, 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 634eae6..b8ef156 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2002-2021, 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 eb01580..a1ecbe2 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1998-2021, 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.ads b/gcc/ada/libgnarl/s-tposen.ads
index a340697..f56906f 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute 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 ef36c4f..0e1a792 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2009-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute 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 76c2113..915db33 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2008-2021, 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 99c3c56..ea1f71c 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2008-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute 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 7c15add..4743540 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2008-2021, 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 92fc8f1..3c200a1 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2008-2021, 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 761533e..421781f 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2008-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute 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 a48c82c..241a8f5 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2008-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute 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 f60c8bc..f188ff8 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2008-2021, 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 229fc8f..d13344e 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2008-2021, 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 3601688..e97561e 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2008-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute 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 b778f25..bf9d774 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1998-2021, 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 781626c..9e712dc 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1998-2021, 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 2c153a7..4fe277b 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1998-2021, 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 cbe1a61..df1ccda 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1998-2021, 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 636c619..bf23742 100644
--- a/gcc/ada/libgnarl/thread.c
+++ b/gcc/ada/libgnarl/thread.c
@@ -6,7 +6,7 @@
* *
* C Implementation File *
* *
- * Copyright (C) 2011-2020, Free Software Foundation, Inc. *
+ * Copyright (C) 2011-2021, Free Software Foundation, Inc. *
* *
* GNAT is free software; you can redistribute it 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 f3fb837..cbb97ac 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2007-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 f7aef0f..0a590d6 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2015-2021, Free Software Foundation, Inc. --
-- --
-- S p e c --
-- --
@@ -39,23 +39,12 @@
pragma Assertion_Policy (Pre => Ignore);
--- We do a with of System.Assertions to get hold of the exception (following
--- the specific RM permission that lets' Assertion_Error being a renaming).
--- The suppression of Warnings stops the warning about bad categorization.
-
-pragma Warnings (Off);
-with System.Assertions;
-pragma Warnings (On);
+pragma Compiler_Unit_Warning;
package Ada.Assertions with
- SPARK_Mode
+ SPARK_Mode, Pure
is
- pragma Pure (Assertions);
-
- Assertion_Error : exception renames System.Assertions.Assert_Failure;
- -- This is the renaming that is allowed by 11.4.2(24). Note that the
- -- Exception_Name will refer to the one in System.Assertions (see
- -- AARM-11.4.1(12.b)).
+ Assertion_Error : exception;
procedure Assert (Check : Boolean) with
Pre => Check;
diff --git a/gcc/ada/libgnat/a-btgbso.adb b/gcc/ada/libgnat/a-btgbso.adb
index 75c6dd5..0620a87 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 a30ccf3..da47c49 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 27d6da4..31b9c74 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2006-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 f319572..ad1fff4 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2005-2021, 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 3b5ec6b..6a017a9 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2008-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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-calcon.ads b/gcc/ada/libgnat/a-calcon.ads
index 23f176e..5a8a19a 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2008-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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-caldel.adb b/gcc/ada/libgnat/a-caldel.adb
index 5b64ef7..70877d0 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-2020, AdaCore --
+-- Copyright (C) 1995-2021, 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/a-caldel.ads b/gcc/ada/libgnat/a-caldel.ads
index 9fa5d60..eba238e 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, 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 f457412..8295a7c 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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.ads b/gcc/ada/libgnat/a-calend.ads
index e7eb3ef..cd3fed5 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, 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-calfor.adb b/gcc/ada/libgnat/a-calfor.adb
index 7d53d56..cb6c179 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2006-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 599e395..2bc030b 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2005-2021, 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-catizo.adb b/gcc/ada/libgnat/a-catizo.adb
index f183445..ec70122 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2009-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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-cbdlli.adb b/gcc/ada/libgnat/a-cbdlli.adb
index 948b706..143805e 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -312,7 +312,7 @@ is
Container.TC'Unrestricted_Access;
begin
return R : constant Constant_Reference_Type :=
- (Element => N.Element'Access,
+ (Element => N.Element'Unchecked_Access,
Control => (Controlled with TC))
do
Busy (TC.all);
@@ -1504,7 +1504,7 @@ is
---------------
procedure Put_Image
- (S : in out Ada.Strings.Text_Output.Sink'Class; V : List)
+ (S : in out Ada.Strings.Text_Buffers.Root_Buffer_Type'Class; V : List)
is
First_Time : Boolean := True;
use System.Put_Images;
@@ -1608,7 +1608,7 @@ is
Container.TC'Unrestricted_Access;
begin
return R : constant Reference_Type :=
- (Element => N.Element'Access,
+ (Element => N.Element'Unchecked_Access,
Control => (Controlled with TC))
do
Busy (TC.all);
diff --git a/gcc/ada/libgnat/a-cbdlli.ads b/gcc/ada/libgnat/a-cbdlli.ads
index 4574aa6..ab55086 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2021, 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,7 +36,7 @@ with Ada.Iterator_Interfaces;
with Ada.Containers.Helpers;
private with Ada.Streams;
private with Ada.Finalization;
-private with Ada.Strings.Text_Output;
+private with Ada.Strings.Text_Buffers;
generic
type Element_Type is private;
@@ -285,7 +285,7 @@ private
end record with Put_Image => Put_Image;
procedure Put_Image
- (S : in out Ada.Strings.Text_Output.Sink'Class; V : List);
+ (S : in out Ada.Strings.Text_Buffers.Root_Buffer_Type'Class; V : List);
procedure Read
(Stream : not null access Root_Stream_Type'Class;
diff --git a/gcc/ada/libgnat/a-cbhama.adb b/gcc/ada/libgnat/a-cbhama.adb
index 7f0c0e6..26c01f5 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -213,7 +213,7 @@ is
Container.TC'Unrestricted_Access;
begin
return R : constant Constant_Reference_Type :=
- (Element => N.Element'Access,
+ (Element => N.Element'Unchecked_Access,
Control => (Controlled with TC))
do
Busy (TC.all);
@@ -239,7 +239,7 @@ is
Container.TC'Unrestricted_Access;
begin
return R : constant Constant_Reference_Type :=
- (Element => N.Element'Access,
+ (Element => N.Element'Unchecked_Access,
Control => (Controlled with TC))
do
Busy (TC.all);
@@ -902,7 +902,7 @@ is
---------------
procedure Put_Image
- (S : in out Ada.Strings.Text_Output.Sink'Class; V : Map)
+ (S : in out Ada.Strings.Text_Buffers.Root_Buffer_Type'Class; V : Map)
is
First_Time : Boolean := True;
use System.Put_Images;
@@ -1028,7 +1028,7 @@ is
Container.TC'Unrestricted_Access;
begin
return R : constant Reference_Type :=
- (Element => N.Element'Access,
+ (Element => N.Element'Unchecked_Access,
Control => (Controlled with TC))
do
Busy (TC.all);
@@ -1053,7 +1053,7 @@ is
Container.TC'Unrestricted_Access;
begin
return R : constant Reference_Type :=
- (Element => N.Element'Access,
+ (Element => N.Element'Unchecked_Access,
Control => (Controlled with TC))
do
Busy (TC.all);
diff --git a/gcc/ada/libgnat/a-cbhama.ads b/gcc/ada/libgnat/a-cbhama.ads
index 7a1d0f6..8be64c8 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2021, 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,7 +36,7 @@ with Ada.Iterator_Interfaces;
private with Ada.Containers.Hash_Tables;
private with Ada.Streams;
private with Ada.Finalization;
-private with Ada.Strings.Text_Output;
+private with Ada.Strings.Text_Buffers;
generic
type Key_Type is private;
@@ -349,7 +349,7 @@ private
with null record with Put_Image => Put_Image;
procedure Put_Image
- (S : in out Ada.Strings.Text_Output.Sink'Class; V : Map);
+ (S : in out Ada.Strings.Text_Buffers.Root_Buffer_Type'Class; V : Map);
use HT_Types, HT_Types.Implementation;
use Ada.Streams;
diff --git a/gcc/ada/libgnat/a-cbhase.adb b/gcc/ada/libgnat/a-cbhase.adb
index 75b9667..d6ab353 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -232,7 +232,7 @@ is
Container.TC'Unrestricted_Access;
begin
return R : constant Constant_Reference_Type :=
- (Element => N.Element'Access,
+ (Element => N.Element'Unchecked_Access,
Control => (Controlled with TC))
do
Busy (TC.all);
@@ -1125,7 +1125,7 @@ is
---------------
procedure Put_Image
- (S : in out Ada.Strings.Text_Output.Sink'Class; V : Set)
+ (S : in out Ada.Strings.Text_Buffers.Root_Buffer_Type'Class; V : Set)
is
First_Time : Boolean := True;
use System.Put_Images;
@@ -1643,7 +1643,7 @@ is
Container.TC'Unrestricted_Access;
begin
return R : constant Constant_Reference_Type :=
- (Element => N.Element'Access,
+ (Element => N.Element'Unchecked_Access,
Control => (Controlled with TC))
do
Busy (TC.all);
diff --git a/gcc/ada/libgnat/a-cbhase.ads b/gcc/ada/libgnat/a-cbhase.ads
index c82a123..92926c1 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2021, 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 @@ private with Ada.Containers.Hash_Tables;
with Ada.Containers.Helpers;
private with Ada.Streams;
private with Ada.Finalization;
-private with Ada.Strings.Text_Output;
+private with Ada.Strings.Text_Buffers;
generic
type Element_Type is private;
@@ -507,7 +507,7 @@ private
with null record with Put_Image => Put_Image;
procedure Put_Image
- (S : in out Ada.Strings.Text_Output.Sink'Class; V : Set);
+ (S : in out Ada.Strings.Text_Buffers.Root_Buffer_Type'Class; V : Set);
use HT_Types, HT_Types.Implementation;
use Ada.Streams;
diff --git a/gcc/ada/libgnat/a-cbmutr.adb b/gcc/ada/libgnat/a-cbmutr.adb
index 3b25d20..e80eb5c 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2011-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -600,7 +600,7 @@ is
Container.TC'Unrestricted_Access;
begin
return R : constant Constant_Reference_Type :=
- (Element => Container.Elements (Position.Node)'Access,
+ (Element => Container.Elements (Position.Node)'Unchecked_Access,
Control => (Controlled with TC))
do
Busy (TC.all);
@@ -2328,7 +2328,7 @@ is
---------------
procedure Put_Image
- (S : in out Ada.Strings.Text_Output.Sink'Class; V : Tree)
+ (S : in out Ada.Strings.Text_Buffers.Root_Buffer_Type'Class; V : Tree)
is
use System.Put_Images;
@@ -2533,7 +2533,7 @@ is
Container.TC'Unrestricted_Access;
begin
return R : constant Reference_Type :=
- (Element => Container.Elements (Position.Node)'Access,
+ (Element => Container.Elements (Position.Node)'Unchecked_Access,
Control => (Controlled with TC))
do
Busy (TC.all);
diff --git a/gcc/ada/libgnat/a-cbmutr.ads b/gcc/ada/libgnat/a-cbmutr.ads
index d9a4a9a..c7e221a 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2014-2021, 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 --
@@ -35,7 +35,7 @@ with Ada.Iterator_Interfaces;
with Ada.Containers.Helpers;
private with Ada.Streams;
-private with Ada.Strings.Text_Output;
+private with Ada.Strings.Text_Buffers;
generic
type Element_Type is private;
@@ -311,7 +311,7 @@ private
end record with Put_Image => Put_Image;
procedure Put_Image
- (S : in out Ada.Strings.Text_Output.Sink'Class; V : Tree);
+ (S : in out Ada.Strings.Text_Buffers.Root_Buffer_Type'Class; V : Tree);
procedure Write
(Stream : not null access Root_Stream_Type'Class;
diff --git a/gcc/ada/libgnat/a-cborma.adb b/gcc/ada/libgnat/a-cborma.adb
index 5401847..f26a1e3 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -420,7 +420,7 @@ is
Container.TC'Unrestricted_Access;
begin
return R : constant Constant_Reference_Type :=
- (Element => N.Element'Access,
+ (Element => N.Element'Unchecked_Access,
Control => (Controlled with TC))
do
Busy (TC.all);
@@ -445,7 +445,7 @@ is
Container.TC'Unrestricted_Access;
begin
return R : constant Constant_Reference_Type :=
- (Element => N.Element'Access,
+ (Element => N.Element'Unchecked_Access,
Control => (Controlled with TC))
do
Busy (TC.all);
@@ -1306,7 +1306,7 @@ is
---------------
procedure Put_Image
- (S : in out Ada.Strings.Text_Output.Sink'Class; V : Map)
+ (S : in out Ada.Strings.Text_Buffers.Root_Buffer_Type'Class; V : Map)
is
First_Time : Boolean := True;
use System.Put_Images;
@@ -1417,7 +1417,7 @@ is
Container.TC'Unrestricted_Access;
begin
return R : constant Reference_Type :=
- (Element => N.Element'Access,
+ (Element => N.Element'Unchecked_Access,
Control => (Controlled with TC))
do
Busy (TC.all);
@@ -1442,7 +1442,7 @@ is
Container.TC'Unrestricted_Access;
begin
return R : constant Reference_Type :=
- (Element => N.Element'Access,
+ (Element => N.Element'Unchecked_Access,
Control => (Controlled with TC))
do
Busy (TC.all);
diff --git a/gcc/ada/libgnat/a-cborma.ads b/gcc/ada/libgnat/a-cborma.ads
index 4da71bc..f87522a 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2021, 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,7 +36,7 @@ with Ada.Iterator_Interfaces;
private with Ada.Containers.Red_Black_Trees;
private with Ada.Streams;
private with Ada.Finalization;
-private with Ada.Strings.Text_Output;
+private with Ada.Strings.Text_Buffers;
generic
type Key_Type is private;
@@ -257,7 +257,7 @@ private
with null record with Put_Image => Put_Image;
procedure Put_Image
- (S : in out Ada.Strings.Text_Output.Sink'Class; V : Map);
+ (S : in out Ada.Strings.Text_Buffers.Root_Buffer_Type'Class; V : Map);
use Red_Black_Trees;
use Tree_Types, Tree_Types.Implementation;
diff --git a/gcc/ada/libgnat/a-cborse.adb b/gcc/ada/libgnat/a-cborse.adb
index 41f0859..5c9a86e 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -420,7 +420,7 @@ is
Container.TC'Unrestricted_Access;
begin
return R : constant Constant_Reference_Type :=
- (Element => N.Element'Access,
+ (Element => N.Element'Unchecked_Access,
Control => (Controlled with TC))
do
Busy (TC.all);
@@ -752,7 +752,7 @@ is
Container.TC'Unrestricted_Access;
begin
return R : constant Constant_Reference_Type :=
- (Element => N.Element'Access,
+ (Element => N.Element'Unchecked_Access,
Control => (Controlled with TC))
do
Busy (TC.all);
@@ -943,7 +943,7 @@ is
N : Node_Type renames Container.Nodes (Position.Node);
begin
return R : constant Reference_Type :=
- (Element => N.Element'Access,
+ (Element => N.Element'Unchecked_Access,
Control =>
(Controlled with
Container.TC'Unrestricted_Access,
@@ -971,7 +971,7 @@ is
N : Node_Type renames Container.Nodes (Node);
begin
return R : constant Reference_Type :=
- (Element => N.Element'Access,
+ (Element => N.Element'Unchecked_Access,
Control =>
(Controlled with
Container.TC'Unrestricted_Access,
@@ -1645,7 +1645,7 @@ is
---------------
procedure Put_Image
- (S : in out Ada.Strings.Text_Output.Sink'Class; V : Set)
+ (S : in out Ada.Strings.Text_Buffers.Root_Buffer_Type'Class; V : Set)
is
First_Time : Boolean := True;
use System.Put_Images;
diff --git a/gcc/ada/libgnat/a-cborse.ads b/gcc/ada/libgnat/a-cborse.ads
index 92a6df7..06bd20f 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2021, 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 Ada.Containers.Helpers;
private with Ada.Containers.Red_Black_Trees;
private with Ada.Streams;
private with Ada.Finalization;
-private with Ada.Strings.Text_Output;
+private with Ada.Strings.Text_Buffers;
generic
type Element_Type is private;
@@ -345,7 +345,7 @@ private
with null record with Put_Image => Put_Image;
procedure Put_Image
- (S : in out Ada.Strings.Text_Output.Sink'Class; V : Set);
+ (S : in out Ada.Strings.Text_Buffers.Root_Buffer_Type'Class; V : Set);
use Tree_Types, Tree_Types.Implementation;
use Ada.Finalization;
diff --git a/gcc/ada/libgnat/a-cbprqu.adb b/gcc/ada/libgnat/a-cbprqu.adb
index 2e97291..1d04579 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2011-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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-cbprqu.ads b/gcc/ada/libgnat/a-cbprqu.ads
index 6259a47..ec08aea 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2011-2021, 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-cbsyqu.adb b/gcc/ada/libgnat/a-cbsyqu.adb
index abb0e79..e4e6725 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2011-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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-cbsyqu.ads b/gcc/ada/libgnat/a-cbsyqu.ads
index 4037d84..8c8d5a6 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2011-2021, 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-cdlili.adb b/gcc/ada/libgnat/a-cdlili.adb
index 08c29f2..d989751 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -130,11 +130,6 @@ is
pragma Assert (Container.Last.Next = null);
pragma Assert (Container.Length > 0);
- Container.First := null;
- Container.Last := null;
- Container.Length := 0;
- Zero_Counts (Container.TC);
-
Container.First := new Node_Type'(Src.Element, null, null);
Container.Last := Container.First;
Container.Length := 1;
@@ -232,9 +227,7 @@ is
Container.Last := null;
Container.Length := 0;
- pragma Warnings (Off);
Free (X);
- pragma Warnings (On);
end Clear;
------------------------
@@ -682,68 +675,152 @@ is
procedure Sort (Container : in out List) is
- procedure Partition (Pivot : Node_Access; Back : Node_Access);
-
- procedure Sort (Front, Back : Node_Access);
-
- ---------------
- -- Partition --
- ---------------
+ type List_Descriptor is
+ record
+ First, Last : Node_Access;
+ Length : Count_Type;
+ end record;
+
+ function Merge_Sort (Arg : List_Descriptor) return List_Descriptor;
+ -- Sort list of given length using MergeSort; length must be >= 2.
+ -- As required by RM, the sort is stable.
+
+ ----------------
+ -- Merge_Sort --
+ ----------------
+
+ function Merge_Sort (Arg : List_Descriptor) return List_Descriptor
+ is
+ procedure Split_List
+ (Unsplit : List_Descriptor; Part1, Part2 : out List_Descriptor);
+ -- Split list into two parts for divide-and-conquer.
+ -- Unsplit.Length must be >= 2.
+
+ function Merge_Parts
+ (Part1, Part2 : List_Descriptor) return List_Descriptor;
+ -- Merge two sorted lists, preserving sorted property.
+
+ ----------------
+ -- Split_List --
+ ----------------
+
+ procedure Split_List
+ (Unsplit : List_Descriptor; Part1, Part2 : out List_Descriptor)
+ is
+ Rover : Node_Access := Unsplit.First;
+ Bump_Count : constant Count_Type := (Unsplit.Length - 1) / 2;
+ begin
+ for Iter in 1 .. Bump_Count loop
+ Rover := Rover.Next;
+ end loop;
+
+ Part1 := (First => Unsplit.First,
+ Last => Rover,
+ Length => Bump_Count + 1);
+
+ Part2 := (First => Rover.Next,
+ Last => Unsplit.Last,
+ Length => Unsplit.Length - Part1.Length);
+
+ -- Detach
+ Part1.Last.Next := null;
+ Part2.First.Prev := null;
+ end Split_List;
+
+ -----------------
+ -- Merge_Parts --
+ -----------------
+
+ function Merge_Parts
+ (Part1, Part2 : List_Descriptor) return List_Descriptor
+ is
+ Empty : constant List_Descriptor := (null, null, 0);
+
+ procedure Detach_First (Source : in out List_Descriptor;
+ Detached : out Node_Access);
+ -- Detach the first element from a non-empty list and
+ -- return the detached node via the Detached parameter.
+
+ ------------------
+ -- Detach_First --
+ ------------------
+
+ procedure Detach_First (Source : in out List_Descriptor;
+ Detached : out Node_Access) is
+ begin
+ Detached := Source.First;
+
+ if Source.Length = 1 then
+ Source := Empty;
+ else
+ Source := (Source.First.Next,
+ Source.Last,
+ Source.Length - 1);
+
+ Detached.Next.Prev := null;
+ Detached.Next := null;
+ end if;
+ end Detach_First;
+
+ P1 : List_Descriptor := Part1;
+ P2 : List_Descriptor := Part2;
+ Merged : List_Descriptor := Empty;
+
+ Take_From_P2 : Boolean;
+ Detached : Node_Access;
+
+ -- Start of processing for Merge_Parts
- procedure Partition (Pivot : Node_Access; Back : Node_Access) is
- Node : Node_Access;
+ begin
+ while (P1.Length /= 0) or (P2.Length /= 0) loop
+ if P1.Length = 0 then
+ Take_From_P2 := True;
+ elsif P2.Length = 0 then
+ Take_From_P2 := False;
+ else
+ -- If the compared elements are equal then Take_From_P2
+ -- must be False in order to ensure stability.
+
+ Take_From_P2 := P2.First.Element < P1.First.Element;
+ end if;
+
+ if Take_From_P2 then
+ Detach_First (P2, Detached);
+ else
+ Detach_First (P1, Detached);
+ end if;
+
+ if Merged.Length = 0 then
+ Merged := (First | Last => Detached, Length => 1);
+ else
+ Detached.Prev := Merged.Last;
+ Merged.Last.Next := Detached;
+ Merged.Last := Detached;
+ Merged.Length := Merged.Length + 1;
+ end if;
+ end loop;
+ return Merged;
+ end Merge_Parts;
+
+ -- Start of processing for Merge_Sort
begin
- Node := Pivot.Next;
- while Node /= Back loop
- if Node.Element < Pivot.Element then
- declare
- Prev : constant Node_Access := Node.Prev;
- Next : constant Node_Access := Node.Next;
-
- begin
- Prev.Next := Next;
-
- if Next = null then
- Container.Last := Prev;
- else
- Next.Prev := Prev;
- end if;
-
- Node.Next := Pivot;
- Node.Prev := Pivot.Prev;
-
- Pivot.Prev := Node;
-
- if Node.Prev = null then
- Container.First := Node;
- else
- Node.Prev.Next := Node;
- end if;
-
- Node := Next;
- end;
+ if Arg.Length < 2 then
+ -- already sorted
+ return Arg;
+ end if;
- else
- Node := Node.Next;
- end if;
- end loop;
- end Partition;
+ declare
+ Part1, Part2 : List_Descriptor;
+ begin
+ Split_List (Unsplit => Arg, Part1 => Part1, Part2 => Part2);
- ----------
- -- Sort --
- ----------
+ Part1 := Merge_Sort (Part1);
+ Part2 := Merge_Sort (Part2);
- procedure Sort (Front, Back : Node_Access) is
- Pivot : constant Node_Access :=
- (if Front = null then Container.First else Front.Next);
- begin
- if Pivot /= Back then
- Partition (Pivot, Back);
- Sort (Front, Pivot);
- Sort (Pivot, Back);
- end if;
- end Sort;
+ return Merge_Parts (Part1, Part2);
+ end;
+ end Merge_Sort;
-- Start of processing for Sort
@@ -761,9 +838,28 @@ is
-- element tampering by a generic actual subprogram.
declare
- Lock : With_Lock (Container.TC'Unchecked_Access);
+ Lock : With_Lock (Container.TC'Unchecked_Access);
+
+ Unsorted : constant List_Descriptor :=
+ (First => Container.First,
+ Last => Container.Last,
+ Length => Container.Length);
+
+ Sorted : List_Descriptor;
begin
- Sort (Front => null, Back => null);
+ -- If a call to the formal < operator references the container
+ -- during sorting, seeing an empty container seems preferable
+ -- to seeing an internally inconsistent container.
+ --
+ Container.First := null;
+ Container.Last := null;
+ Container.Length := 0;
+
+ Sorted := Merge_Sort (Unsorted);
+
+ Container.First := Sorted.First;
+ Container.Last := Sorted.Last;
+ Container.Length := Sorted.Length;
end;
pragma Assert (Container.First.Prev = null);
@@ -1269,7 +1365,7 @@ is
---------------
procedure Put_Image
- (S : in out Ada.Strings.Text_Output.Sink'Class; V : List)
+ (S : in out Ada.Strings.Text_Buffers.Root_Buffer_Type'Class; V : List)
is
First_Time : Boolean := True;
use System.Put_Images;
diff --git a/gcc/ada/libgnat/a-cdlili.ads b/gcc/ada/libgnat/a-cdlili.ads
index 53de78b..66368b5 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2021, 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,7 +36,7 @@ with Ada.Iterator_Interfaces;
with Ada.Containers.Helpers;
private with Ada.Finalization;
private with Ada.Streams;
-private with Ada.Strings.Text_Output;
+private with Ada.Strings.Text_Buffers;
generic
type Element_Type is private;
@@ -66,7 +66,9 @@ is
pragma Preelaborable_Initialization (Cursor);
Empty_List : constant List;
+
function Empty return List;
+ pragma Ada_2022 (Empty);
No_Element : constant Cursor;
@@ -286,7 +288,7 @@ private
end record with Put_Image => Put_Image;
procedure Put_Image
- (S : in out Ada.Strings.Text_Output.Sink'Class; V : List);
+ (S : in out Ada.Strings.Text_Buffers.Root_Buffer_Type'Class; V : List);
overriding procedure Adjust (Container : in out List);
diff --git a/gcc/ada/libgnat/a-cfdlli.adb b/gcc/ada/libgnat/a-cfdlli.adb
index 9713f4c..b289def 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2010-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -188,6 +188,22 @@ is
Free (Container, X);
end Clear;
+ ------------------------
+ -- Constant_Reference --
+ ------------------------
+
+ function Constant_Reference
+ (Container : aliased List;
+ Position : Cursor) return not null access constant Element_Type
+ is
+ begin
+ if not Has_Element (Container => Container, Position => Position) then
+ raise Constraint_Error with "Position cursor has no element";
+ end if;
+
+ return Container.Nodes (Position.Node).Element'Access;
+ end Constant_Reference;
+
--------------
-- Contains --
--------------
@@ -1376,6 +1392,22 @@ is
return (Node => Container.Nodes (Position.Node).Prev);
end Previous;
+ ---------------
+ -- Reference --
+ ---------------
+
+ function Reference
+ (Container : not null access List;
+ Position : Cursor) return not null access Element_Type
+ is
+ begin
+ if not Has_Element (Container.all, Position) then
+ raise Constraint_Error with "Position cursor has no element";
+ end if;
+
+ return Container.Nodes (Position.Node).Element'Access;
+ end Reference;
+
---------------------
-- Replace_Element --
---------------------
diff --git a/gcc/ada/libgnat/a-cfdlli.ads b/gcc/ada/libgnat/a-cfdlli.ads
index f7dbf04..8713d33 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2021, 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,6 +39,11 @@ generic
package Ada.Containers.Formal_Doubly_Linked_Lists with
SPARK_Mode
is
+ -- Contracts in this unit are meant for analysis only, not for run-time
+ -- checking.
+
+ pragma Assertion_Policy (Pre => Ignore);
+ pragma Assertion_Policy (Post => Ignore);
pragma Annotate (CodePeer, Skip_Analysis);
type List (Capacity : Count_Type) is private with
@@ -382,6 +387,53 @@ is
Model (Container),
P.Get (Positions (Container), Position));
+ function At_End (E : access constant List) return access constant List
+ is (E)
+ with Ghost,
+ Annotate => (GNATprove, At_End_Borrow);
+
+ function At_End
+ (E : access constant Element_Type) return access constant Element_Type
+ is (E)
+ with Ghost,
+ Annotate => (GNATprove, At_End_Borrow);
+
+ function Constant_Reference
+ (Container : aliased List;
+ Position : Cursor) return not null access constant Element_Type
+ with
+ Global => null,
+ Pre => Has_Element (Container, Position),
+ Post =>
+ Constant_Reference'Result.all =
+ Element (Model (Container), P.Get (Positions (Container), Position));
+
+ function Reference
+ (Container : not null access List;
+ Position : Cursor) return not null access Element_Type
+ with
+ Global => null,
+ Pre => Has_Element (Container.all, Position),
+ Post =>
+ Length (Container.all) = Length (At_End (Container).all)
+
+ -- Cursors are preserved
+
+ and Positions (Container.all) = Positions (At_End (Container).all)
+
+ -- Container will have Result.all at position Position
+
+ and At_End (Reference'Result).all =
+ Element (Model (At_End (Container).all),
+ P.Get (Positions (At_End (Container).all), Position))
+
+ -- All other elements are preserved
+
+ and M.Equal_Except
+ (Model (Container.all),
+ Model (At_End (Container).all),
+ P.Get (Positions (At_End (Container).all), Position));
+
procedure Move (Target : in out List; Source : in out List) with
Global => null,
Pre => Target.Capacity >= Length (Source),
@@ -1604,7 +1656,7 @@ private
type Node_Type is record
Prev : Count_Type'Base := -1;
Next : Count_Type;
- Element : Element_Type;
+ Element : aliased Element_Type;
end record;
function "=" (L, R : Node_Type) return Boolean is abstract;
diff --git a/gcc/ada/libgnat/a-cfhama.adb b/gcc/ada/libgnat/a-cfhama.adb
index b5c37d2..179b400 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2010-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -109,20 +109,21 @@ is
ENode : Count_Type;
begin
- Node := Left.First.Node;
+ Node := First (Left).Node;
while Node /= 0 loop
ENode :=
Find
(Container => Right,
- Key => Left.Nodes (Node).Key).Node;
+ Key => Left.Content.Nodes (Node).Key).Node;
if ENode = 0 or else
- Right.Nodes (ENode).Element /= Left.Nodes (Node).Element
+ Right.Content.Nodes (ENode).Element /=
+ Left.Content.Nodes (Node).Element
then
return False;
end if;
- Node := HT_Ops.Next (Left, Node);
+ Node := HT_Ops.Next (Left.Content, Node);
end loop;
return True;
@@ -145,7 +146,7 @@ is
--------------------
procedure Insert_Element (Source_Node : Count_Type) is
- N : Node_Type renames Source.Nodes (Source_Node);
+ N : Node_Type renames Source.Content.Nodes (Source_Node);
begin
Insert (Target, N.Key, N.Element);
end Insert_Element;
@@ -164,7 +165,7 @@ is
Clear (Target);
- Insert_Elements (Source);
+ Insert_Elements (Source.Content);
end Assign;
--------------
@@ -173,7 +174,7 @@ is
function Capacity (Container : Map) return Count_Type is
begin
- return Container.Nodes'Length;
+ return Container.Content.Nodes'Length;
end Capacity;
-----------
@@ -182,9 +183,44 @@ is
procedure Clear (Container : in out Map) is
begin
- HT_Ops.Clear (Container);
+ HT_Ops.Clear (Container.Content);
end Clear;
+ ------------------------
+ -- Constant_Reference --
+ ------------------------
+
+ function Constant_Reference
+ (Container : aliased Map;
+ Position : Cursor) return not null access constant Element_Type
+ is
+ begin
+ if not Has_Element (Container, Position) then
+ raise Constraint_Error with "Position cursor has no element";
+ end if;
+
+ pragma Assert
+ (Vet (Container, Position),
+ "bad cursor in function Constant_Reference");
+
+ return Container.Content.Nodes (Position.Node).Element'Access;
+ end Constant_Reference;
+
+ function Constant_Reference
+ (Container : aliased Map;
+ Key : Key_Type) return not null access constant Element_Type
+ is
+ Node : constant Count_Type := Find (Container, Key).Node;
+
+ begin
+ if Node = 0 then
+ raise Constraint_Error with
+ "no element available because key not in map";
+ end if;
+
+ return Container.Content.Nodes (Node).Element'Access;
+ end Constant_Reference;
+
--------------
-- Contains --
--------------
@@ -214,18 +250,18 @@ is
raise Capacity_Error;
end if;
- Target.Length := Source.Length;
- Target.Free := Source.Free;
+ Target.Content.Length := Source.Content.Length;
+ Target.Content.Free := Source.Content.Free;
H := 1;
while H <= Source.Modulus loop
- Target.Buckets (H) := Source.Buckets (H);
+ Target.Content.Buckets (H) := Source.Content.Buckets (H);
H := H + 1;
end loop;
N := 1;
while N <= Source.Capacity loop
- Target.Nodes (N) := Source.Nodes (N);
+ Target.Content.Nodes (N) := Source.Content.Nodes (N);
N := N + 1;
end loop;
@@ -255,7 +291,7 @@ is
X : Count_Type;
begin
- Key_Ops.Delete_Key_Sans_Free (Container, Key, X);
+ Key_Ops.Delete_Key_Sans_Free (Container.Content, Key, X);
if X = 0 then
raise Constraint_Error with "attempt to delete key not in map";
@@ -273,7 +309,7 @@ is
pragma Assert (Vet (Container, Position), "bad cursor in Delete");
- HT_Ops.Delete_Node_Sans_Free (Container, Position.Node);
+ HT_Ops.Delete_Node_Sans_Free (Container.Content, Position.Node);
Free (Container, Position.Node);
Position := No_Element;
@@ -292,7 +328,7 @@ is
"no element available because key not in map";
end if;
- return Container.Nodes (Node).Element;
+ return Container.Content.Nodes (Node).Element;
end Element;
function Element (Container : Map; Position : Cursor) return Element_Type is
@@ -304,7 +340,7 @@ is
pragma Assert
(Vet (Container, Position), "bad cursor in function Element");
- return Container.Nodes (Position.Node).Element;
+ return Container.Content.Nodes (Position.Node).Element;
end Element;
---------------------
@@ -326,7 +362,7 @@ is
procedure Exclude (Container : in out Map; Key : Key_Type) is
X : Count_Type;
begin
- Key_Ops.Delete_Key_Sans_Free (Container, Key, X);
+ Key_Ops.Delete_Key_Sans_Free (Container.Content, Key, X);
Free (Container, X);
end Exclude;
@@ -335,7 +371,7 @@ is
----------
function Find (Container : Map; Key : Key_Type) return Cursor is
- Node : constant Count_Type := Key_Ops.Find (Container, Key);
+ Node : constant Count_Type := Key_Ops.Find (Container.Content, Key);
begin
if Node = 0 then
@@ -350,7 +386,7 @@ is
-----------
function First (Container : Map) return Cursor is
- Node : constant Count_Type := HT_Ops.First (Container);
+ Node : constant Count_Type := HT_Ops.First (Container.Content);
begin
if Node = 0 then
@@ -407,7 +443,7 @@ is
----------
function Keys (Container : Map) return K.Sequence is
- Position : Count_Type := HT_Ops.First (Container);
+ Position : Count_Type := HT_Ops.First (Container.Content);
R : K.Sequence;
begin
@@ -415,8 +451,8 @@ is
-- for their postconditions.
while Position /= 0 loop
- R := K.Add (R, Container.Nodes (Position).Key);
- Position := HT_Ops.Next (Container, Position);
+ R := K.Add (R, Container.Content.Nodes (Position).Key);
+ Position := HT_Ops.Next (Container.Content, Position);
end loop;
return R;
@@ -458,7 +494,7 @@ is
-----------
function Model (Container : Map) return M.Map is
- Position : Count_Type := HT_Ops.First (Container);
+ Position : Count_Type := HT_Ops.First (Container.Content);
R : M.Map;
begin
@@ -469,10 +505,10 @@ is
R :=
M.Add
(Container => R,
- New_Key => Container.Nodes (Position).Key,
- New_Item => Container.Nodes (Position).Element);
+ New_Key => Container.Content.Nodes (Position).Key,
+ New_Item => Container.Content.Nodes (Position).Element);
- Position := HT_Ops.Next (Container, Position);
+ Position := HT_Ops.Next (Container.Content, Position);
end loop;
return R;
@@ -484,7 +520,7 @@ is
function Positions (Container : Map) return P.Map is
I : Count_Type := 1;
- Position : Count_Type := HT_Ops.First (Container);
+ Position : Count_Type := HT_Ops.First (Container.Content);
R : P.Map;
begin
@@ -494,7 +530,7 @@ is
while Position /= 0 loop
R := P.Add (R, (Node => Position), I);
pragma Assert (P.Length (R) = I);
- Position := HT_Ops.Next (Container, Position);
+ Position := HT_Ops.Next (Container.Content, Position);
I := I + 1;
end loop;
@@ -511,8 +547,8 @@ is
begin
if X /= 0 then
pragma Assert (X <= HT.Capacity);
- HT.Nodes (X).Has_Element := False;
- HT_Ops.Free (HT, X);
+ HT.Content.Nodes (X).Has_Element := False;
+ HT_Ops.Free (HT.Content, X);
end if;
end Free;
@@ -525,8 +561,8 @@ is
new HT_Ops.Generic_Allocate (Set_Element);
begin
- Allocate (HT, Node);
- HT.Nodes (Node).Has_Element := True;
+ Allocate (HT.Content, Node);
+ HT.Content.Nodes (Node).Has_Element := True;
end Generic_Allocate;
-----------------
@@ -536,7 +572,7 @@ is
function Has_Element (Container : Map; Position : Cursor) return Boolean is
begin
if Position.Node = 0
- or else not Container.Nodes (Position.Node).Has_Element
+ or else not Container.Content.Nodes (Position.Node).Has_Element
then
return False;
else
@@ -570,7 +606,7 @@ is
if not Inserted then
declare
- N : Node_Type renames Container.Nodes (Position.Node);
+ N : Node_Type renames Container.Content.Nodes (Position.Node);
begin
N.Key := Key;
N.Element := New_Item;
@@ -625,7 +661,7 @@ is
-- Start of processing for Insert
begin
- Local_Insert (Container, Key, Position.Node, Inserted);
+ Local_Insert (Container.Content, Key, Position.Node, Inserted);
end Insert;
procedure Insert
@@ -668,7 +704,7 @@ is
pragma Assert (Vet (Container, Position), "bad cursor in function Key");
- return Container.Nodes (Position.Node).Key;
+ return Container.Content.Nodes (Position.Node).Key;
end Key;
------------
@@ -677,7 +713,7 @@ is
function Length (Container : Map) return Count_Type is
begin
- return Container.Length;
+ return Container.Content.Length;
end Length;
----------
@@ -688,7 +724,7 @@ is
(Target : in out Map;
Source : in out Map)
is
- NN : HT_Types.Nodes_Type renames Source.Nodes;
+ NN : HT_Types.Nodes_Type renames Source.Content.Nodes;
X : Count_Type;
Y : Count_Type;
@@ -704,17 +740,17 @@ is
Clear (Target);
- if Source.Length = 0 then
+ if Source.Content.Length = 0 then
return;
end if;
- X := HT_Ops.First (Source);
+ X := HT_Ops.First (Source.Content);
while X /= 0 loop
Insert (Target, NN (X).Key, NN (X).Element); -- optimize???
- Y := HT_Ops.Next (Source, X);
+ Y := HT_Ops.Next (Source.Content, X);
- HT_Ops.Delete_Node_Sans_Free (Source, X);
+ HT_Ops.Delete_Node_Sans_Free (Source.Content, X);
Free (Source, X);
X := Y;
@@ -743,7 +779,8 @@ is
pragma Assert (Vet (Container, Position), "bad cursor in function Next");
declare
- Node : constant Count_Type := HT_Ops.Next (Container, Position.Node);
+ Node : constant Count_Type :=
+ HT_Ops.Next (Container.Content, Position.Node);
begin
if Node = 0 then
@@ -759,6 +796,40 @@ is
Position := Next (Container, Position);
end Next;
+ ---------------
+ -- Reference --
+ ---------------
+
+ function Reference
+ (Container : not null access Map;
+ Position : Cursor) return not null access Element_Type
+ is
+ begin
+ if not Has_Element (Container.all, Position) then
+ raise Constraint_Error with "Position cursor has no element";
+ end if;
+
+ pragma Assert
+ (Vet (Container.all, Position), "bad cursor in function Reference");
+
+ return Container.Content.Nodes (Position.Node).Element'Access;
+ end Reference;
+
+ function Reference
+ (Container : not null access Map;
+ Key : Key_Type) return not null access Element_Type
+ is
+ Node : constant Count_Type := Find (Container.all, Key).Node;
+
+ begin
+ if Node = 0 then
+ raise Constraint_Error with
+ "no element available because key not in map";
+ end if;
+
+ return Container.Content.Nodes (Node).Element'Access;
+ end Reference;
+
-------------
-- Replace --
-------------
@@ -768,7 +839,7 @@ is
Key : Key_Type;
New_Item : Element_Type)
is
- Node : constant Count_Type := Key_Ops.Find (Container, Key);
+ Node : constant Count_Type := Key_Ops.Find (Container.Content, Key);
begin
if Node = 0 then
@@ -776,7 +847,7 @@ is
end if;
declare
- N : Node_Type renames Container.Nodes (Node);
+ N : Node_Type renames Container.Content.Nodes (Node);
begin
N.Key := Key;
N.Element := New_Item;
@@ -801,7 +872,7 @@ is
pragma Assert
(Vet (Container, Position), "bad cursor in Replace_Element");
- Container.Nodes (Position.Node).Element := New_Item;
+ Container.Content.Nodes (Position.Node).Element := New_Item;
end Replace_Element;
----------------------
@@ -841,7 +912,7 @@ is
X : Count_Type;
begin
- if Container.Length = 0 then
+ if Container.Content.Length = 0 then
return False;
end if;
@@ -849,7 +920,7 @@ is
return False;
end if;
- if Container.Buckets'Length = 0 then
+ if Container.Content.Buckets'Length = 0 then
return False;
end if;
@@ -857,15 +928,17 @@ is
return False;
end if;
- if Container.Nodes (Position.Node).Next = Position.Node then
+ if Container.Content.Nodes (Position.Node).Next = Position.Node then
return False;
end if;
X :=
- Container.Buckets
- (Key_Ops.Index (Container, Container.Nodes (Position.Node).Key));
+ Container.Content.Buckets
+ (Key_Ops.Index
+ (Container.Content,
+ Container.Content.Nodes (Position.Node).Key));
- for J in 1 .. Container.Length loop
+ for J in 1 .. Container.Content.Length loop
if X = Position.Node then
return True;
end if;
@@ -874,14 +947,14 @@ is
return False;
end if;
- if X = Container.Nodes (X).Next then
+ if X = Container.Content.Nodes (X).Next then
-- Prevent unnecessary looping
return False;
end if;
- X := Container.Nodes (X).Next;
+ X := Container.Content.Nodes (X).Next;
end loop;
return False;
diff --git a/gcc/ada/libgnat/a-cfhama.ads b/gcc/ada/libgnat/a-cfhama.ads
index 8a73508..2b49c13 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2021, 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 --
@@ -64,6 +64,11 @@ generic
package Ada.Containers.Formal_Hashed_Maps with
SPARK_Mode
is
+ -- Contracts in this unit are meant for analysis only, not for run-time
+ -- checking.
+
+ pragma Assertion_Policy (Pre => Ignore);
+ pragma Assertion_Policy (Post => Ignore);
pragma Annotate (CodePeer, Skip_Analysis);
type Map (Capacity : Count_Type; Modulus : Hash_Type) is private with
@@ -389,6 +394,95 @@ is
Model (Container)'Old,
Key (Container, Position));
+ function At_End
+ (E : not null access constant Map) return not null access constant Map
+ is (E)
+ with Ghost,
+ Annotate => (GNATprove, At_End_Borrow);
+
+ function At_End
+ (E : access constant Element_Type) return access constant Element_Type
+ is (E)
+ with Ghost,
+ Annotate => (GNATprove, At_End_Borrow);
+
+ function Constant_Reference
+ (Container : aliased Map;
+ Position : Cursor) return not null access constant Element_Type
+ with
+ Global => null,
+ Pre => Has_Element (Container, Position),
+ Post =>
+ Constant_Reference'Result.all =
+ Element (Model (Container), Key (Container, Position));
+
+ function Reference
+ (Container : not null access Map;
+ Position : Cursor) return not null access Element_Type
+ with
+ Global => null,
+ Pre => Has_Element (Container.all, Position),
+ Post =>
+
+ -- Order of keys and cursors is preserved
+
+ Keys (At_End (Container).all) = Keys (Container.all)
+ and Positions (At_End (Container).all) = Positions (Container.all)
+
+ -- The value designated by the result of Reference is now associated
+ -- with the key at position Position in Container.
+
+ and Element (At_End (Container).all, Position) =
+ At_End (Reference'Result).all
+
+ -- Elements associated with other keys are preserved
+
+ and M.Same_Keys
+ (Model (At_End (Container).all),
+ Model (Container.all))
+ and M.Elements_Equal_Except
+ (Model (At_End (Container).all),
+ Model (Container.all),
+ Key (At_End (Container).all, Position));
+
+ function Constant_Reference
+ (Container : aliased Map;
+ Key : Key_Type) return not null access constant Element_Type
+ with
+ Global => null,
+ Pre => Contains (Container, Key),
+ Post =>
+ Constant_Reference'Result.all = Element (Model (Container), Key);
+
+ function Reference
+ (Container : not null access Map;
+ Key : Key_Type) return not null access Element_Type
+ with
+ Global => null,
+ Pre => Contains (Container.all, Key),
+ Post =>
+
+ -- Order of keys and cursors is preserved
+
+ Keys (At_End (Container).all) = Keys (Container.all)
+ and Positions (At_End (Container).all) = Positions (Container.all)
+
+ -- The value designated by the result of Reference is now associated
+ -- with Key in Container.
+
+ and Element (Model (At_End (Container).all), Key) =
+ At_End (Reference'Result).all
+
+ -- Elements associated with other keys are preserved
+
+ and M.Same_Keys
+ (Model (At_End (Container).all),
+ Model (Container.all))
+ and M.Elements_Equal_Except
+ (Model (At_End (Container).all),
+ Model (Container.all),
+ Key);
+
procedure Move (Target : in out Map; Source : in out Map) with
Global => null,
Pre => Target.Capacity >= Length (Source),
@@ -799,7 +893,7 @@ private
type Node_Type is record
Key : Key_Type;
- Element : Element_Type;
+ Element : aliased Element_Type;
Next : Count_Type;
Has_Element : Boolean := False;
end record;
@@ -807,8 +901,9 @@ private
package HT_Types is new
Ada.Containers.Hash_Tables.Generic_Bounded_Hash_Table_Types (Node_Type);
- type Map (Capacity : Count_Type; Modulus : Hash_Type) is
- new HT_Types.Hash_Table_Type (Capacity, Modulus) with null record;
+ type Map (Capacity : Count_Type; Modulus : Hash_Type) is record
+ Content : HT_Types.Hash_Table_Type (Capacity, Modulus);
+ end record;
Empty_Map : constant Map := (Capacity => 0, Modulus => 0, others => <>);
diff --git a/gcc/ada/libgnat/a-cfhase.adb b/gcc/ada/libgnat/a-cfhase.adb
index 121708c..cdb8a98 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2010-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -136,15 +136,16 @@ is
ENode :=
Find
(Container => Right,
- Item => Left.Nodes (Node).Element).Node;
+ Item => Left.Content.Nodes (Node).Element).Node;
if ENode = 0
- or else Right.Nodes (ENode).Element /= Left.Nodes (Node).Element
+ or else Right.Content.Nodes (ENode).Element /=
+ Left.Content.Nodes (Node).Element
then
return False;
end if;
- Node := HT_Ops.Next (Left, Node);
+ Node := HT_Ops.Next (Left.Content, Node);
end loop;
return True;
@@ -166,7 +167,7 @@ is
--------------------
procedure Insert_Element (Source_Node : Count_Type) is
- N : Node_Type renames Source.Nodes (Source_Node);
+ N : Node_Type renames Source.Content.Nodes (Source_Node);
X : Count_Type;
B : Boolean;
@@ -186,8 +187,8 @@ is
raise Storage_Error with "not enough capacity"; -- SE or CE? ???
end if;
- HT_Ops.Clear (Target);
- Insert_Elements (Source);
+ HT_Ops.Clear (Target.Content);
+ Insert_Elements (Source.Content);
end Assign;
--------------
@@ -196,7 +197,7 @@ is
function Capacity (Container : Set) return Count_Type is
begin
- return Container.Nodes'Length;
+ return Container.Content.Nodes'Length;
end Capacity;
-----------
@@ -205,9 +206,28 @@ is
procedure Clear (Container : in out Set) is
begin
- HT_Ops.Clear (Container);
+ HT_Ops.Clear (Container.Content);
end Clear;
+ ------------------------
+ -- Constant_Reference --
+ ------------------------
+
+ function Constant_Reference
+ (Container : aliased Set;
+ Position : Cursor) return not null access constant Element_Type
+ is
+ begin
+ if not Has_Element (Container, Position) then
+ raise Constraint_Error with "Position cursor equals No_Element";
+ end if;
+
+ pragma Assert
+ (Vet (Container, Position), "bad cursor in function Element");
+
+ return Container.Content.Nodes (Position.Node).Element'Access;
+ end Constant_Reference;
+
--------------
-- Contains --
--------------
@@ -237,18 +257,18 @@ is
raise Capacity_Error;
end if;
- Target.Length := Source.Length;
- Target.Free := Source.Free;
+ Target.Content.Length := Source.Content.Length;
+ Target.Content.Free := Source.Content.Free;
H := 1;
while H <= Source.Modulus loop
- Target.Buckets (H) := Source.Buckets (H);
+ Target.Content.Buckets (H) := Source.Content.Buckets (H);
H := H + 1;
end loop;
N := 1;
while N <= Source.Capacity loop
- Target.Nodes (N) := Source.Nodes (N);
+ Target.Content.Nodes (N) := Source.Content.Nodes (N);
N := N + 1;
end loop;
@@ -278,7 +298,7 @@ is
X : Count_Type;
begin
- Element_Keys.Delete_Key_Sans_Free (Container, Item, X);
+ Element_Keys.Delete_Key_Sans_Free (Container.Content, Item, X);
if X = 0 then
raise Constraint_Error with "attempt to delete element not in set";
@@ -295,7 +315,7 @@ is
pragma Assert (Vet (Container, Position), "bad cursor in Delete");
- HT_Ops.Delete_Node_Sans_Free (Container, Position.Node);
+ HT_Ops.Delete_Node_Sans_Free (Container.Content, Position.Node);
Free (Container, Position.Node);
Position := No_Element;
@@ -311,8 +331,8 @@ is
Src_Node : Count_Type;
Tgt_Node : Count_Type;
- TN : Nodes_Type renames Target.Nodes;
- SN : Nodes_Type renames Source.Nodes;
+ TN : Nodes_Type renames Target.Content.Nodes;
+ SN : Nodes_Type renames Source.Content.Nodes;
begin
if Target'Address = Source'Address then
@@ -320,44 +340,45 @@ is
return;
end if;
- Src_Length := Source.Length;
+ Src_Length := Source.Content.Length;
if Src_Length = 0 then
return;
end if;
- if Src_Length >= Target.Length then
- Tgt_Node := HT_Ops.First (Target);
+ if Src_Length >= Target.Content.Length then
+ Tgt_Node := HT_Ops.First (Target.Content);
while Tgt_Node /= 0 loop
- if Element_Keys.Find (Source, TN (Tgt_Node).Element) /= 0 then
+ if Element_Keys.Find (Source.Content, TN (Tgt_Node).Element) /= 0
+ then
declare
X : constant Count_Type := Tgt_Node;
begin
- Tgt_Node := HT_Ops.Next (Target, Tgt_Node);
- HT_Ops.Delete_Node_Sans_Free (Target, X);
+ Tgt_Node := HT_Ops.Next (Target.Content, Tgt_Node);
+ HT_Ops.Delete_Node_Sans_Free (Target.Content, X);
Free (Target, X);
end;
else
- Tgt_Node := HT_Ops.Next (Target, Tgt_Node);
+ Tgt_Node := HT_Ops.Next (Target.Content, Tgt_Node);
end if;
end loop;
return;
else
- Src_Node := HT_Ops.First (Source);
+ Src_Node := HT_Ops.First (Source.Content);
Src_Last := 0;
end if;
while Src_Node /= Src_Last loop
- Tgt_Node := Element_Keys.Find (Target, SN (Src_Node).Element);
+ Tgt_Node := Element_Keys.Find (Target.Content, SN (Src_Node).Element);
if Tgt_Node /= 0 then
- HT_Ops.Delete_Node_Sans_Free (Target, Tgt_Node);
+ HT_Ops.Delete_Node_Sans_Free (Target.Content, Tgt_Node);
Free (Target, Tgt_Node);
end if;
- Src_Node := HT_Ops.Next (Source, Src_Node);
+ Src_Node := HT_Ops.Next (Source.Content, Src_Node);
end loop;
end Difference;
@@ -373,7 +394,7 @@ is
procedure Process (L_Node : Count_Type) is
B : Boolean;
- E : Element_Type renames Left.Nodes (L_Node).Element;
+ E : Element_Type renames Left.Content.Nodes (L_Node).Element;
X : Count_Type;
begin
@@ -386,7 +407,7 @@ is
-- Start of processing for Difference
begin
- Iterate (Left);
+ Iterate (Left.Content);
end Difference;
function Difference (Left : Set; Right : Set) return Set is
@@ -403,7 +424,7 @@ is
end if;
if Length (Right) = 0 then
- return Left.Copy;
+ return Copy (Left);
end if;
C := Length (Left);
@@ -430,7 +451,7 @@ is
pragma Assert
(Vet (Container, Position), "bad cursor in function Element");
- return Container.Nodes (Position.Node).Element;
+ return Container.Content.Nodes (Position.Node).Element;
end Element;
---------------------
@@ -479,7 +500,7 @@ is
-- Start of processing for Equivalent_Sets
begin
- return Is_Equivalent (Left, Right);
+ return Is_Equivalent (Left.Content, Right.Content);
end Equivalent_Sets;
---------------------
@@ -501,7 +522,7 @@ is
procedure Exclude (Container : in out Set; Item : Element_Type) is
X : Count_Type;
begin
- Element_Keys.Delete_Key_Sans_Free (Container, Item, X);
+ Element_Keys.Delete_Key_Sans_Free (Container.Content, Item, X);
Free (Container, X);
end Exclude;
@@ -513,7 +534,8 @@ is
(Container : Set;
Item : Element_Type) return Cursor
is
- Node : constant Count_Type := Element_Keys.Find (Container, Item);
+ Node : constant Count_Type :=
+ Element_Keys.Find (Container.Content, Item);
begin
if Node = 0 then
@@ -528,7 +550,7 @@ is
-----------
function First (Container : Set) return Cursor is
- Node : constant Count_Type := HT_Ops.First (Container);
+ Node : constant Count_Type := HT_Ops.First (Container.Content);
begin
if Node = 0 then
@@ -632,7 +654,7 @@ is
--------------
function Elements (Container : Set) return E.Sequence is
- Position : Count_Type := HT_Ops.First (Container);
+ Position : Count_Type := HT_Ops.First (Container.Content);
R : E.Sequence;
begin
@@ -640,8 +662,8 @@ is
-- for their postconditions.
while Position /= 0 loop
- R := E.Add (R, Container.Nodes (Position).Element);
- Position := HT_Ops.Next (Container, Position);
+ R := E.Add (R, Container.Content.Nodes (Position).Element);
+ Position := HT_Ops.Next (Container.Content, Position);
end loop;
return R;
@@ -710,7 +732,7 @@ is
-----------
function Model (Container : Set) return M.Set is
- Position : Count_Type := HT_Ops.First (Container);
+ Position : Count_Type := HT_Ops.First (Container.Content);
R : M.Set;
begin
@@ -721,9 +743,9 @@ is
R :=
M.Add
(Container => R,
- Item => Container.Nodes (Position).Element);
+ Item => Container.Content.Nodes (Position).Element);
- Position := HT_Ops.Next (Container, Position);
+ Position := HT_Ops.Next (Container.Content, Position);
end loop;
return R;
@@ -735,7 +757,7 @@ is
function Positions (Container : Set) return P.Map is
I : Count_Type := 1;
- Position : Count_Type := HT_Ops.First (Container);
+ Position : Count_Type := HT_Ops.First (Container.Content);
R : P.Map;
begin
@@ -745,7 +767,7 @@ is
while Position /= 0 loop
R := P.Add (R, (Node => Position), I);
pragma Assert (P.Length (R) = I);
- Position := HT_Ops.Next (Container, Position);
+ Position := HT_Ops.Next (Container.Content, Position);
I := I + 1;
end loop;
@@ -762,8 +784,8 @@ is
begin
if X /= 0 then
pragma Assert (X <= HT.Capacity);
- HT.Nodes (X).Has_Element := False;
- HT_Ops.Free (HT, X);
+ HT.Content.Nodes (X).Has_Element := False;
+ HT_Ops.Free (HT.Content, X);
end if;
end Free;
@@ -774,8 +796,8 @@ is
procedure Generic_Allocate (HT : in out Set; Node : out Count_Type) is
procedure Allocate is new HT_Ops.Generic_Allocate (Set_Element);
begin
- Allocate (HT, Node);
- HT.Nodes (Node).Has_Element := True;
+ Allocate (HT.Content, Node);
+ HT.Content.Nodes (Node).Has_Element := True;
end Generic_Allocate;
package body Generic_Keys with SPARK_Mode => Off is
@@ -821,7 +843,7 @@ is
X : Count_Type;
begin
- Key_Keys.Delete_Key_Sans_Free (Container, Key, X);
+ Key_Keys.Delete_Key_Sans_Free (Container.Content, Key, X);
if X = 0 then
raise Constraint_Error with "attempt to delete key not in set";
@@ -845,7 +867,7 @@ is
raise Constraint_Error with "key not in map";
end if;
- return Container.Nodes (Node).Element;
+ return Container.Content.Nodes (Node).Element;
end Element;
-------------------------
@@ -867,7 +889,7 @@ is
procedure Exclude (Container : in out Set; Key : Key_Type) is
X : Count_Type;
begin
- Key_Keys.Delete_Key_Sans_Free (Container, Key, X);
+ Key_Keys.Delete_Key_Sans_Free (Container.Content, Key, X);
Free (Container, X);
end Exclude;
@@ -879,7 +901,7 @@ is
(Container : Set;
Key : Key_Type) return Cursor
is
- Node : constant Count_Type := Key_Keys.Find (Container, Key);
+ Node : constant Count_Type := Key_Keys.Find (Container.Content, Key);
begin
return (if Node = 0 then No_Element else (Node => Node));
end Find;
@@ -927,7 +949,7 @@ is
(Vet (Container, Position), "bad cursor in function Key");
declare
- N : Node_Type renames Container.Nodes (Position.Node);
+ N : Node_Type renames Container.Content.Nodes (Position.Node);
begin
return Key (N.Element);
end;
@@ -942,14 +964,14 @@ is
Key : Key_Type;
New_Item : Element_Type)
is
- Node : constant Count_Type := Key_Keys.Find (Container, Key);
+ Node : constant Count_Type := Key_Keys.Find (Container.Content, Key);
begin
if Node = 0 then
raise Constraint_Error with "attempt to replace key not in set";
end if;
- Replace_Element (Container, Node, New_Item);
+ Replace_Element (Container.Content, Node, New_Item);
end Replace;
end Generic_Keys;
@@ -961,7 +983,7 @@ is
function Has_Element (Container : Set; Position : Cursor) return Boolean is
begin
if Position.Node = 0
- or else not Container.Nodes (Position.Node).Has_Element
+ or else not Container.Content.Nodes (Position.Node).Has_Element
then
return False;
end if;
@@ -990,7 +1012,7 @@ is
Insert (Container, New_Item, Position, Inserted);
if not Inserted then
- Container.Nodes (Position.Node).Element := New_Item;
+ Container.Content.Nodes (Position.Node).Element := New_Item;
end if;
end Include;
@@ -1062,7 +1084,7 @@ is
-- Start of processing for Insert
begin
- Local_Insert (Container, New_Item, Node, Inserted);
+ Local_Insert (Container.Content, New_Item, Node, Inserted);
end Insert;
------------------
@@ -1071,29 +1093,29 @@ is
procedure Intersection (Target : in out Set; Source : Set) is
Tgt_Node : Count_Type;
- TN : Nodes_Type renames Target.Nodes;
+ TN : Nodes_Type renames Target.Content.Nodes;
begin
if Target'Address = Source'Address then
return;
end if;
- if Source.Length = 0 then
+ if Source.Content.Length = 0 then
Clear (Target);
return;
end if;
- Tgt_Node := HT_Ops.First (Target);
+ Tgt_Node := HT_Ops.First (Target.Content);
while Tgt_Node /= 0 loop
if Find (Source, TN (Tgt_Node).Element).Node /= 0 then
- Tgt_Node := HT_Ops.Next (Target, Tgt_Node);
+ Tgt_Node := HT_Ops.Next (Target.Content, Tgt_Node);
else
declare
X : constant Count_Type := Tgt_Node;
begin
- Tgt_Node := HT_Ops.Next (Target, Tgt_Node);
- HT_Ops.Delete_Node_Sans_Free (Target, X);
+ Tgt_Node := HT_Ops.Next (Target.Content, Tgt_Node);
+ HT_Ops.Delete_Node_Sans_Free (Target.Content, X);
Free (Target, X);
end;
end if;
@@ -1111,7 +1133,7 @@ is
-------------
procedure Process (L_Node : Count_Type) is
- E : Element_Type renames Left.Nodes (L_Node).Element;
+ E : Element_Type renames Left.Content.Nodes (L_Node).Element;
X : Count_Type;
B : Boolean;
@@ -1125,7 +1147,7 @@ is
-- Start of processing for Intersection
begin
- Iterate (Left);
+ Iterate (Left.Content);
end Intersection;
function Intersection (Left : Set; Right : Set) return Set is
@@ -1134,7 +1156,7 @@ is
begin
if Left'Address = Right'Address then
- return Left.Copy;
+ return Copy (Left);
end if;
C := Count_Type'Min (Length (Left), Length (Right)); -- ???
@@ -1162,7 +1184,7 @@ is
function Is_In (HT : Set; Key : Node_Type) return Boolean is
begin
- return Element_Keys.Find (HT, Key.Element) /= 0;
+ return Element_Keys.Find (HT.Content, Key.Element) /= 0;
end Is_In;
---------------
@@ -1171,7 +1193,7 @@ is
function Is_Subset (Subset : Set; Of_Set : Set) return Boolean is
Subset_Node : Count_Type;
- Subset_Nodes : Nodes_Type renames Subset.Nodes;
+ Subset_Nodes : Nodes_Type renames Subset.Content.Nodes;
begin
if Subset'Address = Of_Set'Address then
@@ -1194,7 +1216,7 @@ is
end if;
end;
- Subset_Node := HT_Ops.Next (Subset, Subset_Node);
+ Subset_Node := HT_Ops.Next (Subset.Content, Subset_Node);
end loop;
return True;
@@ -1206,7 +1228,7 @@ is
function Length (Container : Set) return Count_Type is
begin
- return Container.Length;
+ return Container.Content.Length;
end Length;
----------
@@ -1216,7 +1238,7 @@ is
-- Comments???
procedure Move (Target : in out Set; Source : in out Set) is
- NN : HT_Types.Nodes_Type renames Source.Nodes;
+ NN : HT_Types.Nodes_Type renames Source.Content.Nodes;
X, Y : Count_Type;
begin
@@ -1231,17 +1253,17 @@ is
Clear (Target);
- if Source.Length = 0 then
+ if Source.Content.Length = 0 then
return;
end if;
- X := HT_Ops.First (Source);
+ X := HT_Ops.First (Source.Content);
while X /= 0 loop
Insert (Target, NN (X).Element); -- optimize???
- Y := HT_Ops.Next (Source, X);
+ Y := HT_Ops.Next (Source.Content, X);
- HT_Ops.Delete_Node_Sans_Free (Source, X);
+ HT_Ops.Delete_Node_Sans_Free (Source.Content, X);
Free (Source, X);
X := Y;
@@ -1269,7 +1291,7 @@ is
pragma Assert (Vet (Container, Position), "bad cursor in Next");
- return (Node => HT_Ops.Next (Container, Position.Node));
+ return (Node => HT_Ops.Next (Container.Content, Position.Node));
end Next;
procedure Next (Container : Set; Position : in out Cursor) is
@@ -1283,7 +1305,7 @@ is
function Overlap (Left, Right : Set) return Boolean is
Left_Node : Count_Type;
- Left_Nodes : Nodes_Type renames Left.Nodes;
+ Left_Nodes : Nodes_Type renames Left.Content.Nodes;
begin
if Length (Right) = 0 or Length (Left) = 0 then
@@ -1305,7 +1327,7 @@ is
end if;
end;
- Left_Node := HT_Ops.Next (Left, Left_Node);
+ Left_Node := HT_Ops.Next (Left.Content, Left_Node);
end loop;
return False;
@@ -1316,14 +1338,15 @@ is
-------------
procedure Replace (Container : in out Set; New_Item : Element_Type) is
- Node : constant Count_Type := Element_Keys.Find (Container, New_Item);
+ Node : constant Count_Type :=
+ Element_Keys.Find (Container.Content, New_Item);
begin
if Node = 0 then
raise Constraint_Error with "attempt to replace element not in set";
end if;
- Container.Nodes (Node).Element := New_Item;
+ Container.Content.Nodes (Node).Element := New_Item;
end Replace;
---------------------
@@ -1343,7 +1366,7 @@ is
pragma Assert
(Vet (Container, Position), "bad cursor in Replace_Element");
- Replace_Element (Container, Position.Node, New_Item);
+ Replace_Element (Container.Content, Position.Node, New_Item);
end Replace_Element;
----------------------
@@ -1394,7 +1417,7 @@ is
procedure Process (Source_Node : Count_Type) is
B : Boolean;
- N : Node_Type renames Source.Nodes (Source_Node);
+ N : Node_Type renames Source.Content.Nodes (Source_Node);
X : Count_Type;
begin
@@ -1419,7 +1442,7 @@ is
return;
end if;
- Iterate (Source);
+ Iterate (Source.Content);
end Symmetric_Difference;
function Symmetric_Difference (Left : Set; Right : Set) return Set is
@@ -1432,11 +1455,11 @@ is
end if;
if Length (Right) = 0 then
- return Left.Copy;
+ return Copy (Left);
end if;
if Length (Left) = 0 then
- return Right.Copy;
+ return Copy (Right);
end if;
C := Length (Left) + Length (Right);
@@ -1478,7 +1501,7 @@ is
-------------
procedure Process (Src_Node : Count_Type) is
- N : Node_Type renames Source.Nodes (Src_Node);
+ N : Node_Type renames Source.Content.Nodes (Src_Node);
E : Element_Type renames N.Element;
X : Count_Type;
@@ -1495,7 +1518,7 @@ is
return;
end if;
- Iterate (Source);
+ Iterate (Source.Content);
end Union;
function Union (Left : Set; Right : Set) return Set is
@@ -1504,15 +1527,15 @@ is
begin
if Left'Address = Right'Address then
- return Left.Copy;
+ return Copy (Left);
end if;
if Length (Right) = 0 then
- return Left.Copy;
+ return Copy (Left);
end if;
if Length (Left) = 0 then
- return Right.Copy;
+ return Copy (Right);
end if;
C := Length (Left) + Length (Right);
@@ -1535,11 +1558,11 @@ is
declare
S : Set renames Container;
- N : Nodes_Type renames S.Nodes;
+ N : Nodes_Type renames S.Content.Nodes;
X : Count_Type;
begin
- if S.Length = 0 then
+ if S.Content.Length = 0 then
return False;
end if;
@@ -1551,9 +1574,10 @@ is
return False;
end if;
- X := S.Buckets (Element_Keys.Index (S, N (Position.Node).Element));
+ X := S.Content.Buckets
+ (Element_Keys.Index (S.Content, N (Position.Node).Element));
- for J in 1 .. S.Length loop
+ for J in 1 .. S.Content.Length loop
if X = Position.Node then
return True;
end if;
diff --git a/gcc/ada/libgnat/a-cfhase.ads b/gcc/ada/libgnat/a-cfhase.ads
index 37022ca..9bcd8ce 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2021, 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 --
@@ -62,6 +62,11 @@ generic
package Ada.Containers.Formal_Hashed_Sets with
SPARK_Mode
is
+ -- Contracts in this unit are meant for analysis only, not for run-time
+ -- checking.
+
+ pragma Assertion_Policy (Pre => Ignore);
+ pragma Assertion_Policy (Post => Ignore);
pragma Annotate (CodePeer, Skip_Analysis);
type Set (Capacity : Count_Type; Modulus : Hash_Type) is private with
@@ -510,6 +515,16 @@ is
Position => Position)
and Positions (Container) = Positions (Container)'Old;
+ function Constant_Reference
+ (Container : aliased Set;
+ Position : Cursor) return not null access constant Element_Type
+ with
+ Global => null,
+ Pre => Has_Element (Container, Position),
+ Post =>
+ Constant_Reference'Result.all =
+ E.Get (Elements (Container), P.Get (Positions (Container), Position));
+
procedure Move (Target : in out Set; Source : in out Set) with
Global => null,
Pre => Target.Capacity >= Length (Source),
@@ -1457,7 +1472,7 @@ private
type Node_Type is
record
- Element : Element_Type;
+ Element : aliased Element_Type;
Next : Count_Type;
Has_Element : Boolean := False;
end record;
@@ -1465,8 +1480,9 @@ private
package HT_Types is new
Ada.Containers.Hash_Tables.Generic_Bounded_Hash_Table_Types (Node_Type);
- type Set (Capacity : Count_Type; Modulus : Hash_Type) is
- new HT_Types.Hash_Table_Type (Capacity, Modulus) with null record;
+ type Set (Capacity : Count_Type; Modulus : Hash_Type) is record
+ Content : HT_Types.Hash_Table_Type (Capacity, Modulus);
+ end record;
use HT_Types;
diff --git a/gcc/ada/libgnat/a-cfinve.adb b/gcc/ada/libgnat/a-cfinve.adb
index e424df0..d0c7e82 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2010-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -184,6 +184,28 @@ is
Free (Container.Elements_Ptr);
end Clear;
+ ------------------------
+ -- Constant_Reference --
+ ------------------------
+
+ function Constant_Reference
+ (Container : aliased Vector;
+ Index : Index_Type) return not null access constant Element_Type
+ is
+ begin
+ if Index > Container.Last then
+ raise Constraint_Error with "Index is out of range";
+ end if;
+
+ declare
+ II : constant Int'Base := Int (Index) - Int (No_Index);
+ I : constant Capacity_Range := Capacity_Range (II);
+
+ begin
+ return Constant_Reference (Elemsc (Container) (I));
+ end;
+ end Constant_Reference;
+
--------------
-- Contains --
--------------
@@ -1180,6 +1202,32 @@ is
Insert (Container, Index_Type'First, New_Item, Count);
end Prepend;
+ ---------------
+ -- Reference --
+ ---------------
+
+ function Reference
+ (Container : not null access Vector;
+ Index : Index_Type) return not null access Element_Type
+ is
+ begin
+ if Index > Container.Last then
+ raise Constraint_Error with "Index is out of range";
+ end if;
+
+ declare
+ II : constant Int'Base := Int (Index) - Int (No_Index);
+ I : constant Capacity_Range := Capacity_Range (II);
+
+ begin
+ if Container.Elements_Ptr = null then
+ return Reference (Container.Elements (I)'Access);
+ else
+ return Reference (Container.Elements_Ptr (I)'Access);
+ end if;
+ end;
+ end Reference;
+
---------------------
-- Replace_Element --
---------------------
diff --git a/gcc/ada/libgnat/a-cfinve.ads b/gcc/ada/libgnat/a-cfinve.ads
index 3e2e350..9b95437 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2014-2021, 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 --
@@ -55,6 +55,11 @@ generic
package Ada.Containers.Formal_Indefinite_Vectors with
SPARK_Mode => On
is
+ -- Contracts in this unit are meant for analysis only, not for run-time
+ -- checking.
+
+ pragma Assertion_Policy (Pre => Ignore);
+ pragma Assertion_Policy (Post => Ignore);
pragma Annotate (CodePeer, Skip_Analysis);
subtype Extended_Index is Index_Type'Base
@@ -306,6 +311,48 @@ is
Right => Model (Container),
Position => Index);
+ function At_End (E : access constant Vector) return access constant Vector
+ is (E)
+ with Ghost,
+ Annotate => (GNATprove, At_End_Borrow);
+
+ function At_End
+ (E : access constant Element_Type) return access constant Element_Type
+ is (E)
+ with Ghost,
+ Annotate => (GNATprove, At_End_Borrow);
+
+ function Constant_Reference
+ (Container : aliased Vector;
+ Index : Index_Type) return not null access constant Element_Type
+ with
+ Global => null,
+ Pre => Index in First_Index (Container) .. Last_Index (Container),
+ Post =>
+ Constant_Reference'Result.all = Element (Model (Container), Index);
+
+ function Reference
+ (Container : not null access Vector;
+ Index : Index_Type) return not null access Element_Type
+ with
+ Global => null,
+ Pre =>
+ Index in First_Index (Container.all) .. Last_Index (Container.all),
+ Post =>
+ Length (Container.all) = Length (At_End (Container).all)
+
+ -- Container will have Result.all at index Index
+
+ and At_End (Reference'Result).all =
+ Element (Model (At_End (Container).all), Index)
+
+ -- All other elements are preserved
+
+ and M.Equal_Except
+ (Left => Model (Container.all),
+ Right => Model (At_End (Container).all),
+ Position => Index);
+
procedure Insert
(Container : in out Vector;
Before : Extended_Index;
@@ -904,7 +951,7 @@ private
use Holders;
subtype Array_Index is Capacity_Range range 1 .. Capacity_Range'Last;
- type Elements_Array is array (Array_Index range <>) of Holder;
+ type Elements_Array is array (Array_Index range <>) of aliased Holder;
function "=" (L, R : Elements_Array) return Boolean is abstract;
type Elements_Array_Ptr is access all Elements_Array;
diff --git a/gcc/ada/libgnat/a-cforma.adb b/gcc/ada/libgnat/a-cforma.adb
index 004b31e..45f9be7 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2010-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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,19 +133,20 @@ is
return True;
end if;
- Lst := Next (Left, Last (Left).Node);
+ Lst := Next (Left.Content, Last (Left).Node);
Node := First (Left).Node;
while Node /= Lst loop
- ENode := Find (Right, Left.Nodes (Node).Key).Node;
+ ENode := Find (Right, Left.Content.Nodes (Node).Key).Node;
if ENode = 0 or else
- Left.Nodes (Node).Element /= Right.Nodes (ENode).Element
+ Left.Content.Nodes (Node).Element /=
+ Right.Content.Nodes (ENode).Element
then
return False;
end if;
- Node := Next (Left, Node);
+ Node := Next (Left.Content, Node);
end loop;
return True;
@@ -166,7 +167,7 @@ is
--------------------
procedure Append_Element (Source_Node : Count_Type) is
- SN : Node_Type renames Source.Nodes (Source_Node);
+ SN : Node_Type renames Source.Content.Nodes (Source_Node);
procedure Set_Element (Node : in out Node_Type);
pragma Inline (Set_Element);
@@ -193,7 +194,7 @@ is
function New_Node return Count_Type is
Result : Count_Type;
begin
- Allocate (Target, Result);
+ Allocate (Target.Content, Result);
return Result;
end New_Node;
@@ -213,7 +214,7 @@ is
begin
Unconditional_Insert_Avec_Hint
- (Tree => Target,
+ (Tree => Target.Content,
Hint => 0,
Key => SN.Key,
Node => Target_Node);
@@ -230,8 +231,8 @@ is
raise Storage_Error with "not enough capacity"; -- SE or CE? ???
end if;
- Tree_Operations.Clear_Tree (Target);
- Append_Elements (Source);
+ Tree_Operations.Clear_Tree (Target.Content);
+ Append_Elements (Source.Content);
end Assign;
-------------
@@ -239,7 +240,7 @@ is
-------------
function Ceiling (Container : Map; Key : Key_Type) return Cursor is
- Node : constant Count_Type := Key_Ops.Ceiling (Container, Key);
+ Node : constant Count_Type := Key_Ops.Ceiling (Container.Content, Key);
begin
if Node = 0 then
@@ -255,7 +256,7 @@ is
procedure Clear (Container : in out Map) is
begin
- Tree_Operations.Clear_Tree (Container);
+ Tree_Operations.Clear_Tree (Container.Content);
end Clear;
-----------
@@ -267,6 +268,40 @@ is
return Node.Color;
end Color;
+ ------------------------
+ -- Constant_Reference --
+ ------------------------
+
+ function Constant_Reference
+ (Container : aliased Map;
+ Position : Cursor) return not null access constant Element_Type
+ is
+ begin
+ if not Has_Element (Container, Position) then
+ raise Constraint_Error with "Position cursor has no element";
+ end if;
+
+ pragma Assert (Vet (Container.Content, Position.Node),
+ "bad cursor in function Constant_Reference");
+
+ return Container.Content.Nodes (Position.Node).Element'Access;
+ end Constant_Reference;
+
+ function Constant_Reference
+ (Container : aliased Map;
+ Key : Key_Type) return not null access constant Element_Type
+ is
+ Node : constant Node_Access := Find (Container, Key).Node;
+
+ begin
+ if Node = 0 then
+ raise Constraint_Error with
+ "no element available because key not in map";
+ end if;
+
+ return Container.Content.Nodes (Node).Element'Access;
+ end Constant_Reference;
+
--------------
-- Contains --
--------------
@@ -291,33 +326,33 @@ is
return Target : Map (Count_Type'Max (Source.Capacity, Capacity)) do
if Length (Source) > 0 then
- Target.Length := Source.Length;
- Target.Root := Source.Root;
- Target.First := Source.First;
- Target.Last := Source.Last;
- Target.Free := Source.Free;
+ Target.Content.Length := Source.Content.Length;
+ Target.Content.Root := Source.Content.Root;
+ Target.Content.First := Source.Content.First;
+ Target.Content.Last := Source.Content.Last;
+ Target.Content.Free := Source.Content.Free;
while Node <= Source.Capacity loop
- Target.Nodes (Node).Element :=
- Source.Nodes (Node).Element;
- Target.Nodes (Node).Key :=
- Source.Nodes (Node).Key;
- Target.Nodes (Node).Parent :=
- Source.Nodes (Node).Parent;
- Target.Nodes (Node).Left :=
- Source.Nodes (Node).Left;
- Target.Nodes (Node).Right :=
- Source.Nodes (Node).Right;
- Target.Nodes (Node).Color :=
- Source.Nodes (Node).Color;
- Target.Nodes (Node).Has_Element :=
- Source.Nodes (Node).Has_Element;
+ Target.Content.Nodes (Node).Element :=
+ Source.Content.Nodes (Node).Element;
+ Target.Content.Nodes (Node).Key :=
+ Source.Content.Nodes (Node).Key;
+ Target.Content.Nodes (Node).Parent :=
+ Source.Content.Nodes (Node).Parent;
+ Target.Content.Nodes (Node).Left :=
+ Source.Content.Nodes (Node).Left;
+ Target.Content.Nodes (Node).Right :=
+ Source.Content.Nodes (Node).Right;
+ Target.Content.Nodes (Node).Color :=
+ Source.Content.Nodes (Node).Color;
+ Target.Content.Nodes (Node).Has_Element :=
+ Source.Content.Nodes (Node).Has_Element;
Node := Node + 1;
end loop;
while Node <= Target.Capacity loop
N := Node;
- Formal_Ordered_Maps.Free (Tree => Target, X => N);
+ Free (Tree => Target, X => N);
Node := Node + 1;
end loop;
end if;
@@ -335,25 +370,25 @@ is
"Position cursor of Delete has no element";
end if;
- pragma Assert (Vet (Container, Position.Node),
+ pragma Assert (Vet (Container.Content, Position.Node),
"Position cursor of Delete is bad");
- Tree_Operations.Delete_Node_Sans_Free (Container,
+ Tree_Operations.Delete_Node_Sans_Free (Container.Content,
Position.Node);
- Formal_Ordered_Maps.Free (Container, Position.Node);
+ Free (Container, Position.Node);
Position := No_Element;
end Delete;
procedure Delete (Container : in out Map; Key : Key_Type) is
- X : constant Node_Access := Key_Ops.Find (Container, Key);
+ X : constant Node_Access := Key_Ops.Find (Container.Content, Key);
begin
if X = 0 then
raise Constraint_Error with "key not in map";
end if;
- Tree_Operations.Delete_Node_Sans_Free (Container, X);
- Formal_Ordered_Maps.Free (Container, X);
+ Tree_Operations.Delete_Node_Sans_Free (Container.Content, X);
+ Free (Container, X);
end Delete;
------------------
@@ -364,8 +399,8 @@ is
X : constant Node_Access := First (Container).Node;
begin
if X /= 0 then
- Tree_Operations.Delete_Node_Sans_Free (Container, X);
- Formal_Ordered_Maps.Free (Container, X);
+ Tree_Operations.Delete_Node_Sans_Free (Container.Content, X);
+ Free (Container, X);
end if;
end Delete_First;
@@ -377,8 +412,8 @@ is
X : constant Node_Access := Last (Container).Node;
begin
if X /= 0 then
- Tree_Operations.Delete_Node_Sans_Free (Container, X);
- Formal_Ordered_Maps.Free (Container, X);
+ Tree_Operations.Delete_Node_Sans_Free (Container.Content, X);
+ Free (Container, X);
end if;
end Delete_Last;
@@ -393,10 +428,10 @@ is
"Position cursor of function Element has no element";
end if;
- pragma Assert (Vet (Container, Position.Node),
+ pragma Assert (Vet (Container.Content, Position.Node),
"Position cursor of function Element is bad");
- return Container.Nodes (Position.Node).Element;
+ return Container.Content.Nodes (Position.Node).Element;
end Element;
@@ -408,7 +443,7 @@ is
raise Constraint_Error with "key not in map";
end if;
- return Container.Nodes (Node).Element;
+ return Container.Content.Nodes (Node).Element;
end Element;
---------------------
@@ -431,11 +466,11 @@ is
-------------
procedure Exclude (Container : in out Map; Key : Key_Type) is
- X : constant Node_Access := Key_Ops.Find (Container, Key);
+ X : constant Node_Access := Key_Ops.Find (Container.Content, Key);
begin
if X /= 0 then
- Tree_Operations.Delete_Node_Sans_Free (Container, X);
- Formal_Ordered_Maps.Free (Container, X);
+ Tree_Operations.Delete_Node_Sans_Free (Container.Content, X);
+ Free (Container, X);
end if;
end Exclude;
@@ -444,7 +479,7 @@ is
----------
function Find (Container : Map; Key : Key_Type) return Cursor is
- Node : constant Count_Type := Key_Ops.Find (Container, Key);
+ Node : constant Count_Type := Key_Ops.Find (Container.Content, Key);
begin
if Node = 0 then
@@ -464,7 +499,7 @@ is
return No_Element;
end if;
- return (Node => Container.First);
+ return (Node => Container.Content.First);
end First;
-------------------
@@ -477,7 +512,7 @@ is
raise Constraint_Error with "map is empty";
end if;
- return Container.Nodes (First (Container).Node).Element;
+ return Container.Content.Nodes (First (Container).Node).Element;
end First_Element;
---------------
@@ -490,7 +525,7 @@ is
raise Constraint_Error with "map is empty";
end if;
- return Container.Nodes (First (Container).Node).Key;
+ return Container.Content.Nodes (First (Container).Node).Key;
end First_Key;
-----------
@@ -498,7 +533,7 @@ is
-----------
function Floor (Container : Map; Key : Key_Type) return Cursor is
- Node : constant Count_Type := Key_Ops.Floor (Container, Key);
+ Node : constant Count_Type := Key_Ops.Floor (Container.Content, Key);
begin
if Node = 0 then
@@ -602,7 +637,7 @@ is
----------
function Keys (Container : Map) return K.Sequence is
- Position : Count_Type := Container.First;
+ Position : Count_Type := Container.Content.First;
R : K.Sequence;
begin
@@ -610,8 +645,8 @@ is
-- for their postconditions.
while Position /= 0 loop
- R := K.Add (R, Container.Nodes (Position).Key);
- Position := Tree_Operations.Next (Container, Position);
+ R := K.Add (R, Container.Content.Nodes (Position).Key);
+ Position := Tree_Operations.Next (Container.Content, Position);
end loop;
return R;
@@ -628,7 +663,7 @@ is
-----------
function Model (Container : Map) return M.Map is
- Position : Count_Type := Container.First;
+ Position : Count_Type := Container.Content.First;
R : M.Map;
begin
@@ -639,10 +674,10 @@ is
R :=
M.Add
(Container => R,
- New_Key => Container.Nodes (Position).Key,
- New_Item => Container.Nodes (Position).Element);
+ New_Key => Container.Content.Nodes (Position).Key,
+ New_Item => Container.Content.Nodes (Position).Element);
- Position := Tree_Operations.Next (Container, Position);
+ Position := Tree_Operations.Next (Container.Content, Position);
end loop;
return R;
@@ -701,7 +736,7 @@ is
function Positions (Container : Map) return P.Map is
I : Count_Type := 1;
- Position : Count_Type := Container.First;
+ Position : Count_Type := Container.Content.First;
R : P.Map;
begin
@@ -711,7 +746,7 @@ is
while Position /= 0 loop
R := P.Add (R, (Node => Position), I);
pragma Assert (P.Length (R) = I);
- Position := Tree_Operations.Next (Container, Position);
+ Position := Tree_Operations.Next (Container.Content, Position);
I := I + 1;
end loop;
@@ -729,8 +764,8 @@ is
X : Count_Type)
is
begin
- Tree.Nodes (X).Has_Element := False;
- Tree_Operations.Free (Tree, X);
+ Tree.Content.Nodes (X).Has_Element := False;
+ Tree_Operations.Free (Tree.Content, X);
end Free;
----------------------
@@ -758,7 +793,7 @@ is
return False;
end if;
- return Container.Nodes (Position.Node).Has_Element;
+ return Container.Content.Nodes (Position.Node).Has_Element;
end Has_Element;
-------------
@@ -778,7 +813,7 @@ is
if not Inserted then
declare
- N : Node_Type renames Container.Nodes (Position.Node);
+ N : Node_Type renames Container.Content.Nodes (Position.Node);
begin
N.Key := Key;
N.Element := New_Item;
@@ -819,7 +854,7 @@ is
X : Node_Access;
begin
- Allocate_Node (Container, X);
+ Allocate_Node (Container.Content, X);
return X;
end New_Node;
@@ -827,7 +862,7 @@ is
begin
Insert_Sans_Hint
- (Container,
+ (Container.Content,
Key,
Position.Node,
Inserted);
@@ -895,10 +930,10 @@ is
"Position cursor of function Key has no element";
end if;
- pragma Assert (Vet (Container, Position.Node),
+ pragma Assert (Vet (Container.Content, Position.Node),
"Position cursor of function Key is bad");
- return Container.Nodes (Position.Node).Key;
+ return Container.Content.Nodes (Position.Node).Key;
end Key;
----------
@@ -911,7 +946,7 @@ is
return No_Element;
end if;
- return (Node => Container.Last);
+ return (Node => Container.Content.Last);
end Last;
------------------
@@ -924,7 +959,7 @@ is
raise Constraint_Error with "map is empty";
end if;
- return Container.Nodes (Last (Container).Node).Element;
+ return Container.Content.Nodes (Last (Container).Node).Element;
end Last_Element;
--------------
@@ -937,7 +972,7 @@ is
raise Constraint_Error with "map is empty";
end if;
- return Container.Nodes (Last (Container).Node).Key;
+ return Container.Content.Nodes (Last (Container).Node).Key;
end Last_Key;
--------------
@@ -955,7 +990,7 @@ is
function Length (Container : Map) return Count_Type is
begin
- return Container.Length;
+ return Container.Content.Length;
end Length;
----------
@@ -963,7 +998,7 @@ is
----------
procedure Move (Target : in out Map; Source : in out Map) is
- NN : Tree_Types.Nodes_Type renames Source.Nodes;
+ NN : Tree_Types.Nodes_Type renames Source.Content.Nodes;
X : Node_Access;
begin
@@ -989,7 +1024,7 @@ is
Insert (Target, NN (X).Key, NN (X).Element); -- optimize???
- Tree_Operations.Delete_Node_Sans_Free (Source, X);
+ Tree_Operations.Delete_Node_Sans_Free (Source.Content, X);
Formal_Ordered_Maps.Free (Source, X);
end loop;
end Move;
@@ -1013,10 +1048,10 @@ is
raise Constraint_Error;
end if;
- pragma Assert (Vet (Container, Position.Node),
+ pragma Assert (Vet (Container.Content, Position.Node),
"bad cursor in Next");
- return (Node => Tree_Operations.Next (Container, Position.Node));
+ return (Node => Tree_Operations.Next (Container.Content, Position.Node));
end Next;
------------
@@ -1047,12 +1082,12 @@ is
raise Constraint_Error;
end if;
- pragma Assert (Vet (Container, Position.Node),
+ pragma Assert (Vet (Container.Content, Position.Node),
"bad cursor in Previous");
declare
Node : constant Count_Type :=
- Tree_Operations.Previous (Container, Position.Node);
+ Tree_Operations.Previous (Container.Content, Position.Node);
begin
if Node = 0 then
@@ -1063,6 +1098,41 @@ is
end;
end Previous;
+ --------------
+ -- Reference --
+ --------------
+
+ function Reference
+ (Container : not null access Map;
+ Position : Cursor) return not null access Element_Type
+ is
+ begin
+ if not Has_Element (Container.all, Position) then
+ raise Constraint_Error with "Position cursor has no element";
+ end if;
+
+ pragma Assert
+ (Vet (Container.Content, Position.Node),
+ "bad cursor in function Reference");
+
+ return Container.Content.Nodes (Position.Node).Element'Access;
+ end Reference;
+
+ function Reference
+ (Container : not null access Map;
+ Key : Key_Type) return not null access Element_Type
+ is
+ Node : constant Count_Type := Find (Container.all, Key).Node;
+
+ begin
+ if Node = 0 then
+ raise Constraint_Error with
+ "no element available because key not in map";
+ end if;
+
+ return Container.Content.Nodes (Node).Element'Access;
+ end Reference;
+
-------------
-- Replace --
-------------
@@ -1074,7 +1144,7 @@ is
is
begin
declare
- Node : constant Node_Access := Key_Ops.Find (Container, Key);
+ Node : constant Node_Access := Key_Ops.Find (Container.Content, Key);
begin
if Node = 0 then
@@ -1082,7 +1152,7 @@ is
end if;
declare
- N : Node_Type renames Container.Nodes (Node);
+ N : Node_Type renames Container.Content.Nodes (Node);
begin
N.Key := Key;
N.Element := New_Item;
@@ -1105,10 +1175,10 @@ is
"Position cursor of Replace_Element has no element";
end if;
- pragma Assert (Vet (Container, Position.Node),
+ pragma Assert (Vet (Container.Content, Position.Node),
"Position cursor of Replace_Element is bad");
- Container.Nodes (Position.Node).Element := New_Item;
+ Container.Content.Nodes (Position.Node).Element := New_Item;
end Replace_Element;
---------------
diff --git a/gcc/ada/libgnat/a-cforma.ads b/gcc/ada/libgnat/a-cforma.ads
index 99b02a5..a1cad03 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2021, 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 --
@@ -63,6 +63,11 @@ generic
package Ada.Containers.Formal_Ordered_Maps with
SPARK_Mode
is
+ -- Contracts in this unit are meant for analysis only, not for run-time
+ -- checking.
+
+ pragma Assertion_Policy (Pre => Ignore);
+ pragma Assertion_Policy (Post => Ignore);
pragma Annotate (CodePeer, Skip_Analysis);
function Equivalent_Keys (Left, Right : Key_Type) return Boolean with
@@ -395,6 +400,95 @@ is
Model (Container)'Old,
Key (Container, Position));
+ function At_End
+ (E : not null access constant Map) return not null access constant Map
+ is (E)
+ with Ghost,
+ Annotate => (GNATprove, At_End_Borrow);
+
+ function At_End
+ (E : access constant Element_Type) return access constant Element_Type
+ is (E)
+ with Ghost,
+ Annotate => (GNATprove, At_End_Borrow);
+
+ function Constant_Reference
+ (Container : aliased Map;
+ Position : Cursor) return not null access constant Element_Type
+ with
+ Global => null,
+ Pre => Has_Element (Container, Position),
+ Post =>
+ Constant_Reference'Result.all =
+ Element (Model (Container), Key (Container, Position));
+
+ function Reference
+ (Container : not null access Map;
+ Position : Cursor) return not null access Element_Type
+ with
+ Global => null,
+ Pre => Has_Element (Container.all, Position),
+ Post =>
+
+ -- Order of keys and cursors is preserved
+
+ Keys (At_End (Container).all) = Keys (Container.all)
+ and Positions (At_End (Container).all) = Positions (Container.all)
+
+ -- The value designated by the result of Reference is now associated
+ -- with the key at position Position in Container.
+
+ and Element (At_End (Container).all, Position) =
+ At_End (Reference'Result).all
+
+ -- Elements associated with other keys are preserved
+
+ and M.Same_Keys
+ (Model (At_End (Container).all),
+ Model (Container.all))
+ and M.Elements_Equal_Except
+ (Model (At_End (Container).all),
+ Model (Container.all),
+ Key (At_End (Container).all, Position));
+
+ function Constant_Reference
+ (Container : aliased Map;
+ Key : Key_Type) return not null access constant Element_Type
+ with
+ Global => null,
+ Pre => Contains (Container, Key),
+ Post =>
+ Constant_Reference'Result.all = Element (Model (Container), Key);
+
+ function Reference
+ (Container : not null access Map;
+ Key : Key_Type) return not null access Element_Type
+ with
+ Global => null,
+ Pre => Contains (Container.all, Key),
+ Post =>
+
+ -- Order of keys and cursors is preserved
+
+ Keys (At_End (Container).all) = Keys (Container.all)
+ and Positions (At_End (Container).all) = Positions (Container.all)
+
+ -- The value designated by the result of Reference is now associated
+ -- with Key in Container.
+
+ and Element (Model (At_End (Container).all), Key) =
+ At_End (Reference'Result).all
+
+ -- Elements associated with other keys are preserved
+
+ and M.Same_Keys
+ (Model (At_End (Container).all),
+ Model (Container.all))
+ and M.Elements_Equal_Except
+ (Model (At_End (Container).all),
+ Model (Container.all),
+ Key);
+
procedure Move (Target : in out Map; Source : in out Map) with
Global => null,
Pre => Target.Capacity >= Length (Source),
@@ -1040,14 +1134,15 @@ private
Right : Node_Access := 0;
Color : Red_Black_Trees.Color_Type := Red;
Key : Key_Type;
- Element : Element_Type;
+ Element : aliased Element_Type;
end record;
package Tree_Types is
new Ada.Containers.Red_Black_Trees.Generic_Bounded_Tree_Types (Node_Type);
- type Map (Capacity : Count_Type) is
- new Tree_Types.Tree_Type (Capacity) with null record;
+ type Map (Capacity : Count_Type) is record
+ Content : Tree_Types.Tree_Type (Capacity);
+ end record;
Empty_Map : constant Map := (Capacity => 0, others => <>);
diff --git a/gcc/ada/libgnat/a-cforse.adb b/gcc/ada/libgnat/a-cforse.adb
index 991d1dc..7c45e4f 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2010-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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,10 @@ is
-- Comments needed???
+ procedure Assign
+ (Target : in out Tree_Types.Tree_Type;
+ Source : Tree_Types.Tree_Type);
+
generic
with procedure Set_Element (Node : in out Node_Type);
procedure Generic_Allocate
@@ -90,13 +94,13 @@ is
procedure Free (Tree : in out Set; X : Count_Type);
procedure Insert_Sans_Hint
- (Container : in out Set;
+ (Container : in out Tree_Types.Tree_Type;
New_Item : Element_Type;
Node : out Count_Type;
Inserted : out Boolean);
procedure Insert_With_Hint
- (Dst_Set : in out Set;
+ (Dst_Set : in out Tree_Types.Tree_Type;
Dst_Hint : Count_Type;
Src_Node : Node_Type;
Dst_Node : out Count_Type);
@@ -141,7 +145,7 @@ is
package Set_Ops is
new Red_Black_Trees.Generic_Bounded_Set_Operations
(Tree_Operations => Tree_Operations,
- Set_Type => Set,
+ Set_Type => Tree_Types.Tree_Type,
Assign => Assign,
Insert_With_Hint => Insert_With_Hint,
Is_Less => Is_Less_Node_Node);
@@ -164,18 +168,19 @@ is
return True;
end if;
- Lst := Next (Left, Last (Left).Node);
+ Lst := Next (Left.Content, Last (Left).Node);
Node := First (Left).Node;
while Node /= Lst loop
- ENode := Find (Right, Left.Nodes (Node).Element).Node;
+ ENode := Find (Right, Left.Content.Nodes (Node).Element).Node;
if ENode = 0
- or else Left.Nodes (Node).Element /= Right.Nodes (ENode).Element
+ or else Left.Content.Nodes (Node).Element /=
+ Right.Content.Nodes (ENode).Element
then
return False;
end if;
- Node := Next (Left, Node);
+ Node := Next (Left.Content, Node);
end loop;
return True;
@@ -185,7 +190,10 @@ is
-- Assign --
------------
- procedure Assign (Target : in out Set; Source : Set) is
+ procedure Assign
+ (Target : in out Tree_Types.Tree_Type;
+ Source : Tree_Types.Tree_Type)
+ is
procedure Append_Element (Source_Node : Count_Type);
procedure Append_Elements is
@@ -267,12 +275,18 @@ is
Append_Elements (Source);
end Assign;
+ procedure Assign (Target : in out Set; Source : Set) is
+ begin
+ Assign (Target.Content, Source.Content);
+ end Assign;
+
-------------
-- Ceiling --
-------------
function Ceiling (Container : Set; Item : Element_Type) return Cursor is
- Node : constant Count_Type := Element_Keys.Ceiling (Container, Item);
+ Node : constant Count_Type :=
+ Element_Keys.Ceiling (Container.Content, Item);
begin
if Node = 0 then
@@ -288,7 +302,7 @@ is
procedure Clear (Container : in out Set) is
begin
- Tree_Operations.Clear_Tree (Container);
+ Tree_Operations.Clear_Tree (Container.Content);
end Clear;
-----------
@@ -300,6 +314,25 @@ is
return Node.Color;
end Color;
+ ------------------------
+ -- Constant_Reference --
+ ------------------------
+
+ function Constant_Reference
+ (Container : aliased Set;
+ Position : Cursor) return not null access constant Element_Type
+ is
+ begin
+ if not Has_Element (Container, Position) then
+ raise Constraint_Error with "Position cursor has no element";
+ end if;
+
+ pragma Assert (Vet (Container.Content, Position.Node),
+ "bad cursor in Element");
+
+ return Container.Content.Nodes (Position.Node).Element'Access;
+ end Constant_Reference;
+
--------------
-- Contains --
--------------
@@ -327,32 +360,32 @@ is
end if;
if Length (Source) > 0 then
- Target.Length := Source.Length;
- Target.Root := Source.Root;
- Target.First := Source.First;
- Target.Last := Source.Last;
- Target.Free := Source.Free;
+ Target.Content.Length := Source.Content.Length;
+ Target.Content.Root := Source.Content.Root;
+ Target.Content.First := Source.Content.First;
+ Target.Content.Last := Source.Content.Last;
+ Target.Content.Free := Source.Content.Free;
Node := 1;
while Node <= Source.Capacity loop
- Target.Nodes (Node).Element :=
- Source.Nodes (Node).Element;
- Target.Nodes (Node).Parent :=
- Source.Nodes (Node).Parent;
- Target.Nodes (Node).Left :=
- Source.Nodes (Node).Left;
- Target.Nodes (Node).Right :=
- Source.Nodes (Node).Right;
- Target.Nodes (Node).Color :=
- Source.Nodes (Node).Color;
- Target.Nodes (Node).Has_Element :=
- Source.Nodes (Node).Has_Element;
+ Target.Content.Nodes (Node).Element :=
+ Source.Content.Nodes (Node).Element;
+ Target.Content.Nodes (Node).Parent :=
+ Source.Content.Nodes (Node).Parent;
+ Target.Content.Nodes (Node).Left :=
+ Source.Content.Nodes (Node).Left;
+ Target.Content.Nodes (Node).Right :=
+ Source.Content.Nodes (Node).Right;
+ Target.Content.Nodes (Node).Color :=
+ Source.Content.Nodes (Node).Color;
+ Target.Content.Nodes (Node).Has_Element :=
+ Source.Content.Nodes (Node).Has_Element;
Node := Node + 1;
end loop;
while Node <= Target.Capacity loop
N := Node;
- Formal_Ordered_Sets.Free (Tree => Target, X => N);
+ Free (Tree => Target, X => N);
Node := Node + 1;
end loop;
end if;
@@ -370,25 +403,25 @@ is
raise Constraint_Error with "Position cursor has no element";
end if;
- pragma Assert (Vet (Container, Position.Node),
+ pragma Assert (Vet (Container.Content, Position.Node),
"bad cursor in Delete");
- Tree_Operations.Delete_Node_Sans_Free (Container,
+ Tree_Operations.Delete_Node_Sans_Free (Container.Content,
Position.Node);
- Formal_Ordered_Sets.Free (Container, Position.Node);
+ Free (Container, Position.Node);
Position := No_Element;
end Delete;
procedure Delete (Container : in out Set; Item : Element_Type) is
- X : constant Count_Type := Element_Keys.Find (Container, Item);
+ X : constant Count_Type := Element_Keys.Find (Container.Content, Item);
begin
if X = 0 then
raise Constraint_Error with "attempt to delete element not in set";
end if;
- Tree_Operations.Delete_Node_Sans_Free (Container, X);
- Formal_Ordered_Sets.Free (Container, X);
+ Tree_Operations.Delete_Node_Sans_Free (Container.Content, X);
+ Free (Container, X);
end Delete;
------------------
@@ -396,11 +429,11 @@ is
------------------
procedure Delete_First (Container : in out Set) is
- X : constant Count_Type := Container.First;
+ X : constant Count_Type := Container.Content.First;
begin
if X /= 0 then
- Tree_Operations.Delete_Node_Sans_Free (Container, X);
- Formal_Ordered_Sets.Free (Container, X);
+ Tree_Operations.Delete_Node_Sans_Free (Container.Content, X);
+ Free (Container, X);
end if;
end Delete_First;
@@ -409,11 +442,11 @@ is
-----------------
procedure Delete_Last (Container : in out Set) is
- X : constant Count_Type := Container.Last;
+ X : constant Count_Type := Container.Content.Last;
begin
if X /= 0 then
- Tree_Operations.Delete_Node_Sans_Free (Container, X);
- Formal_Ordered_Sets.Free (Container, X);
+ Tree_Operations.Delete_Node_Sans_Free (Container.Content, X);
+ Free (Container, X);
end if;
end Delete_Last;
@@ -423,7 +456,7 @@ is
procedure Difference (Target : in out Set; Source : Set) is
begin
- Set_Ops.Set_Difference (Target, Source);
+ Set_Ops.Set_Difference (Target.Content, Source.Content);
end Difference;
function Difference (Left, Right : Set) return Set is
@@ -437,11 +470,12 @@ is
end if;
if Length (Right) = 0 then
- return Left.Copy;
+ return Copy (Left);
end if;
return S : Set (Length (Left)) do
- Assign (S, Set_Ops.Set_Difference (Left, Right));
+ Assign
+ (S.Content, Set_Ops.Set_Difference (Left.Content, Right.Content));
end return;
end Difference;
@@ -455,10 +489,10 @@ is
raise Constraint_Error with "Position cursor has no element";
end if;
- pragma Assert (Vet (Container, Position.Node),
+ pragma Assert (Vet (Container.Content, Position.Node),
"bad cursor in Element");
- return Container.Nodes (Position.Node).Element;
+ return Container.Content.Nodes (Position.Node).Element;
end Element;
-------------------------
@@ -506,7 +540,7 @@ is
-- Start of processing for Equivalent_Sets
begin
- return Is_Equivalent (Left, Right);
+ return Is_Equivalent (Left.Content, Right.Content);
end Equivalent_Sets;
-------------
@@ -514,11 +548,11 @@ is
-------------
procedure Exclude (Container : in out Set; Item : Element_Type) is
- X : constant Count_Type := Element_Keys.Find (Container, Item);
+ X : constant Count_Type := Element_Keys.Find (Container.Content, Item);
begin
if X /= 0 then
- Tree_Operations.Delete_Node_Sans_Free (Container, X);
- Formal_Ordered_Sets.Free (Container, X);
+ Tree_Operations.Delete_Node_Sans_Free (Container.Content, X);
+ Free (Container, X);
end if;
end Exclude;
@@ -527,7 +561,8 @@ is
----------
function Find (Container : Set; Item : Element_Type) return Cursor is
- Node : constant Count_Type := Element_Keys.Find (Container, Item);
+ Node : constant Count_Type :=
+ Element_Keys.Find (Container.Content, Item);
begin
if Node = 0 then
@@ -547,7 +582,7 @@ is
return No_Element;
end if;
- return (Node => Container.First);
+ return (Node => Container.Content.First);
end First;
-------------------
@@ -562,7 +597,7 @@ is
end if;
declare
- N : Tree_Types.Nodes_Type renames Container.Nodes;
+ N : Tree_Types.Nodes_Type renames Container.Content.Nodes;
begin
return N (Fst).Element;
end;
@@ -575,7 +610,8 @@ is
function Floor (Container : Set; Item : Element_Type) return Cursor is
begin
declare
- Node : constant Count_Type := Element_Keys.Floor (Container, Item);
+ Node : constant Count_Type :=
+ Element_Keys.Floor (Container.Content, Item);
begin
if Node = 0 then
@@ -748,7 +784,7 @@ is
--------------
function Elements (Container : Set) return E.Sequence is
- Position : Count_Type := Container.First;
+ Position : Count_Type := Container.Content.First;
R : E.Sequence;
begin
@@ -756,8 +792,8 @@ is
-- for their postconditions.
while Position /= 0 loop
- R := E.Add (R, Container.Nodes (Position).Element);
- Position := Tree_Operations.Next (Container, Position);
+ R := E.Add (R, Container.Content.Nodes (Position).Element);
+ Position := Tree_Operations.Next (Container.Content, Position);
end loop;
return R;
@@ -873,7 +909,7 @@ is
-----------
function Model (Container : Set) return M.Set is
- Position : Count_Type := Container.First;
+ Position : Count_Type := Container.Content.First;
R : M.Set;
begin
@@ -884,9 +920,9 @@ is
R :=
M.Add
(Container => R,
- Item => Container.Nodes (Position).Element);
+ Item => Container.Content.Nodes (Position).Element);
- Position := Tree_Operations.Next (Container, Position);
+ Position := Tree_Operations.Next (Container.Content, Position);
end loop;
return R;
@@ -898,7 +934,7 @@ is
function Positions (Container : Set) return P.Map is
I : Count_Type := 1;
- Position : Count_Type := Container.First;
+ Position : Count_Type := Container.Content.First;
R : P.Map;
begin
@@ -908,7 +944,7 @@ is
while Position /= 0 loop
R := P.Add (R, (Node => Position), I);
pragma Assert (P.Length (R) = I);
- Position := Tree_Operations.Next (Container, Position);
+ Position := Tree_Operations.Next (Container.Content, Position);
I := I + 1;
end loop;
@@ -923,8 +959,8 @@ is
procedure Free (Tree : in out Set; X : Count_Type) is
begin
- Tree.Nodes (X).Has_Element := False;
- Tree_Operations.Free (Tree, X);
+ Tree.Content.Nodes (X).Has_Element := False;
+ Tree_Operations.Free (Tree.Content, X);
end Free;
----------------------
@@ -978,7 +1014,8 @@ is
-------------
function Ceiling (Container : Set; Key : Key_Type) return Cursor is
- Node : constant Count_Type := Key_Keys.Ceiling (Container, Key);
+ Node : constant Count_Type :=
+ Key_Keys.Ceiling (Container.Content, Key);
begin
if Node = 0 then
@@ -1002,15 +1039,15 @@ is
------------
procedure Delete (Container : in out Set; Key : Key_Type) is
- X : constant Count_Type := Key_Keys.Find (Container, Key);
+ X : constant Count_Type := Key_Keys.Find (Container.Content, Key);
begin
if X = 0 then
raise Constraint_Error with "attempt to delete key not in set";
end if;
- Delete_Node_Sans_Free (Container, X);
- Formal_Ordered_Sets.Free (Container, X);
+ Delete_Node_Sans_Free (Container.Content, X);
+ Free (Container, X);
end Delete;
-------------
@@ -1018,7 +1055,7 @@ is
-------------
function Element (Container : Set; Key : Key_Type) return Element_Type is
- Node : constant Count_Type := Key_Keys.Find (Container, Key);
+ Node : constant Count_Type := Key_Keys.Find (Container.Content, Key);
begin
if Node = 0 then
@@ -1026,7 +1063,7 @@ is
end if;
declare
- N : Tree_Types.Nodes_Type renames Container.Nodes;
+ N : Tree_Types.Nodes_Type renames Container.Content.Nodes;
begin
return N (Node).Element;
end;
@@ -1052,11 +1089,11 @@ is
-------------
procedure Exclude (Container : in out Set; Key : Key_Type) is
- X : constant Count_Type := Key_Keys.Find (Container, Key);
+ X : constant Count_Type := Key_Keys.Find (Container.Content, Key);
begin
if X /= 0 then
- Delete_Node_Sans_Free (Container, X);
- Formal_Ordered_Sets.Free (Container, X);
+ Delete_Node_Sans_Free (Container.Content, X);
+ Free (Container, X);
end if;
end Exclude;
@@ -1065,7 +1102,7 @@ is
----------
function Find (Container : Set; Key : Key_Type) return Cursor is
- Node : constant Count_Type := Key_Keys.Find (Container, Key);
+ Node : constant Count_Type := Key_Keys.Find (Container.Content, Key);
begin
return (if Node = 0 then No_Element else (Node => Node));
end Find;
@@ -1075,7 +1112,7 @@ is
-----------
function Floor (Container : Set; Key : Key_Type) return Cursor is
- Node : constant Count_Type := Key_Keys.Floor (Container, Key);
+ Node : constant Count_Type := Key_Keys.Floor (Container.Content, Key);
begin
return (if Node = 0 then No_Element else (Node => Node));
end Floor;
@@ -1225,11 +1262,11 @@ is
"Position cursor has no element";
end if;
- pragma Assert (Vet (Container, Position.Node),
+ pragma Assert (Vet (Container.Content, Position.Node),
"bad cursor in Key");
declare
- N : Tree_Types.Nodes_Type renames Container.Nodes;
+ N : Tree_Types.Nodes_Type renames Container.Content.Nodes;
begin
return Key (N (Position.Node).Element);
end;
@@ -1244,7 +1281,7 @@ is
Key : Key_Type;
New_Item : Element_Type)
is
- Node : constant Count_Type := Key_Keys.Find (Container, Key);
+ Node : constant Count_Type := Key_Keys.Find (Container.Content, Key);
begin
if not Has_Element (Container, (Node => Node)) then
raise Constraint_Error with
@@ -1265,7 +1302,7 @@ is
if Position.Node = 0 then
return False;
else
- return Container.Nodes (Position.Node).Has_Element;
+ return Container.Content.Nodes (Position.Node).Has_Element;
end if;
end Has_Element;
@@ -1282,7 +1319,7 @@ is
if not Inserted then
declare
- N : Tree_Types.Nodes_Type renames Container.Nodes;
+ N : Tree_Types.Nodes_Type renames Container.Content.Nodes;
begin
N (Position.Node).Element := New_Item;
end;
@@ -1300,7 +1337,7 @@ is
Inserted : out Boolean)
is
begin
- Insert_Sans_Hint (Container, New_Item, Position.Node, Inserted);
+ Insert_Sans_Hint (Container.Content, New_Item, Position.Node, Inserted);
end Insert;
procedure Insert
@@ -1324,7 +1361,7 @@ is
----------------------
procedure Insert_Sans_Hint
- (Container : in out Set;
+ (Container : in out Tree_Types.Tree_Type;
New_Item : Element_Type;
Node : out Count_Type;
Inserted : out Boolean)
@@ -1377,7 +1414,7 @@ is
----------------------
procedure Insert_With_Hint
- (Dst_Set : in out Set;
+ (Dst_Set : in out Tree_Types.Tree_Type;
Dst_Hint : Count_Type;
Src_Node : Node_Type;
Dst_Node : out Count_Type)
@@ -1439,17 +1476,18 @@ is
procedure Intersection (Target : in out Set; Source : Set) is
begin
- Set_Ops.Set_Intersection (Target, Source);
+ Set_Ops.Set_Intersection (Target.Content, Source.Content);
end Intersection;
function Intersection (Left, Right : Set) return Set is
begin
if Left'Address = Right'Address then
- return Left.Copy;
+ return Copy (Left);
end if;
return S : Set (Count_Type'Min (Length (Left), Length (Right))) do
- Assign (S, Set_Ops.Set_Intersection (Left, Right));
+ Assign (S.Content,
+ Set_Ops.Set_Intersection (Left.Content, Right.Content));
end return;
end Intersection;
@@ -1503,7 +1541,7 @@ is
function Is_Subset (Subset : Set; Of_Set : Set) return Boolean is
begin
- return Set_Ops.Set_Subset (Subset, Of_Set => Of_Set);
+ return Set_Ops.Set_Subset (Subset.Content, Of_Set => Of_Set.Content);
end Is_Subset;
----------
@@ -1514,7 +1552,7 @@ is
begin
return (if Length (Container) = 0
then No_Element
- else (Node => Container.Last));
+ else (Node => Container.Content.Last));
end Last;
------------------
@@ -1528,7 +1566,7 @@ is
end if;
declare
- N : Tree_Types.Nodes_Type renames Container.Nodes;
+ N : Tree_Types.Nodes_Type renames Container.Content.Nodes;
begin
return N (Last (Container).Node).Element;
end;
@@ -1549,7 +1587,7 @@ is
function Length (Container : Set) return Count_Type is
begin
- return Container.Length;
+ return Container.Content.Length;
end Length;
----------
@@ -1557,7 +1595,7 @@ is
----------
procedure Move (Target : in out Set; Source : in out Set) is
- N : Tree_Types.Nodes_Type renames Source.Nodes;
+ N : Tree_Types.Nodes_Type renames Source.Content.Nodes;
X : Count_Type;
begin
@@ -1573,13 +1611,13 @@ is
Clear (Target);
loop
- X := Source.First;
+ X := Source.Content.First;
exit when X = 0;
Insert (Target, N (X).Element); -- optimize???
- Tree_Operations.Delete_Node_Sans_Free (Source, X);
- Formal_Ordered_Sets.Free (Source, X);
+ Tree_Operations.Delete_Node_Sans_Free (Source.Content, X);
+ Free (Source, X);
end loop;
end Move;
@@ -1597,9 +1635,9 @@ is
raise Constraint_Error;
end if;
- pragma Assert (Vet (Container, Position.Node),
+ pragma Assert (Vet (Container.Content, Position.Node),
"bad cursor in Next");
- return (Node => Tree_Operations.Next (Container, Position.Node));
+ return (Node => Tree_Operations.Next (Container.Content, Position.Node));
end Next;
procedure Next (Container : Set; Position : in out Cursor) is
@@ -1613,7 +1651,7 @@ is
function Overlap (Left, Right : Set) return Boolean is
begin
- return Set_Ops.Set_Overlap (Left, Right);
+ return Set_Ops.Set_Overlap (Left.Content, Right.Content);
end Overlap;
------------
@@ -1639,12 +1677,12 @@ is
raise Constraint_Error;
end if;
- pragma Assert (Vet (Container, Position.Node),
+ pragma Assert (Vet (Container.Content, Position.Node),
"bad cursor in Previous");
declare
Node : constant Count_Type :=
- Tree_Operations.Previous (Container, Position.Node);
+ Tree_Operations.Previous (Container.Content, Position.Node);
begin
return (if Node = 0 then No_Element else (Node => Node));
end;
@@ -1660,7 +1698,8 @@ is
-------------
procedure Replace (Container : in out Set; New_Item : Element_Type) is
- Node : constant Count_Type := Element_Keys.Find (Container, New_Item);
+ Node : constant Count_Type :=
+ Element_Keys.Find (Container.Content, New_Item);
begin
if Node = 0 then
@@ -1668,7 +1707,7 @@ is
"attempt to replace element not in set";
end if;
- Container.Nodes (Node).Element := New_Item;
+ Container.Content.Nodes (Node).Element := New_Item;
end Replace;
---------------------
@@ -1696,7 +1735,7 @@ is
(Local_Insert_Post,
Local_Insert_Sans_Hint);
- NN : Tree_Types.Nodes_Type renames Tree.Nodes;
+ NN : Tree_Types.Nodes_Type renames Tree.Content.Nodes;
--------------
-- New_Node --
@@ -1730,7 +1769,7 @@ is
return;
end if;
- Hint := Element_Keys.Ceiling (Tree, Item);
+ Hint := Element_Keys.Ceiling (Tree.Content, Item);
if Hint = 0 then
null;
@@ -1746,10 +1785,10 @@ is
raise Program_Error with "attempt to replace existing element";
end if;
- Tree_Operations.Delete_Node_Sans_Free (Tree, Node);
+ Tree_Operations.Delete_Node_Sans_Free (Tree.Content, Node);
Local_Insert_With_Hint
- (Tree => Tree,
+ (Tree => Tree.Content,
Position => Hint,
Key => Item,
Node => Result,
@@ -1770,7 +1809,7 @@ is
"Position cursor has no element";
end if;
- pragma Assert (Vet (Container, Position.Node),
+ pragma Assert (Vet (Container.Content, Position.Node),
"bad cursor in Replace_Element");
Replace_Element (Container, Position.Node, New_Item);
@@ -1830,7 +1869,7 @@ is
procedure Symmetric_Difference (Target : in out Set; Source : Set) is
begin
- Set_Ops.Set_Symmetric_Difference (Target, Source);
+ Set_Ops.Set_Symmetric_Difference (Target.Content, Source.Content);
end Symmetric_Difference;
function Symmetric_Difference (Left, Right : Set) return Set is
@@ -1840,15 +1879,17 @@ is
end if;
if Length (Right) = 0 then
- return Left.Copy;
+ return Copy (Left);
end if;
if Length (Left) = 0 then
- return Right.Copy;
+ return Copy (Right);
end if;
return S : Set (Length (Left) + Length (Right)) do
- Assign (S, Set_Ops.Set_Symmetric_Difference (Left, Right));
+ Assign
+ (S.Content,
+ Set_Ops.Set_Symmetric_Difference (Left.Content, Right.Content));
end return;
end Symmetric_Difference;
@@ -1861,7 +1902,7 @@ is
Inserted : Boolean;
begin
return S : Set (Capacity => 1) do
- Insert_Sans_Hint (S, New_Item, Node, Inserted);
+ Insert_Sans_Hint (S.Content, New_Item, Node, Inserted);
pragma Assert (Inserted);
end return;
end To_Set;
@@ -1872,21 +1913,21 @@ is
procedure Union (Target : in out Set; Source : Set) is
begin
- Set_Ops.Set_Union (Target, Source);
+ Set_Ops.Set_Union (Target.Content, Source.Content);
end Union;
function Union (Left, Right : Set) return Set is
begin
if Left'Address = Right'Address then
- return Left.Copy;
+ return Copy (Left);
end if;
if Length (Left) = 0 then
- return Right.Copy;
+ return Copy (Right);
end if;
if Length (Right) = 0 then
- return Left.Copy;
+ return Copy (Left);
end if;
return S : Set (Length (Left) + Length (Right)) do
diff --git a/gcc/ada/libgnat/a-cforse.ads b/gcc/ada/libgnat/a-cforse.ads
index a818726..e1d7c91 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2021, 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 --
@@ -59,6 +59,11 @@ generic
package Ada.Containers.Formal_Ordered_Sets with
SPARK_Mode
is
+ -- Contracts in this unit are meant for analysis only, not for run-time
+ -- checking.
+
+ pragma Assertion_Policy (Pre => Ignore);
+ pragma Assertion_Policy (Post => Ignore);
pragma Annotate (CodePeer, Skip_Analysis);
function Equivalent_Elements (Left, Right : Element_Type) return Boolean
@@ -524,6 +529,16 @@ is
Position => Position)
and Positions (Container) = Positions (Container)'Old;
+ function Constant_Reference
+ (Container : aliased Set;
+ Position : Cursor) return not null access constant Element_Type
+ with
+ Global => null,
+ Pre => Has_Element (Container, Position),
+ Post =>
+ Constant_Reference'Result.all =
+ E.Get (Elements (Container), P.Get (Positions (Container), Position));
+
procedure Move (Target : in out Set; Source : in out Set) with
Global => null,
Pre => Target.Capacity >= Length (Source),
@@ -1765,18 +1780,19 @@ private
type Node_Type is record
Has_Element : Boolean := False;
- Parent : Count_Type := 0;
- Left : Count_Type := 0;
- Right : Count_Type := 0;
- Color : Red_Black_Trees.Color_Type;
- Element : Element_Type;
+ Parent : Count_Type := 0;
+ Left : Count_Type := 0;
+ Right : Count_Type := 0;
+ Color : Red_Black_Trees.Color_Type;
+ Element : aliased Element_Type;
end record;
package Tree_Types is
new Red_Black_Trees.Generic_Bounded_Tree_Types (Node_Type);
- type Set (Capacity : Count_Type) is
- new Tree_Types.Tree_Type (Capacity) with null record;
+ type Set (Capacity : Count_Type) is record
+ Content : Tree_Types.Tree_Type (Capacity);
+ end record;
use Red_Black_Trees;
diff --git a/gcc/ada/libgnat/a-cgaaso.adb b/gcc/ada/libgnat/a-cgaaso.adb
index 6d0049a..ec4952c 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 c809b65..cfa858a 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 5f4e594..18a20e7 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 ff03b80..ca4f14a 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 638dcc4..dbb1b0e 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2005-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 df2e276..6f611f5 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2005-2021, 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 de66846..827794c 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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-chahan.ads b/gcc/ada/libgnat/a-chahan.ads
index 04f975c..2f93e7c 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, 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-chlat9.ads b/gcc/ada/libgnat/a-chlat9.ads
index de9b54e..53ce457 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2002-2021, 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 89358e4..148b92d 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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-chtgbk.ads b/gcc/ada/libgnat/a-chtgbk.ads
index 43ad208..edeca72 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 9fec5c4..678cdc0 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 5fc852d..1779c79 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 fdd62b7..76c7e1b 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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.ads b/gcc/ada/libgnat/a-chtgke.ads
index 375ddf6..1445369 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 6e7511f..7250488 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 9073d57..a2081dd 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 8afca7d..3d27eba 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 389bccf..0359309 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 79df5a9..3fc57da 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -1311,7 +1311,7 @@ is
---------------
procedure Put_Image
- (S : in out Ada.Strings.Text_Output.Sink'Class; V : List)
+ (S : in out Ada.Strings.Text_Buffers.Root_Buffer_Type'Class; V : List)
is
First_Time : Boolean := True;
use System.Put_Images;
diff --git a/gcc/ada/libgnat/a-cidlli.ads b/gcc/ada/libgnat/a-cidlli.ads
index c75e5af..c8794a3 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2021, 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,7 +36,7 @@ with Ada.Iterator_Interfaces;
with Ada.Containers.Helpers;
private with Ada.Finalization;
private with Ada.Streams;
-private with Ada.Strings.Text_Output;
+private with Ada.Strings.Text_Buffers;
generic
type Element_Type (<>) is private;
@@ -65,7 +65,9 @@ is
pragma Preelaborable_Initialization (Cursor);
Empty_List : constant List;
+
function Empty return List;
+ pragma Ada_2022 (Empty);
No_Element : constant Cursor;
@@ -280,7 +282,7 @@ private
end record with Put_Image => Put_Image;
procedure Put_Image
- (S : in out Ada.Strings.Text_Output.Sink'Class; V : List);
+ (S : in out Ada.Strings.Text_Buffers.Root_Buffer_Type'Class; V : List);
overriding procedure Adjust (Container : in out List);
diff --git a/gcc/ada/libgnat/a-cihama.adb b/gcc/ada/libgnat/a-cihama.adb
index 7a490d5..2fbf65e 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -522,7 +522,8 @@ is
return No_Element;
end if;
- return Cursor'(Container'Unrestricted_Access, Node, Hash_Type'Last);
+ return Cursor'
+ (Container'Unrestricted_Access, Node, HT_Ops.Index (HT, Node));
end Find;
--------------------
@@ -748,6 +749,7 @@ is
end if;
Position.Container := Container'Unchecked_Access;
+ Position.Position := HT_Ops.Index (HT, Position.Node);
end Insert;
procedure Insert
@@ -971,7 +973,7 @@ is
---------------
procedure Put_Image
- (S : in out Ada.Strings.Text_Output.Sink'Class; V : Map)
+ (S : in out Ada.Strings.Text_Buffers.Root_Buffer_Type'Class; V : Map)
is
First_Time : Boolean := True;
use System.Put_Images;
diff --git a/gcc/ada/libgnat/a-cihama.ads b/gcc/ada/libgnat/a-cihama.ads
index ccf5f4e..056f338 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2021, 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,7 +36,7 @@ with Ada.Iterator_Interfaces;
private with Ada.Containers.Hash_Tables;
private with Ada.Finalization;
private with Ada.Streams;
-private with Ada.Strings.Text_Output;
+private with Ada.Strings.Text_Buffers;
generic
type Key_Type (<>) is private;
@@ -336,7 +336,7 @@ private
end record with Put_Image => Put_Image;
procedure Put_Image
- (S : in out Ada.Strings.Text_Output.Sink'Class; V : Map);
+ (S : in out Ada.Strings.Text_Buffers.Root_Buffer_Type'Class; V : Map);
overriding procedure Adjust (Container : in out Map);
@@ -363,8 +363,22 @@ private
type Cursor is record
Container : Map_Access;
+ -- Access to this cursor's container
+
Node : Node_Access;
+ -- Access to the node pointed to by this cursor
+
Position : Hash_Type := Hash_Type'Last;
+ -- Position of the node in the buckets of the container. If this is
+ -- equal to Hash_Type'Last, then it will not be used. Position is
+ -- not requried by the implementation, but improves the efficiency
+ -- of various operations.
+ --
+ -- However, this value must be maintained so that the predefined
+ -- equality operation acts as required by RM A.18.4-18/2, which
+ -- states: "The predefined "=" operator for type Cursor returns True
+ -- if both cursors are No_Element, or designate the same element
+ -- in the same container."
end record;
procedure Write
diff --git a/gcc/ada/libgnat/a-cihase.adb b/gcc/ada/libgnat/a-cihase.adb
index ebc9152..9fd4d98 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -1281,7 +1281,7 @@ is
---------------
procedure Put_Image
- (S : in out Ada.Strings.Text_Output.Sink'Class; V : Set)
+ (S : in out Ada.Strings.Text_Buffers.Root_Buffer_Type'Class; V : Set)
is
First_Time : Boolean := True;
use System.Put_Images;
diff --git a/gcc/ada/libgnat/a-cihase.ads b/gcc/ada/libgnat/a-cihase.ads
index cdfd86e..a73e898 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2021, 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 @@ private with Ada.Containers.Hash_Tables;
with Ada.Containers.Helpers;
private with Ada.Streams;
private with Ada.Finalization;
-private with Ada.Strings.Text_Output;
+private with Ada.Strings.Text_Buffers;
generic
type Element_Type (<>) is private;
@@ -500,7 +500,7 @@ private
end record with Put_Image => Put_Image;
procedure Put_Image
- (S : in out Ada.Strings.Text_Output.Sink'Class; V : Set);
+ (S : in out Ada.Strings.Text_Buffers.Root_Buffer_Type'Class; V : Set);
overriding procedure Adjust (Container : in out Set);
diff --git a/gcc/ada/libgnat/a-cimutr.adb b/gcc/ada/libgnat/a-cimutr.adb
index b358aad..aa7efac 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -1881,7 +1881,7 @@ is
---------------
procedure Put_Image
- (S : in out Ada.Strings.Text_Output.Sink'Class; V : Tree)
+ (S : in out Ada.Strings.Text_Buffers.Root_Buffer_Type'Class; V : Tree)
is
use System.Put_Images;
diff --git a/gcc/ada/libgnat/a-cimutr.ads b/gcc/ada/libgnat/a-cimutr.ads
index 9e03eb9..014d1fe 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2021, 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,7 +36,7 @@ with Ada.Iterator_Interfaces;
with Ada.Containers.Helpers;
private with Ada.Finalization;
private with Ada.Streams;
-private with Ada.Strings.Text_Output;
+private with Ada.Strings.Text_Buffers;
generic
type Element_Type (<>) is private;
@@ -352,7 +352,7 @@ private
end record with Put_Image => Put_Image;
procedure Put_Image
- (S : in out Ada.Strings.Text_Output.Sink'Class; V : Tree);
+ (S : in out Ada.Strings.Text_Buffers.Root_Buffer_Type'Class; V : Tree);
overriding procedure Adjust (Container : in out Tree);
diff --git a/gcc/ada/libgnat/a-ciorma.adb b/gcc/ada/libgnat/a-ciorma.adb
index 7cfe07d..a569156 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -1297,7 +1297,7 @@ is
---------------
procedure Put_Image
- (S : in out Ada.Strings.Text_Output.Sink'Class; V : Map)
+ (S : in out Ada.Strings.Text_Buffers.Root_Buffer_Type'Class; V : Map)
is
First_Time : Boolean := True;
use System.Put_Images;
diff --git a/gcc/ada/libgnat/a-ciorma.ads b/gcc/ada/libgnat/a-ciorma.ads
index 17f5dfd..157714d 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2021, 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,7 +36,7 @@ with Ada.Iterator_Interfaces;
private with Ada.Containers.Red_Black_Trees;
private with Ada.Finalization;
private with Ada.Streams;
-private with Ada.Strings.Text_Output;
+private with Ada.Strings.Text_Buffers;
generic
type Key_Type (<>) is private;
@@ -70,6 +70,7 @@ is
Empty_Map : constant Map;
function Empty return Map;
+ pragma Ada_2022 (Empty);
No_Element : constant Cursor;
function Has_Element (Position : Cursor) return Boolean;
@@ -264,7 +265,7 @@ private
end record with Put_Image => Put_Image;
procedure Put_Image
- (S : in out Ada.Strings.Text_Output.Sink'Class; V : Map);
+ (S : in out Ada.Strings.Text_Buffers.Root_Buffer_Type'Class; V : Map);
overriding procedure Adjust (Container : in out Map);
diff --git a/gcc/ada/libgnat/a-ciormu.adb b/gcc/ada/libgnat/a-ciormu.adb
index c3672f4..f1b9021 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -1663,7 +1663,7 @@ is
---------------
procedure Put_Image
- (S : in out Ada.Strings.Text_Output.Sink'Class; V : Set)
+ (S : in out Ada.Strings.Text_Buffers.Root_Buffer_Type'Class; V : Set)
is
First_Time : Boolean := True;
use System.Put_Images;
diff --git a/gcc/ada/libgnat/a-ciormu.ads b/gcc/ada/libgnat/a-ciormu.ads
index 5667e2c..cf8ea0d 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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 @@
private with Ada.Containers.Red_Black_Trees;
private with Ada.Finalization;
private with Ada.Streams;
-private with Ada.Strings.Text_Output;
+private with Ada.Strings.Text_Buffers;
with Ada.Iterator_Interfaces;
generic
@@ -472,7 +472,7 @@ private
end record with Put_Image => Put_Image;
procedure Put_Image
- (S : in out Ada.Strings.Text_Output.Sink'Class; V : Set);
+ (S : in out Ada.Strings.Text_Buffers.Root_Buffer_Type'Class; V : Set);
overriding procedure Adjust (Container : in out Set);
diff --git a/gcc/ada/libgnat/a-ciorse.adb b/gcc/ada/libgnat/a-ciorse.adb
index df56e48..7e63f15 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -1728,7 +1728,7 @@ is
---------------
procedure Put_Image
- (S : in out Ada.Strings.Text_Output.Sink'Class; V : Set)
+ (S : in out Ada.Strings.Text_Buffers.Root_Buffer_Type'Class; V : Set)
is
First_Time : Boolean := True;
use System.Put_Images;
diff --git a/gcc/ada/libgnat/a-ciorse.ads b/gcc/ada/libgnat/a-ciorse.ads
index 1b6e317..1a9d82c 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2021, 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 Ada.Containers.Helpers;
private with Ada.Containers.Red_Black_Trees;
private with Ada.Finalization;
private with Ada.Streams;
-private with Ada.Strings.Text_Output;
+private with Ada.Strings.Text_Buffers;
generic
type Element_Type (<>) is private;
@@ -364,7 +364,7 @@ private
end record with Put_Image => Put_Image;
procedure Put_Image
- (S : in out Ada.Strings.Text_Output.Sink'Class; V : Set);
+ (S : in out Ada.Strings.Text_Buffers.Root_Buffer_Type'Class; V : Set);
overriding procedure Adjust (Container : in out Set);
diff --git a/gcc/ada/libgnat/a-clrefi.adb b/gcc/ada/libgnat/a-clrefi.adb
index 2d2c78c..1bcb370 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2007-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 4aace2d..bb31bee 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2007-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 5d44163..21b9f54 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2015-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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,12 +65,32 @@ package body Ada.Containers.Bounded_Holders is
return Get (Left) = Get (Right);
end "=";
+ ------------------------
+ -- Constant_Reference --
+ ------------------------
+
+ function Constant_Reference
+ (Container : aliased Holder) return not null access constant Element_Type
+ is
+ begin
+ return Cast (Container'Address);
+ end Constant_Reference;
+
+ ---------
+ -- Get --
+ ---------
+
+ function Get (Container : Holder) return Element_Type is
+ begin
+ return Cast (Container'Address).all;
+ end Get;
+
---------------
-- Put_Image --
---------------
procedure Put_Image
- (S : in out Ada.Strings.Text_Output.Sink'Class; V : Holder)
+ (S : in out Ada.Strings.Text_Buffers.Root_Buffer_Type'Class; V : Holder)
is
use System.Put_Images;
begin
@@ -79,14 +99,16 @@ package body Ada.Containers.Bounded_Holders is
Array_After (S);
end Put_Image;
- ---------
- -- Get --
- ---------
+ ---------------
+ -- Reference --
+ ---------------
- function Get (Container : Holder) return Element_Type is
+ function Reference
+ (Container : not null access Holder) return not null access Element_Type
+ is
begin
- return Cast (Container'Address).all;
- end Get;
+ return Cast (Container.all'Address);
+ end Reference;
---------
-- Set --
diff --git a/gcc/ada/libgnat/a-coboho.ads b/gcc/ada/libgnat/a-coboho.ads
index 024e6a6..086f194 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2015-2021, 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 --
@@ -30,7 +30,7 @@
------------------------------------------------------------------------------
private with System;
-private with Ada.Strings.Text_Output;
+private with Ada.Strings.Text_Buffers;
generic
type Element_Type (<>) is private;
@@ -81,6 +81,12 @@ package Ada.Containers.Bounded_Holders is
procedure Set (Container : in out Holder; New_Item : Element_Type);
+ function Constant_Reference
+ (Container : aliased Holder) return not null access constant Element_Type;
+
+ function Reference
+ (Container : not null access Holder) return not null access Element_Type;
+
private
-- The implementation uses low-level tricks (Address clauses and unchecked
@@ -100,7 +106,7 @@ private
-- (default) alignment instead.
procedure Put_Image
- (S : in out Ada.Strings.Text_Output.Sink'Class; V : Holder);
+ (S : in out Ada.Strings.Text_Buffers.Root_Buffer_Type'Class; V : Holder);
type Element_Access is access all Element_Type;
pragma Assert (Element_Access'Size = Standard'Address_Size,
diff --git a/gcc/ada/libgnat/a-cobove.adb b/gcc/ada/libgnat/a-cobove.adb
index 8a8b279..e56cb94 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -415,7 +415,7 @@ package body Ada.Containers.Bounded_Vectors is
Container.TC'Unrestricted_Access;
begin
return R : constant Constant_Reference_Type :=
- (Element => A (J)'Access,
+ (Element => A (J)'Unchecked_Access,
Control => (Controlled with TC))
do
Busy (TC.all);
@@ -439,7 +439,7 @@ package body Ada.Containers.Bounded_Vectors is
Container.TC'Unrestricted_Access;
begin
return R : constant Constant_Reference_Type :=
- (Element => A (J)'Access,
+ (Element => A (J)'Unchecked_Access,
Control => (Controlled with TC))
do
Busy (TC.all);
@@ -2140,7 +2140,7 @@ package body Ada.Containers.Bounded_Vectors is
---------------
procedure Put_Image
- (S : in out Ada.Strings.Text_Output.Sink'Class; V : Vector)
+ (S : in out Ada.Strings.Text_Buffers.Root_Buffer_Type'Class; V : Vector)
is
First_Time : Boolean := True;
use System.Put_Images;
@@ -2238,7 +2238,7 @@ package body Ada.Containers.Bounded_Vectors is
Container.TC'Unrestricted_Access;
begin
return R : constant Reference_Type :=
- (Element => A (J)'Access,
+ (Element => A (J)'Unchecked_Access,
Control => (Controlled with TC))
do
Busy (TC.all);
@@ -2262,7 +2262,7 @@ package body Ada.Containers.Bounded_Vectors is
Container.TC'Unrestricted_Access;
begin
return R : constant Reference_Type :=
- (Element => A (J)'Access,
+ (Element => A (J)'Unchecked_Access,
Control => (Controlled with TC))
do
Busy (TC.all);
diff --git a/gcc/ada/libgnat/a-cobove.ads b/gcc/ada/libgnat/a-cobove.ads
index 324ca84..67c4419 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2021, 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,7 +36,7 @@ with Ada.Iterator_Interfaces;
with Ada.Containers.Helpers;
private with Ada.Streams;
private with Ada.Finalization;
-private with Ada.Strings.Text_Output;
+private with Ada.Strings.Text_Buffers;
generic
type Index_Type is range <>;
@@ -80,12 +80,14 @@ package Ada.Containers.Bounded_Vectors is
Ada.Iterator_Interfaces (Cursor, Has_Element);
function Empty (Capacity : Count_Type := 10) return Vector;
+ pragma Ada_2022 (Empty);
overriding function "=" (Left, Right : Vector) return Boolean;
function New_Vector (First, Last : Index_Type) return Vector
with Pre => First = Index_Type'First;
- -- Ada_2020 aggregate operation.
+ -- Ada 2022 aggregate operation.
+ pragma Ada_2022 (New_Vector);
function To_Vector (Length : Count_Type) return Vector;
@@ -194,6 +196,7 @@ package Ada.Containers.Bounded_Vectors is
(Container : in out Vector;
Before : Extended_Index;
New_Item : Vector);
+ pragma Ada_2022 (Insert_Vector);
procedure Insert
(Container : in out Vector;
@@ -205,6 +208,7 @@ package Ada.Containers.Bounded_Vectors is
(Container : in out Vector;
Before : Cursor;
New_Item : Vector);
+ pragma Ada_2022 (Insert_Vector);
procedure Insert
(Container : in out Vector;
@@ -217,6 +221,7 @@ package Ada.Containers.Bounded_Vectors is
Before : Cursor;
New_Item : Vector;
Position : out Cursor);
+ pragma Ada_2022 (Insert_Vector);
procedure Insert
(Container : in out Vector;
@@ -258,6 +263,7 @@ package Ada.Containers.Bounded_Vectors is
procedure Prepend_Vector
(Container : in out Vector;
New_Item : Vector);
+ pragma Ada_2022 (Prepend_Vector);
procedure Prepend
(Container : in out Vector;
@@ -272,6 +278,7 @@ package Ada.Containers.Bounded_Vectors is
procedure Append_Vector
(Container : in out Vector;
New_Item : Vector);
+ pragma Ada_2022 (Append_Vector);
procedure Append
(Container : in out Vector;
@@ -426,7 +433,7 @@ private
end record with Put_Image => Put_Image;
procedure Put_Image
- (S : in out Ada.Strings.Text_Output.Sink'Class; V : Vector);
+ (S : in out Ada.Strings.Text_Buffers.Root_Buffer_Type'Class; V : Vector);
procedure Write
(Stream : not null access Root_Stream_Type'Class;
diff --git a/gcc/ada/libgnat/a-cofove.adb b/gcc/ada/libgnat/a-cofove.adb
index d467384..c7f4f06 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2010-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -142,6 +142,22 @@ is
Container.Last := No_Index;
end Clear;
+ ------------------------
+ -- Constant_Reference --
+ ------------------------
+
+ function Constant_Reference
+ (Container : aliased Vector;
+ Index : Index_Type) return not null access constant Element_Type
+ is
+ begin
+ if Index > Container.Last then
+ raise Constraint_Error with "Index is out of range";
+ end if;
+
+ return Container.Elements (To_Array_Index (Index))'Access;
+ end Constant_Reference;
+
--------------
-- Contains --
--------------
@@ -868,11 +884,7 @@ 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
@@ -1100,6 +1112,22 @@ is
end;
end Replace_Element;
+ ---------------
+ -- Reference --
+ ---------------
+
+ function Reference
+ (Container : not null access Vector;
+ Index : Index_Type) return not null access Element_Type
+ is
+ begin
+ if Index > Container.Last then
+ raise Constraint_Error with "Index is out of range";
+ end if;
+
+ return Container.Elements (To_Array_Index (Index))'Access;
+ end Reference;
+
----------------------
-- Reserve_Capacity --
----------------------
diff --git a/gcc/ada/libgnat/a-cofove.ads b/gcc/ada/libgnat/a-cofove.ads
index 5712e63..a4ed7e5 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2021, 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,6 +45,11 @@ generic
package Ada.Containers.Formal_Vectors with
SPARK_Mode
is
+ -- Contracts in this unit are meant for analysis only, not for run-time
+ -- checking.
+
+ pragma Assertion_Policy (Pre => Ignore);
+ pragma Assertion_Policy (Post => Ignore);
pragma Annotate (CodePeer, Skip_Analysis);
subtype Extended_Index is Index_Type'Base
@@ -285,6 +290,48 @@ is
Right => Model (Container),
Position => Index);
+ function At_End (E : access constant Vector) return access constant Vector
+ is (E)
+ with Ghost,
+ Annotate => (GNATprove, At_End_Borrow);
+
+ function At_End
+ (E : access constant Element_Type) return access constant Element_Type
+ is (E)
+ with Ghost,
+ Annotate => (GNATprove, At_End_Borrow);
+
+ function Constant_Reference
+ (Container : aliased Vector;
+ Index : Index_Type) return not null access constant Element_Type
+ with
+ Global => null,
+ Pre => Index in First_Index (Container) .. Last_Index (Container),
+ Post =>
+ Constant_Reference'Result.all = Element (Model (Container), Index);
+
+ function Reference
+ (Container : not null access Vector;
+ Index : Index_Type) return not null access Element_Type
+ with
+ Global => null,
+ Pre =>
+ Index in First_Index (Container.all) .. Last_Index (Container.all),
+ Post =>
+ Length (Container.all) = Length (At_End (Container).all)
+
+ -- Container will have Result.all at index Index
+
+ and At_End (Reference'Result).all =
+ Element (Model (At_End (Container).all), Index)
+
+ -- All other elements are preserved
+
+ and M.Equal_Except
+ (Left => Model (Container.all),
+ Right => Model (At_End (Container).all),
+ Position => Index);
+
procedure Insert
(Container : in out Vector;
Before : Extended_Index;
@@ -900,7 +947,7 @@ private
pragma Inline (Contains);
subtype Array_Index is Capacity_Range range 1 .. Capacity_Range'Last;
- type Elements_Array is array (Array_Index range <>) of Element_Type;
+ type Elements_Array is array (Array_Index range <>) of aliased Element_Type;
function "=" (L, R : Elements_Array) return Boolean is abstract;
type Vector (Capacity : Capacity_Range) is record
diff --git a/gcc/ada/libgnat/a-cofuba.adb b/gcc/ada/libgnat/a-cofuba.adb
index 6f2b1f3..b290c74 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2016-2021, 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 7865342..1640b03 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2016-2021, 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 4defdf2..2b21b0c 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2016-2021, 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 d50d5de..a1dd764 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2016-2021, 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 --
@@ -302,6 +302,14 @@ package Ada.Containers.Functional_Maps with SPARK_Mode is
Global => null,
Pre => Has_Witness (Container, Witness);
+ function Copy_Key (Key : Key_Type) return Key_Type is (Key);
+ function Copy_Element (Item : Element_Type) return Element_Type is (Item);
+ -- Elements and Keys of maps are copied by numerous primitives in this
+ -- package. This function causes GNATprove to verify that such a copy is
+ -- valid (in particular, it does not break the ownership policy of SPARK,
+ -- i.e. it does not contain pointers that could be used to alias mutable
+ -- data).
+
---------------------------
-- Iteration Primitives --
---------------------------
diff --git a/gcc/ada/libgnat/a-cofuse.adb b/gcc/ada/libgnat/a-cofuse.adb
index 668c6d0..1c5f25b 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2016-2021, 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 4209e74..d0acba7 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2016-2021, 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 --
@@ -249,6 +249,13 @@ package Ada.Containers.Functional_Sets with SPARK_Mode is
and Right <= Union'Result
and Included_In_Union (Union'Result, Left, Right);
+ function Copy_Element (Item : Element_Type) return Element_Type is (Item);
+ -- Elements of containers are copied by numerous primitives in this
+ -- package. This function causes GNATprove to verify that such a copy is
+ -- valid (in particular, it does not break the ownership policy of SPARK,
+ -- i.e. it does not contain pointers that could be used to alias mutable
+ -- data).
+
---------------------------
-- Iteration Primitives --
---------------------------
diff --git a/gcc/ada/libgnat/a-cofuve.adb b/gcc/ada/libgnat/a-cofuve.adb
index 0ff2204..b4f972c 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2016-2021, 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 cfccf1d..ee52730 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2016-2021, 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 --
@@ -336,6 +336,13 @@ package Ada.Containers.Functional_Vectors with SPARK_Mode is
Lst => Last (Remove'Result),
Offset => 1);
+ function Copy_Element (Item : Element_Type) return Element_Type is (Item);
+ -- Elements of containers are copied by numerous primitives in this
+ -- package. This function causes GNATprove to verify that such a copy is
+ -- valid (in particular, it does not break the ownership policy of SPARK,
+ -- i.e. it does not contain pointers that could be used to alias mutable
+ -- data).
+
---------------------------
-- Iteration Primitives --
---------------------------
diff --git a/gcc/ada/libgnat/a-cogeso.adb b/gcc/ada/libgnat/a-cogeso.adb
index 2b6b05e..ebbc118 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2011-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 6457e64..810b93b 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2011-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 9c4e51a..e6d6e4d 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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,6 +116,13 @@ is
-- "=" --
---------
+ function "=" (Left, Right : Cursor) return Boolean is
+ begin
+ return
+ Left.Container = Right.Container
+ and then Left.Node = Right.Node;
+ end "=";
+
function "=" (Left, Right : Map) return Boolean is
begin
return Is_Equal (Left.HT, Right.HT);
@@ -478,7 +485,8 @@ is
return No_Element;
end if;
- return Cursor'(Container'Unrestricted_Access, Node, Hash_Type'Last);
+ return Cursor'
+ (Container'Unrestricted_Access, Node, HT_Ops.Index (HT, Node));
end Find;
--------------------
@@ -635,6 +643,11 @@ is
end if;
Position.Container := Container'Unrestricted_Access;
+
+ -- Note that we do not set the Position component of the cursor,
+ -- because it may become incorrect on subsequent insertions/deletions
+ -- from the container. This will lose some optimizations but prevents
+ -- anomalies when the underlying hash-table is expanded or shrunk.
end Insert;
procedure Insert
@@ -889,7 +902,7 @@ is
---------------
procedure Put_Image
- (S : in out Ada.Strings.Text_Output.Sink'Class; V : Map)
+ (S : in out Ada.Strings.Text_Buffers.Root_Buffer_Type'Class; V : Map)
is
First_Time : Boolean := True;
use System.Put_Images;
diff --git a/gcc/ada/libgnat/a-cohama.ads b/gcc/ada/libgnat/a-cohama.ads
index 21b6935..3f172bd 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2021, 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,7 +36,7 @@ with Ada.Iterator_Interfaces;
private with Ada.Containers.Hash_Tables;
private with Ada.Finalization;
private with Ada.Streams;
-private with Ada.Strings.Text_Output;
+private with Ada.Strings.Text_Buffers;
-- The language-defined generic package Containers.Hashed_Maps provides
-- private types Map and Cursor, and a set of operations for each type. A map
@@ -110,6 +110,14 @@ is
type Cursor is private;
pragma Preelaborable_Initialization (Cursor);
+ function "=" (Left, Right : Cursor) return Boolean;
+ -- The representation of cursors includes a component used to optimize
+ -- iteration over maps. This component may become unreliable after
+ -- multiple map insertions, and must be excluded from cursor equality,
+ -- so we need to provide an explicit definition for it, instead of
+ -- using predefined equality (as implied by a questionable comment
+ -- in the RM).
+
Empty_Map : constant Map;
-- Map objects declared without an initialization expression are
-- initialized to the value Empty_Map.
@@ -431,7 +439,7 @@ private
end record with Put_Image => Put_Image;
procedure Put_Image
- (S : in out Ada.Strings.Text_Output.Sink'Class; V : Map);
+ (S : in out Ada.Strings.Text_Buffers.Root_Buffer_Type'Class; V : Map);
overriding procedure Adjust (Container : in out Map);
@@ -465,7 +473,15 @@ private
Position : Hash_Type := Hash_Type'Last;
-- Position of the node in the buckets of the container. If this is
- -- equal to Hash_Type'Last, then it will not be used.
+ -- equal to Hash_Type'Last, then it will not be used. Position is
+ -- not requried by the implementation, but improves the efficiency
+ -- of various operations.
+ --
+ -- However, this value must be maintained so that the predefined
+ -- equality operation acts as required by RM A.18.4-18/2, which
+ -- states: "The predefined "=" operator for type Cursor returns True
+ -- if both cursors are No_Element, or designate the same element
+ -- in the same container."
end record;
procedure Read
diff --git a/gcc/ada/libgnat/a-cohase.adb b/gcc/ada/libgnat/a-cohase.adb
index 0131f73..2342116 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -145,6 +145,13 @@ is
-- "=" --
---------
+ function "=" (Left, Right : Cursor) return Boolean is
+ begin
+ return
+ Left.Container = Right.Container
+ and then Left.Node = Right.Node;
+ end "=";
+
function "=" (Left, Right : Set) return Boolean is
begin
return Is_Equal (Left.HT, Right.HT);
@@ -605,13 +612,13 @@ is
is
HT : Hash_Table_Type renames Container'Unrestricted_Access.HT;
Node : constant Node_Access := Element_Keys.Find (HT, Item);
-
begin
if Node = null then
return No_Element;
end if;
- return Cursor'(Container'Unrestricted_Access, Node, Hash_Type'Last);
+ return Cursor'
+ (Container'Unrestricted_Access, Node, HT_Ops.Index (HT, Node));
end Find;
--------------------
@@ -766,6 +773,11 @@ is
begin
Insert (Container.HT, New_Item, Position.Node, Inserted);
Position.Container := Container'Unchecked_Access;
+
+ -- Note that we do not set the Position component of the cursor,
+ -- because it may become incorrect on subsequent insertions/deletions
+ -- from the container. This will lose some optimizations but prevents
+ -- anomalies when the underlying hash-table is expanded or shrunk.
end Insert;
procedure Insert
@@ -1168,7 +1180,7 @@ is
---------------
procedure Put_Image
- (S : in out Ada.Strings.Text_Output.Sink'Class; V : Set)
+ (S : in out Ada.Strings.Text_Buffers.Root_Buffer_Type'Class; V : Set)
is
First_Time : Boolean := True;
use System.Put_Images;
@@ -1998,7 +2010,7 @@ is
return No_Element;
else
return Cursor'
- (Container'Unrestricted_Access, Node, Hash_Type'Last);
+ (Container'Unrestricted_Access, Node, HT_Ops.Index (HT, Node));
end if;
end Find;
diff --git a/gcc/ada/libgnat/a-cohase.ads b/gcc/ada/libgnat/a-cohase.ads
index a0aca52..2356ba7 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2021, 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 @@ private with Ada.Containers.Hash_Tables;
with Ada.Containers.Helpers;
private with Ada.Finalization;
private with Ada.Streams;
-private with Ada.Strings.Text_Output;
+private with Ada.Strings.Text_Buffers;
generic
type Element_Type is private;
@@ -69,6 +69,15 @@ is
type Cursor is private;
pragma Preelaborable_Initialization (Cursor);
+ function "=" (Left, Right : Cursor) return Boolean;
+ -- The representation of cursors includes a component used to optimize
+ -- iteration over sets. This component may become unreliable after
+ -- multiple set insertions, and must be excluded from cursor equality,
+ -- so we need to provide an explicit definition for it, instead of
+ -- using predefined equality (as implied by a questionable comment
+ -- in the RM). This is also the case for hashed maps, and affects the
+ -- use of Insert primitives in hashed structures.
+
Empty_Set : constant Set;
-- Set objects declared without an initialization expression are
-- initialized to the value Empty_Set.
@@ -510,7 +519,7 @@ private
end record with Put_Image => Put_Image;
procedure Put_Image
- (S : in out Ada.Strings.Text_Output.Sink'Class; V : Set);
+ (S : in out Ada.Strings.Text_Buffers.Root_Buffer_Type'Class; V : Set);
overriding procedure Adjust (Container : in out Set);
@@ -537,8 +546,22 @@ private
type Cursor is record
Container : Set_Access;
+ -- Access to this cursor's container
+
Node : Node_Access;
+ -- Access to the node pointed to by this cursor
+
Position : Hash_Type := Hash_Type'Last;
+ -- Position of the node in the buckets of the container. If this is
+ -- equal to Hash_Type'Last, then it will not be used. Position is
+ -- not requried by the implementation, but improves the efficiency
+ -- of various operations.
+ --
+ -- However, this value must be maintained so that the predefined
+ -- equality operation acts as required by RM A.18.7-17/2, which
+ -- states: "The predefined "=" operator for type Cursor returns True
+ -- if both cursors are No_Element, or designate the same element
+ -- in the same container."
end record;
procedure Write
diff --git a/gcc/ada/libgnat/a-cohata.ads b/gcc/ada/libgnat/a-cohata.ads
index 2b98928..f7e44a3 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 6c99c8d..ca6882a 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2012-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -235,7 +235,7 @@ package body Ada.Containers.Indefinite_Holders is
---------------
procedure Put_Image
- (S : in out Ada.Strings.Text_Output.Sink'Class; V : Holder)
+ (S : in out Ada.Strings.Text_Buffers.Root_Buffer_Type'Class; V : Holder)
is
use System.Put_Images;
begin
diff --git a/gcc/ada/libgnat/a-coinho.ads b/gcc/ada/libgnat/a-coinho.ads
index 372f069..b648836 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2011-2021, 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 --
@@ -31,7 +31,7 @@
private with Ada.Finalization;
private with Ada.Streams;
-private with Ada.Strings.Text_Output;
+private with Ada.Strings.Text_Buffers;
generic
type Element_Type (<>) is private;
@@ -119,7 +119,7 @@ private
end record with Put_Image => Put_Image;
procedure Put_Image
- (S : in out Ada.Strings.Text_Output.Sink'Class; V : Holder);
+ (S : in out Ada.Strings.Text_Buffers.Root_Buffer_Type'Class; V : Holder);
for Holder'Read use Read;
for Holder'Write use Write;
diff --git a/gcc/ada/libgnat/a-coinho__shared.adb b/gcc/ada/libgnat/a-coinho__shared.adb
index 16bb708..0340af0 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2013-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -325,7 +325,7 @@ package body Ada.Containers.Indefinite_Holders is
---------------
procedure Put_Image
- (S : in out Ada.Strings.Text_Output.Sink'Class; V : Holder)
+ (S : in out Ada.Strings.Text_Buffers.Root_Buffer_Type'Class; V : Holder)
is
use System.Put_Images;
begin
diff --git a/gcc/ada/libgnat/a-coinho__shared.ads b/gcc/ada/libgnat/a-coinho__shared.ads
index e7bea85..97f796d 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2013-2021, 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,7 +36,7 @@ private with Ada.Finalization;
private with Ada.Streams;
private with System.Atomic_Counters;
-private with Ada.Strings.Text_Output;
+private with Ada.Strings.Text_Buffers;
generic
type Element_Type (<>) is private;
@@ -134,7 +134,7 @@ private
end record with Put_Image => Put_Image;
procedure Put_Image
- (S : in out Ada.Strings.Text_Output.Sink'Class; V : Holder);
+ (S : in out Ada.Strings.Text_Buffers.Root_Buffer_Type'Class; V : Holder);
for Holder'Read use Read;
for Holder'Write use Write;
diff --git a/gcc/ada/libgnat/a-coinve.adb b/gcc/ada/libgnat/a-coinve.adb
index 051aa71..9df6e3d 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -2670,7 +2670,7 @@ is
---------------
procedure Put_Image
- (S : in out Ada.Strings.Text_Output.Sink'Class; V : Vector)
+ (S : in out Ada.Strings.Text_Buffers.Root_Buffer_Type'Class; V : Vector)
is
First_Time : Boolean := True;
use System.Put_Images;
diff --git a/gcc/ada/libgnat/a-coinve.ads b/gcc/ada/libgnat/a-coinve.ads
index c9364c7..828ed29 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2021, 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,7 +36,7 @@ with Ada.Iterator_Interfaces;
with Ada.Containers.Helpers;
private with Ada.Finalization;
private with Ada.Streams;
-private with Ada.Strings.Text_Output;
+private with Ada.Strings.Text_Buffers;
generic
type Index_Type is range <>;
@@ -428,7 +428,7 @@ private
end record with Put_Image => Put_Image;
procedure Put_Image
- (S : in out Ada.Strings.Text_Output.Sink'Class; V : Vector);
+ (S : in out Ada.Strings.Text_Buffers.Root_Buffer_Type'Class; V : Vector);
overriding procedure Adjust (Container : in out Vector);
overriding procedure Finalize (Container : in out Vector);
diff --git a/gcc/ada/libgnat/a-colien.adb b/gcc/ada/libgnat/a-colien.adb
index 9ea536d..b189505 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1996-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 cdcb842..0c20486 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1996-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 c341773..e39d002 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1999-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 975c0db..c1d79b8 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1999-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 e6e6174..171b061 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 8dbbb07..d8149cf 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, 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 78f93f0..617d248 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -1864,7 +1864,7 @@ is
---------------
procedure Put_Image
- (S : in out Ada.Strings.Text_Output.Sink'Class; V : Tree)
+ (S : in out Ada.Strings.Text_Buffers.Root_Buffer_Type'Class; V : Tree)
is
use System.Put_Images;
diff --git a/gcc/ada/libgnat/a-comutr.ads b/gcc/ada/libgnat/a-comutr.ads
index a1f51af..8e88b14 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2021, 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,7 +36,7 @@ with Ada.Iterator_Interfaces;
with Ada.Containers.Helpers;
private with Ada.Finalization;
private with Ada.Streams;
-private with Ada.Strings.Text_Output;
+private with Ada.Strings.Text_Buffers;
generic
type Element_Type is private;
@@ -404,7 +404,7 @@ private
end record with Put_Image => Put_Image;
procedure Put_Image
- (S : in out Ada.Strings.Text_Output.Sink'Class; V : Tree);
+ (S : in out Ada.Strings.Text_Buffers.Root_Buffer_Type'Class; V : Tree);
overriding procedure Adjust (Container : in out Tree);
diff --git a/gcc/ada/libgnat/a-conhel.adb b/gcc/ada/libgnat/a-conhel.adb
index 1a30b53..316c866 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2015-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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,13 @@
package body Ada.Containers.Helpers is
+ Max_Count : constant := 2**31 - 1;
+ -- Used in assertions below, to make sure the counts don't wrap around.
+ -- This can help detect bugs in which Adjust and Finalize calls are
+ -- improperly generated. An extra Decrement could otherwise cause
+ -- wraparound from 0 to 2**32-1. The highest count seen so far is
+ -- around 25, so this should be plenty.
+
package body Generic_Implementation is
use type SAC.Atomic_Unsigned;
@@ -50,6 +57,7 @@ package body Ada.Containers.Helpers is
begin
if T_Check then
SAC.Increment (T_Counts.Busy);
+ pragma Assert (T_Counts.Busy <= Max_Count);
end if;
end Busy;
@@ -112,7 +120,9 @@ package body Ada.Containers.Helpers is
begin
if T_Check then
SAC.Increment (T_Counts.Lock);
+ pragma Assert (T_Counts.Lock <= Max_Count);
SAC.Increment (T_Counts.Busy);
+ pragma Assert (T_Counts.Busy <= Max_Count);
end if;
end Lock;
@@ -122,17 +132,20 @@ package body Ada.Containers.Helpers is
procedure TC_Check (T_Counts : Tamper_Counts) is
begin
- if T_Check and then T_Counts.Busy > 0 then
- raise Program_Error with
- "attempt to tamper with cursors";
+ if T_Check then
+ if T_Counts.Busy > 0 then
+ raise Program_Error with
+ "attempt to tamper with cursors";
+ end if;
+
+ -- The lock status (which monitors "element tampering") always
+ -- implies that the busy status (which monitors "cursor
+ -- tampering") is set too; this is a representation invariant.
+ -- Thus if the busy count is zero, then the lock count
+ -- must also be zero.
+
+ pragma Assert (T_Counts.Lock = 0);
end if;
-
- -- The lock status (which monitors "element tampering") always
- -- implies that the busy status (which monitors "cursor tampering")
- -- is set too; this is a representation invariant. Thus if the busy
- -- bit is not set, then the lock bit must not be set either.
-
- pragma Assert (T_Counts.Lock = 0);
end TC_Check;
--------------
@@ -155,6 +168,7 @@ package body Ada.Containers.Helpers is
begin
if T_Check then
SAC.Decrement (T_Counts.Busy);
+ pragma Assert (T_Counts.Busy <= Max_Count);
end if;
end Unbusy;
@@ -166,7 +180,9 @@ package body Ada.Containers.Helpers is
begin
if T_Check then
SAC.Decrement (T_Counts.Lock);
+ pragma Assert (T_Counts.Lock <= Max_Count);
SAC.Decrement (T_Counts.Busy);
+ pragma Assert (T_Counts.Busy <= Max_Count);
end if;
end Unlock;
diff --git a/gcc/ada/libgnat/a-conhel.ads b/gcc/ada/libgnat/a-conhel.ads
index 80ae980..47cb2ce 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2015-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 fec72cc..5cede72 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -2345,7 +2345,7 @@ is
---------------
procedure Put_Image
- (S : in out Ada.Strings.Text_Output.Sink'Class; V : Vector)
+ (S : in out Ada.Strings.Text_Buffers.Root_Buffer_Type'Class; V : Vector)
is
First_Time : Boolean := True;
use System.Put_Images;
diff --git a/gcc/ada/libgnat/a-convec.ads b/gcc/ada/libgnat/a-convec.ads
index 1d257a0..41eafbc 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2021, 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,7 +36,7 @@ with Ada.Iterator_Interfaces;
with Ada.Containers.Helpers;
private with Ada.Finalization;
private with Ada.Streams;
-private with Ada.Strings.Text_Output;
+private with Ada.Strings.Text_Buffers;
-- The language-defined generic package Containers.Vectors provides private
-- types Vector and Cursor, and a set of operations for each type. A vector
@@ -332,7 +332,7 @@ is
function New_Vector (First, Last : Index_Type) return Vector
with Pre => First = Index_Type'First;
- -- Ada_2020 aggregate operation.
+ -- Ada 2022 aggregate operation.
procedure Insert_Vector
(Container : in out Vector;
@@ -745,7 +745,7 @@ private
end record with Put_Image => Put_Image;
procedure Put_Image
- (S : in out Ada.Strings.Text_Output.Sink'Class; V : Vector);
+ (S : in out Ada.Strings.Text_Buffers.Root_Buffer_Type'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 15d08f5..65adf4c 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -1220,7 +1220,7 @@ is
---------------
procedure Put_Image
- (S : in out Ada.Strings.Text_Output.Sink'Class; V : Map)
+ (S : in out Ada.Strings.Text_Buffers.Root_Buffer_Type'Class; V : Map)
is
First_Time : Boolean := True;
use System.Put_Images;
diff --git a/gcc/ada/libgnat/a-coorma.ads b/gcc/ada/libgnat/a-coorma.ads
index 7f65a7f..5de65c1 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2021, 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,7 +36,7 @@ with Ada.Iterator_Interfaces;
private with Ada.Containers.Red_Black_Trees;
private with Ada.Finalization;
private with Ada.Streams;
-private with Ada.Strings.Text_Output;
+private with Ada.Strings.Text_Buffers;
generic
type Key_Type is private;
@@ -61,12 +61,15 @@ is
Iterator_Element => Element_Type,
Aggregate => (Empty => Empty,
Add_Named => Insert);
+ pragma Preelaborable_Initialization (Map);
type Cursor is private;
pragma Preelaborable_Initialization (Cursor);
Empty_Map : constant Map;
+
function Empty return Map;
+ pragma Ada_2022 (Empty);
No_Element : constant Cursor;
@@ -264,7 +267,7 @@ private
end record with Put_Image => Put_Image;
procedure Put_Image
- (S : in out Ada.Strings.Text_Output.Sink'Class; V : Map);
+ (S : in out Ada.Strings.Text_Buffers.Root_Buffer_Type'Class; V : Map);
overriding procedure Adjust (Container : in out Map);
diff --git a/gcc/ada/libgnat/a-coormu.adb b/gcc/ada/libgnat/a-coormu.adb
index c7db472..9b11d29 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -1571,7 +1571,7 @@ is
---------------
procedure Put_Image
- (S : in out Ada.Strings.Text_Output.Sink'Class; V : Set)
+ (S : in out Ada.Strings.Text_Buffers.Root_Buffer_Type'Class; V : Set)
is
First_Time : Boolean := True;
use System.Put_Images;
diff --git a/gcc/ada/libgnat/a-coormu.ads b/gcc/ada/libgnat/a-coormu.ads
index 95aec73..51b94eb 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -34,7 +34,7 @@
private with Ada.Containers.Red_Black_Trees;
private with Ada.Finalization;
private with Ada.Streams;
-private with Ada.Strings.Text_Output;
+private with Ada.Strings.Text_Buffers;
with Ada.Iterator_Interfaces;
generic
@@ -476,7 +476,7 @@ private
end record with Put_Image => Put_Image;
procedure Put_Image
- (S : in out Ada.Strings.Text_Output.Sink'Class; V : Set);
+ (S : in out Ada.Strings.Text_Buffers.Root_Buffer_Type'Class; V : Set);
overriding procedure Adjust (Container : in out Set);
diff --git a/gcc/ada/libgnat/a-coorse.adb b/gcc/ada/libgnat/a-coorse.adb
index 8a648e8..ca8f238 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -1586,7 +1586,7 @@ is
---------------
procedure Put_Image
- (S : in out Ada.Strings.Text_Output.Sink'Class; V : Set)
+ (S : in out Ada.Strings.Text_Buffers.Root_Buffer_Type'Class; V : Set)
is
First_Time : Boolean := True;
use System.Put_Images;
diff --git a/gcc/ada/libgnat/a-coorse.ads b/gcc/ada/libgnat/a-coorse.ads
index 1ccf290..6d24e03 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2021, 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 Ada.Containers.Helpers;
private with Ada.Containers.Red_Black_Trees;
private with Ada.Finalization;
private with Ada.Streams;
-private with Ada.Strings.Text_Output;
+private with Ada.Strings.Text_Buffers;
generic
type Element_Type is private;
@@ -347,7 +347,7 @@ private
end record with Put_Image => Put_Image;
procedure Put_Image
- (S : in out Ada.Strings.Text_Output.Sink'Class; V : Set);
+ (S : in out Ada.Strings.Text_Buffers.Root_Buffer_Type'Class; V : Set);
overriding procedure Adjust (Container : in out Set);
diff --git a/gcc/ada/libgnat/a-coprnu.adb b/gcc/ada/libgnat/a-coprnu.adb
index 25f04e6..20837d4 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 5afb474..7f5f7bd 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 4f00bd6..7f5028d 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 a41fcbb..8af0923 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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.ads b/gcc/ada/libgnat/a-crbtgk.ads
index 4bdcf5c..a7c597c 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 35727b0..467b1b7 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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.ads b/gcc/ada/libgnat/a-crbtgo.ads
index 5f37221..00e5a6d 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 fb92fd4..6538b26 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 b30d353..ea693c3 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 df65ba4..95e334e 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2011-2021, 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 deae9a7..d0a4e64 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2011-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 a70e5e0..4367fe6 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2011-2021, 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 295711c..85a0747 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2011-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 cd2af82..407359d 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2011-2021, 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 fc28f17..830fb47 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 8f44c5b..5545c14 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 bf05516..9afe287 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 9b56cc6..7ccd9f0 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, 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-decima__128.ads b/gcc/ada/libgnat/a-decima__128.ads
index b29b010..aa87ccf 100644
--- a/gcc/ada/libgnat/a-decima__128.ads
+++ b/gcc/ada/libgnat/a-decima__128.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2020-2021, 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 e0ae41f..4f0f033 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 cf8697e..d760251 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 83dc30a..f3e08fe 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 a6507c1..6454c91 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 162ace9..20616a2 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 05cb2b6..12f3bd4 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2021, 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 48e4f74..f83b34b 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 a293156..0a91174 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, 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 38e56c9..bdb8faf 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 0485802..8c6cd0a 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 27d09ef..51827a5 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 bc9211a..1c409da 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2000-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 5d1e264..cb70ab1 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2000-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 244352d..d54aa65 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2003-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 5aa7fe2..15696bf 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2003-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 25097d6..69f5cc2 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2003-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 0d6e2ed..cf11887 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2009-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 f9d6ee0..3939287 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 f7fd5bb..c332afa 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -279,6 +279,23 @@ package body Ada.Exceptions is
pragma No_Return (Raise_Exception_No_Defer);
-- Similar to Raise_Exception, but with no abort deferral
+ procedure Raise_From_Signal_Handler
+ (E : Exception_Id;
+ M : System.Address);
+ pragma Export
+ (C, Raise_From_Signal_Handler, "__gnat_raise_from_signal_handler");
+ pragma No_Return (Raise_From_Signal_Handler);
+ -- This routine is used to raise an exception from a signal handler. The
+ -- signal handler has already stored the machine state (i.e. the state that
+ -- corresponds to the location at which the signal was raised). E is the
+ -- Exception_Id specifying what exception is being raised, and M is a
+ -- pointer to a null-terminated string which is the message to be raised.
+ -- Note that this routine never returns, so it is permissible to simply
+ -- jump to this routine, rather than call it. This may be appropriate for
+ -- systems where the right way to get out of signal handler is to alter the
+ -- PC value in the machine state or in some other way ask the operating
+ -- system to return here rather than to the original location.
+
procedure Raise_With_Msg (E : Exception_Id);
pragma No_Return (Raise_With_Msg);
pragma Export (C, Raise_With_Msg, "__gnat_raise_with_msg");
diff --git a/gcc/ada/libgnat/a-except.ads b/gcc/ada/libgnat/a-except.ads
index 4d36a84..2b27adb 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, 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 --
@@ -184,26 +184,7 @@ private
-- Raise_Exception_Always if it can determine this is the case. The Export
-- allows this routine to be accessed from Pure units.
- procedure Raise_From_Signal_Handler
- (E : Exception_Id;
- M : System.Address);
- pragma Export
- (Ada, Raise_From_Signal_Handler,
- "ada__exceptions__raise_from_signal_handler");
- pragma No_Return (Raise_From_Signal_Handler);
- -- This routine is used to raise an exception from a signal handler. The
- -- signal handler has already stored the machine state (i.e. the state that
- -- corresponds to the location at which the signal was raised). E is the
- -- Exception_Id specifying what exception is being raised, and M is a
- -- pointer to a null-terminated string which is the message to be raised.
- -- Note that this routine never returns, so it is permissible to simply
- -- jump to this routine, rather than call it. This may be appropriate for
- -- systems where the right way to get out of signal handler is to alter the
- -- PC value in the machine state or in some other way ask the operating
- -- system to return here rather than to the original location.
-
- procedure Raise_From_Controlled_Operation
- (X : Ada.Exceptions.Exception_Occurrence);
+ procedure Raise_From_Controlled_Operation (X : Exception_Occurrence);
pragma No_Return (Raise_From_Controlled_Operation);
pragma Export
(Ada, Raise_From_Controlled_Operation,
diff --git a/gcc/ada/libgnat/a-exctra.adb b/gcc/ada/libgnat/a-exctra.adb
index 450af8b..67c85ae 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1999-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 ba90f52..84c2f20 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1999-2021, 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 31831b6..f5cb37e 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 fb4b545..ff85bc5 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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,6 +91,9 @@ package body Exception_Propagation is
use Exception_Traces;
+ type bool is new Boolean;
+ pragma Convention (C, bool);
+
Foreign_Exception : aliased System.Standard_Library.Exception_Data;
pragma Import (Ada, Foreign_Exception,
"system__exceptions__foreign_exception");
@@ -277,9 +280,8 @@ package body Exception_Propagation is
-- painful and error prone. These subprograms could be moved to a more
-- widely visible location if need be.
- function Is_Handled_By_Others (E : Exception_Data_Ptr) return Boolean;
+ function Is_Handled_By_Others (E : Exception_Data_Ptr) return bool;
pragma Export (C, Is_Handled_By_Others, "__gnat_is_handled_by_others");
- pragma Warnings (Off, Is_Handled_By_Others);
function Language_For (E : Exception_Data_Ptr) return Character;
pragma Export (C, Language_For, "__gnat_language_for");
@@ -685,9 +687,7 @@ package body Exception_Propagation is
-- Foreign_Data_For --
----------------------
- function Foreign_Data_For
- (E : SSL.Exception_Data_Ptr) return Address
- is
+ function Foreign_Data_For (E : Exception_Data_Ptr) return Address is
begin
return E.Foreign_Data;
end Foreign_Data_For;
@@ -696,16 +696,16 @@ package body Exception_Propagation is
-- Is_Handled_By_Others --
--------------------------
- function Is_Handled_By_Others (E : SSL.Exception_Data_Ptr) return Boolean is
+ function Is_Handled_By_Others (E : Exception_Data_Ptr) return bool is
begin
- return not E.all.Not_Handled_By_Others;
+ return not bool (E.all.Not_Handled_By_Others);
end Is_Handled_By_Others;
------------------
-- Language_For --
------------------
- function Language_For (E : SSL.Exception_Data_Ptr) return Character is
+ function Language_For (E : Exception_Data_Ptr) return Character is
begin
return E.all.Lang;
end Language_For;
diff --git a/gcc/ada/libgnat/a-exextr.adb b/gcc/ada/libgnat/a-exextr.adb
index da66873..9ef7e86 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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-exstat.adb b/gcc/ada/libgnat/a-exstat.adb
index 028be1f..adb199a 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 ba8b7b3..4bba140 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 2ee4cf8..ce124e3 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, 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-iteint.ads b/gcc/ada/libgnat/a-iteint.ads
index 8ac9e1a..953853f 100644
--- a/gcc/ada/libgnat/a-iteint.ads
+++ b/gcc/ada/libgnat/a-iteint.ads
@@ -21,7 +21,7 @@ generic
package Ada.Iterator_Interfaces is
pragma Pure;
- type Forward_Iterator is limited interface;
+ type Forward_Iterator is limited interface with No_Task_Parts;
function First
(Object : Forward_Iterator) return Cursor is abstract;
@@ -29,7 +29,8 @@ package Ada.Iterator_Interfaces is
(Object : Forward_Iterator;
Position : Cursor) return Cursor is abstract;
- type Reversible_Iterator is limited interface and Forward_Iterator;
+ type Reversible_Iterator is limited interface and Forward_Iterator with
+ No_Task_Parts;
function Last
(Object : Reversible_Iterator) return Cursor is abstract;
diff --git a/gcc/ada/libgnat/a-locale.adb b/gcc/ada/libgnat/a-locale.adb
index ec65938..71e8557 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2010-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 be6b0c2..334e1f1 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2010-2021, 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-nagefl.ads b/gcc/ada/libgnat/a-nagefl.ads
index 9260391..25875fa 100644
--- a/gcc/ada/libgnat/a-nagefl.ads
+++ b/gcc/ada/libgnat/a-nagefl.ads
@@ -7,7 +7,7 @@
-- S p e c --
-- (Generic Wrapper) --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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-naliop.ads b/gcc/ada/libgnat/a-naliop.ads
index 81de811..d5f2ecb 100644
--- a/gcc/ada/libgnat/a-naliop.ads
+++ b/gcc/ada/libgnat/a-naliop.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2001-2020, AdaCore --
+-- Copyright (C) 2001-2021, 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/a-naliop__nolibm.ads b/gcc/ada/libgnat/a-naliop__nolibm.ads
index dc1969a..6482e88 100644
--- a/gcc/ada/libgnat/a-naliop__nolibm.ads
+++ b/gcc/ada/libgnat/a-naliop__nolibm.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2001-2020, AdaCore --
+-- Copyright (C) 2001-2021, 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/a-nallfl.ads b/gcc/ada/libgnat/a-nallfl.ads
index ca998fa..ef52992 100644
--- a/gcc/ada/libgnat/a-nallfl.ads
+++ b/gcc/ada/libgnat/a-nallfl.ads
@@ -7,7 +7,7 @@
-- S p e c --
-- (C Math Library Version, Long Long Float) --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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-nallfl__wraplf.ads b/gcc/ada/libgnat/a-nallfl__wraplf.ads
index 2d5c71d..582821e 100644
--- a/gcc/ada/libgnat/a-nallfl__wraplf.ads
+++ b/gcc/ada/libgnat/a-nallfl__wraplf.ads
@@ -7,7 +7,7 @@
-- S p e c --
-- (Long Long Float Wrapper in terms of Long Float) --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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-nalofl.ads b/gcc/ada/libgnat/a-nalofl.ads
index 4cdf2f4..519bf1c 100644
--- a/gcc/ada/libgnat/a-nalofl.ads
+++ b/gcc/ada/libgnat/a-nalofl.ads
@@ -7,7 +7,7 @@
-- S p e c --
-- (C Math Library Version, Long Float) --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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-nashfl.ads b/gcc/ada/libgnat/a-nashfl.ads
index eaee862..6bb660d 100644
--- a/gcc/ada/libgnat/a-nashfl.ads
+++ b/gcc/ada/libgnat/a-nashfl.ads
@@ -7,7 +7,7 @@
-- S p e c --
-- (Short Float Wrapper in terms of Float) --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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-nashfl__wraplf.ads b/gcc/ada/libgnat/a-nashfl__wraplf.ads
index ca5b48d..a6ffe3d 100644
--- a/gcc/ada/libgnat/a-nashfl__wraplf.ads
+++ b/gcc/ada/libgnat/a-nashfl__wraplf.ads
@@ -7,7 +7,7 @@
-- S p e c --
-- (Short Float Wrapper in terms of Long Float) --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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-nbnbin.adb b/gcc/ada/libgnat/a-nbnbin.adb
index 9e051d3..fe41cf1 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2019-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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 Ada.Unchecked_Deallocation;
-with Ada.Strings.Text_Output.Utils;
with Interfaces; use Interfaces;
@@ -432,12 +431,12 @@ package body Ada.Numerics.Big_Numbers.Big_Integers is
-- Put_Image --
---------------
- procedure Put_Image (S : in out Sink'Class; V : Big_Integer) is
+ procedure Put_Image (S : in out Root_Buffer_Type'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
- Strings.Text_Output.Utils.Put_UTF_8 (S, To_String (V));
+ Strings.Text_Buffers.Put_UTF_8 (S, To_String (V));
end Put_Image;
---------
diff --git a/gcc/ada/libgnat/a-nbnbin.ads b/gcc/ada/libgnat/a-nbnbin.ads
index 668da8d..1ba10da 100644
--- a/gcc/ada/libgnat/a-nbnbin.ads
+++ b/gcc/ada/libgnat/a-nbnbin.ads
@@ -13,7 +13,7 @@
-- --
------------------------------------------------------------------------------
-with Ada.Strings.Text_Output; use Ada.Strings.Text_Output;
+with Ada.Strings.Text_Buffers; use Ada.Strings.Text_Buffers;
private with Ada.Finalization;
private with System;
@@ -22,7 +22,7 @@ package Ada.Numerics.Big_Numbers.Big_Integers
with Preelaborate
is
type Big_Integer is private
- with Integer_Literal => From_String,
+ with Integer_Literal => From_Universal_Image,
Put_Image => Put_Image;
function Is_Valid (Arg : Big_Integer) return Boolean
@@ -116,7 +116,10 @@ is
function From_String (Arg : String) return Valid_Big_Integer
with Global => null;
- procedure Put_Image (S : in out Sink'Class; V : Big_Integer);
+ function From_Universal_Image (Arg : String) return Valid_Big_Integer
+ renames From_String;
+
+ procedure Put_Image (S : in out Root_Buffer_Type'Class; V : Big_Integer);
function "+" (L : Valid_Big_Integer) return Valid_Big_Integer
with Global => null;
diff --git a/gcc/ada/libgnat/a-nbnbin__gmp.adb b/gcc/ada/libgnat/a-nbnbin__gmp.adb
index 2e8a260..880e9a3 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2019-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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,6 @@ with Ada.Unchecked_Conversion;
with Ada.Unchecked_Deallocation;
with Interfaces.C; use Interfaces.C;
with Interfaces.C.Strings; use Interfaces.C.Strings;
-with Ada.Strings.Text_Output.Utils;
with Ada.Characters.Handling; use Ada.Characters.Handling;
package body Ada.Numerics.Big_Numbers.Big_Integers is
@@ -403,12 +402,12 @@ package body Ada.Numerics.Big_Numbers.Big_Integers is
-- Put_Image --
---------------
- procedure Put_Image (S : in out Sink'Class; V : Big_Integer) is
+ procedure Put_Image (S : in out Root_Buffer_Type'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
- Strings.Text_Output.Utils.Put_UTF_8 (S, To_String (V));
+ Strings.Text_Buffers.Put_UTF_8 (S, To_String (V));
end Put_Image;
---------
diff --git a/gcc/ada/libgnat/a-nbnbre.adb b/gcc/ada/libgnat/a-nbnbre.adb
index 4ff5b35..e45bc6d 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2019-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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.Strings.Text_Output.Utils;
with System.Unsigned_Types; use System.Unsigned_Types;
package body Ada.Numerics.Big_Numbers.Big_Reals is
@@ -307,7 +306,7 @@ package body Ada.Numerics.Big_Numbers.Big_Reals is
package body Fixed_Conversions is
- package Float_Aux is new Float_Conversions (Long_Long_Float);
+ package Float_Aux is new Float_Conversions (Long_Float);
subtype LLLI is Long_Long_Long_Integer;
subtype LLLU is Long_Long_Long_Unsigned;
@@ -316,7 +315,7 @@ package body Ada.Numerics.Big_Numbers.Big_Reals is
Num'Small_Numerator > LLLU'Last
or else Num'Small_Denominator > LLLU'Last;
-- True if the Small is too large for Long_Long_Long_Unsigned, in which
- -- case we convert to/from Long_Long_Float as an intermediate step.
+ -- case we convert to/from Long_Float as an intermediate step.
package Conv_I is new Big_Integers.Signed_Conversions (LLLI);
package Conv_U is new Big_Integers.Unsigned_Conversions (LLLU);
@@ -334,7 +333,7 @@ package body Ada.Numerics.Big_Numbers.Big_Reals is
begin
if Too_Large then
- return Float_Aux.To_Big_Real (Long_Long_Float (Arg));
+ return Float_Aux.To_Big_Real (Long_Float (Arg));
end if;
N := Conv_U.To_Big_Integer (Num'Small_Numerator);
@@ -593,13 +592,6 @@ package body Ada.Numerics.Big_Numbers.Big_Reals is
end;
end From_String;
- function From_String
- (Numerator, Denominator : String) return Valid_Big_Real is
- begin
- return Big_Integers.From_String (Numerator) /
- Big_Integers.From_String (Denominator);
- end From_String;
-
--------------------------
-- From_Quotient_String --
--------------------------
@@ -626,12 +618,12 @@ package body Ada.Numerics.Big_Numbers.Big_Reals is
-- Put_Image --
---------------
- procedure Put_Image (S : in out Sink'Class; V : Big_Real) is
+ procedure Put_Image (S : in out Root_Buffer_Type'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
- Strings.Text_Output.Utils.Put_UTF_8 (S, To_String (V));
+ Strings.Text_Buffers.Put_UTF_8 (S, To_String (V));
end Put_Image;
---------
diff --git a/gcc/ada/libgnat/a-nbnbre.ads b/gcc/ada/libgnat/a-nbnbre.ads
index ee5636f..4118d2b 100644
--- a/gcc/ada/libgnat/a-nbnbre.ads
+++ b/gcc/ada/libgnat/a-nbnbre.ads
@@ -15,13 +15,13 @@
with Ada.Numerics.Big_Numbers.Big_Integers;
-with Ada.Strings.Text_Output; use Ada.Strings.Text_Output;
+with Ada.Strings.Text_Buffers; use Ada.Strings.Text_Buffers;
package Ada.Numerics.Big_Numbers.Big_Reals
with Preelaborate
is
type Big_Real is private with
- Real_Literal => From_String,
+ Real_Literal => From_Universal_Image,
Put_Image => Put_Image;
function Is_Valid (Arg : Big_Real) return Boolean
@@ -122,8 +122,13 @@ is
function From_String (Arg : String) return Valid_Big_Real
with Global => null;
- function From_String (Numerator, Denominator : String) return Valid_Big_Real
- with Global => null;
+
+ function From_Universal_Image (Arg : String) return Valid_Big_Real
+ renames From_String;
+ function From_Universal_Image (Num, Den : String) return Valid_Big_Real is
+ (Big_Integers.From_Universal_Image (Num) /
+ Big_Integers.From_Universal_Image (Den))
+ with Global => null;
function To_Quotient_String (Arg : Big_Real) return String is
(Big_Integers.To_String (Numerator (Arg)) & " / "
@@ -133,7 +138,7 @@ is
function From_Quotient_String (Arg : String) return Valid_Big_Real
with Global => null;
- procedure Put_Image (S : in out Sink'Class; V : Big_Real);
+ procedure Put_Image (S : in out Root_Buffer_Type'Class; V : Big_Real);
function "+" (L : Valid_Big_Real) return Valid_Big_Real
with Global => null;
diff --git a/gcc/ada/libgnat/a-ngcefu.adb b/gcc/ada/libgnat/a-ngcefu.adb
index d47a14f..50abfb2 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 3a7cede..ed9be6a 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2006-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 b369dfc..d9a88e8 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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.ads b/gcc/ada/libgnat/a-ngcoty.ads
index a5534cd..71a6123 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, 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 3f7c3d1..d9de09c 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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-ngelfu.ads b/gcc/ada/libgnat/a-ngelfu.ads
index 70f9b7a..523e64f 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2012-2021, 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 --
@@ -126,7 +126,7 @@ is
Pre => Cycle > 0.0
and then X /= 0.0
and then Float_Type'Base'Remainder (X, Cycle) /= 0.0
- and then abs Float_Type'Base'Remainder (X, Cycle) = 0.5 * Cycle;
+ and then abs Float_Type'Base'Remainder (X, Cycle) /= 0.5 * Cycle;
function Arcsin (X : Float_Type'Base) return Float_Type'Base with
Pre => abs X <= 1.0,
diff --git a/gcc/ada/libgnat/a-ngrear.adb b/gcc/ada/libgnat/a-ngrear.adb
index 1115cd3..820e6f7 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2006-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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-ngrear.ads b/gcc/ada/libgnat/a-ngrear.ads
index 748d6b7..6e3f854 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2009-2021, 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-nuauco.ads b/gcc/ada/libgnat/a-nuauco.ads
index 7fd49a8..164d4b8 100644
--- a/gcc/ada/libgnat/a-nuauco.ads
+++ b/gcc/ada/libgnat/a-nuauco.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2001-2020, AdaCore --
+-- Copyright (C) 2001-2021, 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/a-nuauco__x86.ads b/gcc/ada/libgnat/a-nuauco__x86.ads
index f1fbb31..7901782 100644
--- a/gcc/ada/libgnat/a-nuauco__x86.ads
+++ b/gcc/ada/libgnat/a-nuauco__x86.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2001-2020, AdaCore --
+-- Copyright (C) 2001-2021, 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/a-nuaufl.ads b/gcc/ada/libgnat/a-nuaufl.ads
index 16a34ae..1c19912 100644
--- a/gcc/ada/libgnat/a-nuaufl.ads
+++ b/gcc/ada/libgnat/a-nuaufl.ads
@@ -7,7 +7,7 @@
-- S p e c --
-- (C Math Library Version, Float) --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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-nuaufl__wraplf.ads b/gcc/ada/libgnat/a-nuaufl__wraplf.ads
index b6eb22c..3318a10 100644
--- a/gcc/ada/libgnat/a-nuaufl__wraplf.ads
+++ b/gcc/ada/libgnat/a-nuaufl__wraplf.ads
@@ -7,7 +7,7 @@
-- S p e c --
-- (Double-based Version, Float) --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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-nudira.adb b/gcc/ada/libgnat/a-nudira.adb
index e18403c..dff1013 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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-nudira.ads b/gcc/ada/libgnat/a-nudira.ads
index 35b7dc6..9496043 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, 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-nuflra.adb b/gcc/ada/libgnat/a-nuflra.adb
index 8621006..1ec38ac 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 ff7ab88..350faeb 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, 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 42ed336..de952a8 100644
--- a/gcc/ada/libgnat/a-numaux.ads
+++ b/gcc/ada/libgnat/a-numaux.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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.adb b/gcc/ada/libgnat/a-rbtgbk.adb
index 40a792f..1c0d5d8 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 22f6c22..cd18fdc 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 a2775ea..f92191e 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 968c2f2..4d2c655 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 fcb254d..22f5603 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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.ads b/gcc/ada/libgnat/a-rbtgso.ads
index e6eeb33..1e80ed5 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 d9bef56..ebbdc7f 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2011-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 9144e9e..6061e9e 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2011-2021, 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 5062756..f2994f9 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2011-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 ec1d97c..d067b61 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2011-2021, 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 c21050d..14b3b4c 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2011-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 8915631..e9f5f20 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2011-2021, 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 6c042f1..bf80383 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 3e77231..e376660 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 0b5aa61..99e5e59 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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.ads b/gcc/ada/libgnat/a-sequio.ads
index dcaa3f0..34d3b25 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, 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 0c1b0a7..c476d78 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2011-2021, 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 8da6f43..0d253a0 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2011-2021, 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 8fb7ac1..712ed2f 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2011-2021, 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 35a346e..9432a07 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 4d2975c..8ba2551 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 5501486..e830621 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 3a37f7bb..88713b9 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 732e103..141757b 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 8efa651..a015993 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 2293136..03da997 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 7cf18cb..9233fb7 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 a960dc3..b551587 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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-stbubo.adb b/gcc/ada/libgnat/a-stbubo.adb
new file mode 100644
index 0000000..a3e0e32
--- /dev/null
+++ b/gcc/ada/libgnat/a-stbubo.adb
@@ -0,0 +1,147 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- ADA.STRINGS.TEXT_BUFFERS.BOUNDED --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 2020-2021, Free Software Foundation, Inc. --
+-- --
+-- GNAT is 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.Conversions;
+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_Buffers.Bounded is
+
+ -- Pretty much the same as the Unbounded version, except where different.
+ --
+ -- One could imagine inventing an Input_Mapping generic analogous to
+ -- the existing Output_Mapping generic to address the Get-related
+ -- Bounded/Unbounded code duplication issues, but let's not. In the
+ -- Output case, there was more substantial duplication and there were
+ -- 3 clients (Bounded, Unbounded, and Files) instead of 2.
+
+ function Text_Truncated (Buffer : Buffer_Type) return Boolean is
+ (Buffer.Truncated);
+
+ function Get (Buffer : in out Buffer_Type) return String is
+ -- 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 RM 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.
+ begin
+ if Buffer.All_8_Bits and not Buffer.All_7_Bits then
+ return UTF_Encoding.Strings.Decode (Get_UTF_8 (Buffer));
+ else
+ return Get_UTF_8 (Buffer);
+ end if;
+ end Get;
+
+ function Wide_Get (Buffer : in out Buffer_Type) return Wide_String is
+ begin
+ return UTF_Encoding.Wide_Strings.Decode (Get_UTF_8 (Buffer));
+ end Wide_Get;
+
+ function Wide_Wide_Get (Buffer : in out Buffer_Type) return Wide_Wide_String
+ is
+ begin
+ return UTF_Encoding.Wide_Wide_Strings.Decode (Get_UTF_8 (Buffer));
+ end Wide_Wide_Get;
+
+ function Get_UTF_8
+ (Buffer : in out Buffer_Type) return UTF_Encoding.UTF_8_String
+ is
+ begin
+ return
+ Result : constant UTF_Encoding.UTF_8_String :=
+ UTF_Encoding.UTF_8_String
+ (Buffer.Chars (1 .. Text_Buffer_Count (Buffer.UTF_8_Length)))
+ do
+ -- Reset buffer to default initial value.
+ declare
+ Defaulted : Buffer_Type (0);
+
+ -- If this aggregate becomes illegal due to new field, don't
+ -- forget to add corresponding assignment statement below.
+ Dummy : array (1 .. 0) of Buffer_Type (0) :=
+ (others =>
+ (Max_Characters => 0, Chars => <>, Indentation => <>,
+ Indent_Pending => <>, UTF_8_Length => <>, UTF_8_Column => <>,
+ All_7_Bits => <>, All_8_Bits => <>, Truncated => <>));
+ begin
+ Buffer.Indentation := Defaulted.Indentation;
+ Buffer.Indent_Pending := Defaulted.Indent_Pending;
+ Buffer.UTF_8_Length := Defaulted.UTF_8_Length;
+ Buffer.UTF_8_Column := Defaulted.UTF_8_Column;
+ Buffer.All_7_Bits := Defaulted.All_7_Bits;
+ Buffer.All_8_Bits := Defaulted.All_8_Bits;
+ Buffer.Truncated := Defaulted.Truncated;
+ end;
+ end return;
+ end Get_UTF_8;
+
+ function Wide_Get_UTF_16
+ (Buffer : in out Buffer_Type) return UTF_Encoding.UTF_16_Wide_String
+ is
+ begin
+ return
+ UTF_Encoding.Conversions.Convert
+ (Get_UTF_8 (Buffer), Input_Scheme => UTF_Encoding.UTF_8);
+ end Wide_Get_UTF_16;
+
+ procedure Put_UTF_8_Implementation
+ (Buffer : in out Root_Buffer_Type'Class;
+ Item : UTF_Encoding.UTF_8_String)
+ is
+ procedure Buffer_Type_Implementation (Buffer : in out Buffer_Type);
+ -- View the passed-in Buffer parameter as being of type Buffer_Type,
+ -- not of Root_Buffer_Type'Class.
+
+ procedure Buffer_Type_Implementation (Buffer : in out Buffer_Type) is
+ begin
+ for Char of Item loop
+ if Buffer.UTF_8_Length = Integer (Buffer.Max_Characters) then
+ Buffer.Truncated := True;
+ return;
+ end if;
+
+ Buffer.All_7_Bits := @ and then Character'Pos (Char) < 128;
+
+ Buffer.UTF_8_Length := @ + 1;
+ Buffer.UTF_8_Column := @ + 1;
+ Buffer.Chars (Text_Buffer_Count (Buffer.UTF_8_Length)) := Char;
+ end loop;
+ end Buffer_Type_Implementation;
+ begin
+ if Item'Length > 0 then
+ Buffer_Type_Implementation (Buffer_Type (Buffer));
+ end if;
+ end Put_UTF_8_Implementation;
+
+end Ada.Strings.Text_Buffers.Bounded;
diff --git a/gcc/ada/libgnat/a-stbubo.ads b/gcc/ada/libgnat/a-stbubo.ads
new file mode 100644
index 0000000..aef7ccf
--- /dev/null
+++ b/gcc/ada/libgnat/a-stbubo.ads
@@ -0,0 +1,73 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- ADA.STRINGS.TEXT_BUFFERS.BOUNDED --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 2020-2021, 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 --
+-- copy and modify this specification, provided that if you redistribute a --
+-- modified version, any changes that you have made are clearly indicated. --
+-- --
+------------------------------------------------------------------------------
+
+package Ada.Strings.Text_Buffers.Bounded with
+ Pure
+is
+
+ type Buffer_Type (Max_Characters : Text_Buffer_Count) is
+ new Root_Buffer_Type with private with
+ Default_Initial_Condition => not Text_Truncated (Buffer_Type);
+
+ function Text_Truncated (Buffer : Buffer_Type) return Boolean;
+
+ function Get (Buffer : in out Buffer_Type) return String with
+ Post'Class => Get'Result'First = 1 and then Current_Indent (Buffer) = 0;
+
+ function Wide_Get (Buffer : in out Buffer_Type) return Wide_String with
+ Post'Class => Wide_Get'Result'First = 1
+ and then Current_Indent (Buffer) = 0;
+
+ function Wide_Wide_Get
+ (Buffer : in out Buffer_Type) return Wide_Wide_String with
+ Post'Class => Wide_Wide_Get'Result'First = 1
+ and then Current_Indent (Buffer) = 0;
+
+ function Get_UTF_8
+ (Buffer : in out Buffer_Type) return UTF_Encoding.UTF_8_String with
+ Post'Class => Get_UTF_8'Result'First = 1
+ and then Current_Indent (Buffer) = 0;
+
+ function Wide_Get_UTF_16
+ (Buffer : in out Buffer_Type) return UTF_Encoding.UTF_16_Wide_String with
+ Post'Class => Wide_Get_UTF_16'Result'First = 1
+ and then Current_Indent (Buffer) = 0;
+
+private
+
+ procedure Put_UTF_8_Implementation
+ (Buffer : in out Root_Buffer_Type'Class;
+ Item : UTF_Encoding.UTF_8_String)
+ with Pre => Buffer in Buffer_Type'Class;
+
+ package Mapping is new Output_Mapping (Put_UTF_8_Implementation);
+
+ subtype Positive_Text_Buffer_Count is
+ Text_Buffer_Count range 1 .. Text_Buffer_Count'Last;
+
+ type Convertible_To_UTF_8_String is
+ array (Positive_Text_Buffer_Count range <>) of Character;
+
+ type Buffer_Type (Max_Characters : Text_Buffer_Count)
+ is new Mapping.Buffer_Type with record
+ Truncated : Boolean := False;
+ -- True if we ran out of space on a Put
+
+ Chars : Convertible_To_UTF_8_String (1 .. Max_Characters);
+ end record;
+
+end Ada.Strings.Text_Buffers.Bounded;
diff --git a/gcc/ada/libgnat/a-stbufi.adb b/gcc/ada/libgnat/a-stbufi.adb
new file mode 100644
index 0000000..0a8feab
--- /dev/null
+++ b/gcc/ada/libgnat/a-stbufi.adb
@@ -0,0 +1,82 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- ADA.STRINGS.TEXT_BUFFERS.FILES --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 2020-2021, Free Software Foundation, Inc. --
+-- --
+-- GNAT is 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_Buffers.Files is
+
+ procedure Put_UTF_8_Implementation
+ (Buffer : in out Root_Buffer_Type'Class;
+ Item : UTF_Encoding.UTF_8_String) is
+ Result : Integer;
+ begin
+ Result := OS.Write (File_Buffer (Buffer).FD,
+ Item (Item'First)'Address,
+ Item'Length);
+ if Result /= Item'Length then
+ raise Program_Error with OS.Errno_Message;
+ end if;
+ end Put_UTF_8_Implementation;
+
+ function Create_From_FD
+ (FD : GNAT.OS_Lib.File_Descriptor;
+ Close_Upon_Finalization : Boolean := True) return File_Buffer
+ is
+ use OS;
+ begin
+ if FD = Invalid_FD then
+ raise Program_Error with OS.Errno_Message;
+ end if;
+ return Result : File_Buffer do
+ Result.FD := FD;
+ Result.Close_Upon_Finalization := Close_Upon_Finalization;
+ end return;
+ end Create_From_FD;
+
+ function Create_File (Name : String) return File_Buffer is
+ begin
+ return Create_From_FD (OS.Create_File (Name, Fmode => OS.Binary));
+ end Create_File;
+
+ procedure Finalize (Ref : in out Self_Ref) is
+ Success : Boolean;
+ use OS;
+ begin
+ if Ref.Self.FD /= OS.Invalid_FD
+ and then Ref.Self.Close_Upon_Finalization
+ then
+ Close (Ref.Self.FD, Success);
+ if not Success then
+ raise Program_Error with OS.Errno_Message;
+ end if;
+ end if;
+ Ref.Self.FD := OS.Invalid_FD;
+ end Finalize;
+
+end Ada.Strings.Text_Buffers.Files;
diff --git a/gcc/ada/libgnat/a-stoufi.ads b/gcc/ada/libgnat/a-stbufi.ads
index 0bff45a..2a2db90 100644
--- a/gcc/ada/libgnat/a-stoufi.ads
+++ b/gcc/ada/libgnat/a-stbufi.ads
@@ -2,11 +2,11 @@
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
--- ADA.STRINGS.TEXT_OUTPUT.FILES --
+-- ADA.STRINGS.TEXT_BUFFERS.FILES --
-- --
-- S p e c --
-- --
--- Copyright (C) 2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2020-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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,44 +29,47 @@
-- --
------------------------------------------------------------------------------
-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.
+with Ada.Finalization;
+with GNAT.OS_Lib;
- function Standard_Output return Sink_Access;
- function Standard_Error return Sink_Access;
+package Ada.Strings.Text_Buffers.Files is
- type File (<>) is new Sink with private;
+ type File_Buffer is new Root_Buffer_Type with private;
+ -- Output written to a File_Buffer is written to the associated file.
- 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.
+ function Create_From_FD
+ (FD : GNAT.OS_Lib.File_Descriptor;
+ Close_Upon_Finalization : Boolean := True)
+ return File_Buffer;
+ -- file closed upon finalization if specified
- procedure Close (S : in out File'Class);
+ function Create_File (Name : String) return File_Buffer;
+ -- file closed upon finalization
+
+ function Create_Standard_Output_Buffer return File_Buffer is
+ (Create_From_FD (GNAT.OS_Lib.Standout, Close_Upon_Finalization => False));
+ function Create_Standard_Error_Buffer return File_Buffer is
+ (Create_From_FD (GNAT.OS_Lib.Standerr, Close_Upon_Finalization => False));
private
+ procedure Put_UTF_8_Implementation
+ (Buffer : in out Root_Buffer_Type'Class;
+ Item : UTF_Encoding.UTF_8_String)
+ with Pre => Buffer in File_Buffer'Class;
+
+ package Mapping is new Output_Mapping (Put_UTF_8_Implementation);
+
package OS renames GNAT.OS_Lib;
- type Self_Ref (Self : access File) is new Finalization.Limited_Controlled
- with null record;
+ type Self_Ref (Self : not null access File_Buffer)
+ 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);
+ type File_Buffer is new Mapping.Buffer_Type with record
+ FD : OS.File_Descriptor := OS.Invalid_FD;
+ Ref : Self_Ref (File_Buffer'Access);
+ Close_Upon_Finalization : Boolean := False;
end record;
- overriding procedure Full_Method (S : in out File);
- overriding procedure Flush_Method (S : in out File);
-
-end Ada.Strings.Text_Output.Files;
+end Ada.Strings.Text_Buffers.Files;
diff --git a/gcc/ada/libgnat/a-stoufo.adb b/gcc/ada/libgnat/a-stbufo.adb
index f80b30a..8ac5512 100644
--- a/gcc/ada/libgnat/a-stoufo.adb
+++ b/gcc/ada/libgnat/a-stbufo.adb
@@ -2,11 +2,11 @@
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
--- ADA.STRINGS.TEXT_OUTPUT.FORMATTING --
+-- ADA.STRINGS.TEXT_BUFFERS.FORMATTING --
-- --
-- B o d y --
-- --
--- Copyright (C) 2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2020-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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,17 @@
-- --
------------------------------------------------------------------------------
-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
+with Ada.Strings.Text_Buffers.Unbounded;
+with Ada.Strings.Text_Buffers.Files;
+
+package body Ada.Strings.Text_Buffers.Formatting is
+
+ use Ada.Strings.Text_Buffers.Files;
+ use Ada.Strings.Text_Buffers.Utils;
procedure Put
- (S : in out Sink'Class; T : Template;
- X1, X2, X3, X4, X5, X6, X7, X8, X9 : UTF_8_Lines := "")
+ (S : in out Root_Buffer_Type'Class; T : Template;
+ X1, X2, X3, X4, X5, X6, X7, X8, X9 : Utils.UTF_8_Lines := "")
is
J : Positive := T'First;
Used : array (1 .. 9) of Boolean := (others => False);
@@ -50,13 +53,13 @@ package body Ada.Strings.Text_Output.Formatting is
when '\' =>
Put_7bit (S, '\');
when 'i' =>
- Indent (S);
+ Increase_Indent (S);
when 'o' =>
- Outdent (S);
+ Decrease_Indent (S);
when 'I' =>
- Indent (S, 1);
+ Increase_Indent (S, 1);
when 'O' =>
- Outdent (S, 1);
+ Decrease_Indent (S, 1);
when '1' =>
Used (1) := True;
@@ -123,33 +126,33 @@ package body Ada.Strings.Text_Output.Formatting is
if not Used (9) then
pragma Assert (X9 = "");
end if;
-
- Flush (S);
end Put;
+ function Format
+ (T : Template;
+ X1, X2, X3, X4, X5, X6, X7, X8, X9 : Utils.UTF_8_Lines := "")
+ return Utils.UTF_8_Lines
+ is
+ Buffer : Unbounded.Buffer_Type;
+ begin
+ Put (Buffer, T, X1, X2, X3, X4, X5, X6, X7, X8, X9);
+ return Buffer.Get_UTF_8;
+ end Format;
+
procedure Put
(T : Template;
- X1, X2, X3, X4, X5, X6, X7, X8, X9 : UTF_8_Lines := "") is
+ X1, X2, X3, X4, X5, X6, X7, X8, X9 : Utils.UTF_8_Lines := "") is
+ Buffer : File_Buffer := Create_Standard_Output_Buffer;
begin
- Put (Files.Standard_Output.all, T, X1, X2, X3, X4, X5, X6, X7, X8, X9);
+ Put (Buffer, 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
+ X1, X2, X3, X4, X5, X6, X7, X8, X9 : Utils.UTF_8_Lines := "") is
+ Buffer : File_Buffer := Create_Standard_Error_Buffer;
begin
- Put (Files.Standard_Error.all, T, X1, X2, X3, X4, X5, X6, X7, X8, X9);
+ Put (Buffer, 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;
+end Ada.Strings.Text_Buffers.Formatting;
diff --git a/gcc/ada/libgnat/a-stoufo.ads b/gcc/ada/libgnat/a-stbufo.ads
index 3b44bd8..8c0d476 100644
--- a/gcc/ada/libgnat/a-stoufo.ads
+++ b/gcc/ada/libgnat/a-stbufo.ads
@@ -2,11 +2,11 @@
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
--- ADA.STRINGS.TEXT_OUTPUT.FORMATTING --
+-- ADA.STRINGS.TEXT_BUFFERS.FORMATTING --
-- --
-- S p e c --
-- --
--- Copyright (C) 2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2020-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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,19 +29,20 @@
-- --
------------------------------------------------------------------------------
-package Ada.Strings.Text_Output.Formatting is
+with Ada.Strings.Text_Buffers.Utils;
+
+package Ada.Strings.Text_Buffers.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;
+ type Template is new Utils.UTF_8;
+
procedure Put
- (S : in out Sink'Class; T : Template;
- X1, X2, X3, X4, X5, X6, X7, X8, X9 : UTF_8_Lines := "");
+ (S : in out Root_Buffer_Type'Class; T : Template;
+ X1, X2, X3, X4, X5, X6, X7, X8, X9 : Utils.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.
@@ -55,18 +56,18 @@ package Ada.Strings.Text_Output.Formatting is
procedure Put
(T : Template;
- X1, X2, X3, X4, X5, X6, X7, X8, X9 : UTF_8_Lines := "");
+ X1, X2, X3, X4, X5, X6, X7, X8, X9 : Utils.UTF_8_Lines := "");
-- Sends to standard output
procedure Err
(T : Template;
- X1, X2, X3, X4, X5, X6, X7, X8, X9 : UTF_8_Lines := "");
+ X1, X2, X3, X4, X5, X6, X7, X8, X9 : Utils.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;
+ X1, X2, X3, X4, X5, X6, X7, X8, X9 : Utils.UTF_8_Lines := "")
+ return Utils.UTF_8_Lines;
-- Returns a UTF-8-encoded String
-end Ada.Strings.Text_Output.Formatting;
+end Ada.Strings.Text_Buffers.Formatting;
diff --git a/gcc/ada/libgnat/a-stbuun.adb b/gcc/ada/libgnat/a-stbuun.adb
new file mode 100644
index 0000000..9ae3d28
--- /dev/null
+++ b/gcc/ada/libgnat/a-stbuun.adb
@@ -0,0 +1,193 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- ADA.STRINGS.TEXT_BUFFERS.UNBOUNDED --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 2020-2021, Free Software Foundation, Inc. --
+-- --
+-- GNAT is 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.Unchecked_Deallocation;
+with Ada.Strings.UTF_Encoding.Conversions;
+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_Buffers.Unbounded is
+
+ function Get (Buffer : in out Buffer_Type) return String is
+ -- 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 RM 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.
+ begin
+ if Buffer.All_8_Bits and not Buffer.All_7_Bits then
+ return UTF_Encoding.Strings.Decode (Get_UTF_8 (Buffer));
+ else
+ return Get_UTF_8 (Buffer);
+ end if;
+ end Get;
+
+ function Wide_Get (Buffer : in out Buffer_Type) return Wide_String is
+ begin
+ return UTF_Encoding.Wide_Strings.Decode (Get_UTF_8 (Buffer));
+ end Wide_Get;
+
+ function Wide_Wide_Get (Buffer : in out Buffer_Type) return Wide_Wide_String
+ is
+ begin
+ return UTF_Encoding.Wide_Wide_Strings.Decode (Get_UTF_8 (Buffer));
+ end Wide_Wide_Get;
+
+ function Get_UTF_8
+ (Buffer : in out Buffer_Type) return UTF_Encoding.UTF_8_String
+ is
+ begin
+ return Result : UTF_Encoding.UTF_8_String (1 .. Buffer.UTF_8_Length) do
+ declare
+ Target_First : Positive := 1;
+ Ptr : Chunk_Access := Buffer.List.First_Chunk'Unchecked_Access;
+ Target_Last : Positive;
+ begin
+ while Ptr /= null loop
+ Target_Last := Target_First + Ptr.Chars'Length - 1;
+ if Target_Last <= Result'Last then
+ -- all of chunk is assigned to Result
+ Result (Target_First .. Target_Last) := Ptr.Chars;
+ Target_First := Target_First + Ptr.Chars'Length;
+ else
+ -- only part of (last) chunk is assigned to Result
+ declare
+ Final_Target : UTF_Encoding.UTF_8_String renames
+ Result (Target_First .. Result'Last);
+ begin
+ Final_Target := Ptr.Chars (1 .. Final_Target'Length);
+ end;
+ pragma Assert (Ptr.Next = null);
+ Target_First := Integer'Last;
+ end if;
+
+ Ptr := Ptr.Next;
+ end loop;
+ end;
+
+ -- Reset buffer to default initial value.
+ declare
+ Defaulted : Buffer_Type;
+
+ -- If this aggregate becomes illegal due to new field, don't
+ -- forget to add corresponding assignment statement below.
+ Dummy : array (1 .. 0) of Buffer_Type :=
+ (others =>
+ (Indentation => <>, Indent_Pending => <>, UTF_8_Length => <>,
+ UTF_8_Column => <>, All_7_Bits => <>, All_8_Bits => <>,
+ List => <>, Last_Used => <>));
+ begin
+ Buffer.Indentation := Defaulted.Indentation;
+ Buffer.Indent_Pending := Defaulted.Indent_Pending;
+ Buffer.UTF_8_Length := Defaulted.UTF_8_Length;
+ Buffer.UTF_8_Column := Defaulted.UTF_8_Column;
+ Buffer.All_7_Bits := Defaulted.All_7_Bits;
+ Buffer.All_8_Bits := Defaulted.All_8_Bits;
+ Buffer.Last_Used := Defaulted.Last_Used;
+ Finalize (Buffer.List); -- free any allocated chunks
+ end;
+ end return;
+ end Get_UTF_8;
+
+ function Wide_Get_UTF_16
+ (Buffer : in out Buffer_Type) return UTF_Encoding.UTF_16_Wide_String
+ is
+ begin
+ return
+ UTF_Encoding.Conversions.Convert
+ (Get_UTF_8 (Buffer), Input_Scheme => UTF_Encoding.UTF_8);
+ end Wide_Get_UTF_16;
+
+ procedure Put_UTF_8_Implementation
+ (Buffer : in out Root_Buffer_Type'Class;
+ Item : UTF_Encoding.UTF_8_String)
+ is
+ procedure Buffer_Type_Implementation (Buffer : in out Buffer_Type);
+ -- View the passed-in Buffer parameter as being of type Buffer_Type,
+ -- not of type Root_Buffer_Type'Class.
+
+ procedure Buffer_Type_Implementation (Buffer : in out Buffer_Type) is
+ begin
+ for Char of Item loop
+ Buffer.All_7_Bits := @ and then Character'Pos (Char) < 128;
+
+ if Buffer.Last_Used = Buffer.List.Current_Chunk.Length then
+ -- Current chunk is full; allocate a new one with doubled size
+
+ declare
+ Cc : Chunk renames Buffer.List.Current_Chunk.all;
+ Max : constant Positive := Integer'Last / 2;
+ Length : constant Natural :=
+ Integer'Min (Max, 2 * Cc.Length);
+ begin
+ pragma Assert (Cc.Next = null);
+ Cc.Next := new Chunk (Length => Length);
+ Buffer.List.Current_Chunk := Cc.Next;
+ Buffer.Last_Used := 0;
+ end;
+ end if;
+
+ Buffer.UTF_8_Length := @ + 1;
+ Buffer.UTF_8_Column := @ + 1;
+ Buffer.Last_Used := @ + 1;
+ Buffer.List.Current_Chunk.Chars (Buffer.Last_Used) := Char;
+ end loop;
+ end Buffer_Type_Implementation;
+ begin
+ Buffer_Type_Implementation (Buffer_Type (Buffer));
+ end Put_UTF_8_Implementation;
+
+ procedure Initialize (List : in out Managed_Chunk_List) is
+ begin
+ List.Current_Chunk := List.First_Chunk'Unchecked_Access;
+ end Initialize;
+
+ procedure Finalize (List : in out Managed_Chunk_List) is
+ procedure Free is new Ada.Unchecked_Deallocation (Chunk, Chunk_Access);
+ Ptr : Chunk_Access := List.First_Chunk.Next;
+ begin
+ while Ptr /= null loop
+ declare
+ Old_Ptr : Chunk_Access := Ptr;
+ begin
+ Ptr := Ptr.Next;
+ Free (Old_Ptr);
+ end;
+ end loop;
+
+ List.First_Chunk.Next := null;
+ Initialize (List);
+ end Finalize;
+
+end Ada.Strings.Text_Buffers.Unbounded;
diff --git a/gcc/ada/libgnat/a-stbuun.ads b/gcc/ada/libgnat/a-stbuun.ads
new file mode 100644
index 0000000..3c6ad3a
--- /dev/null
+++ b/gcc/ada/libgnat/a-stbuun.ads
@@ -0,0 +1,87 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- ADA.STRINGS.TEXT_BUFFERS.UNBOUNDED --
+-- --
+-- S p e c --
+-- --
+-- This specification is derived from the Ada Reference Manual for use with --
+-- GNAT. In accordance with the copyright of that document, you can freely --
+-- copy and modify this specification, provided that if you redistribute a --
+-- modified version, any changes that you have made are clearly indicated. --
+-- --
+------------------------------------------------------------------------------
+
+with Ada.Finalization;
+package Ada.Strings.Text_Buffers.Unbounded with
+ Preelaborate
+ -- , Nonblocking
+ -- , Global => null
+is
+
+ type Buffer_Type is new Root_Buffer_Type with private;
+
+ function Get (Buffer : in out Buffer_Type) return String with
+ Post'Class => Get'Result'First = 1 and then Current_Indent (Buffer) = 0;
+
+ function Wide_Get (Buffer : in out Buffer_Type) return Wide_String with
+ Post'Class => Wide_Get'Result'First = 1
+ and then Current_Indent (Buffer) = 0;
+
+ function Wide_Wide_Get
+ (Buffer : in out Buffer_Type) return Wide_Wide_String with
+ Post'Class => Wide_Wide_Get'Result'First = 1
+ and then Current_Indent (Buffer) = 0;
+
+ function Get_UTF_8
+ (Buffer : in out Buffer_Type) return UTF_Encoding.UTF_8_String with
+ Post'Class => Get_UTF_8'Result'First = 1
+ and then Current_Indent (Buffer) = 0;
+
+ function Wide_Get_UTF_16
+ (Buffer : in out Buffer_Type) return UTF_Encoding.UTF_16_Wide_String with
+ Post'Class => Wide_Get_UTF_16'Result'First = 1
+ and then Current_Indent (Buffer) = 0;
+
+private
+
+ procedure Put_UTF_8_Implementation
+ (Buffer : in out Root_Buffer_Type'Class;
+ Item : UTF_Encoding.UTF_8_String)
+ with Pre => Buffer in Buffer_Type'Class;
+
+ package Mapping is new Output_Mapping (Put_UTF_8_Implementation);
+
+ type Chunk;
+ type Chunk_Access is access all Chunk;
+ type Chunk (Length : Positive) is record
+ Next : Chunk_Access := null;
+ Chars : UTF_Encoding.UTF_8_String (1 .. Length);
+ end record;
+
+ type Managed_Chunk_List is new Ada.Finalization.Limited_Controlled with
+ record
+ First_Chunk : aliased Chunk (64);
+ -- First chunk in list is not created by an allocator; it is
+ -- large enough to suffice for many common images.
+
+ Current_Chunk : Chunk_Access;
+ -- Chunk we are currrently writing to.
+ -- Initialized to Managed_Chunk_List.First'Access.
+ end record;
+
+ overriding procedure Initialize (List : in out Managed_Chunk_List);
+ -- List.Current_Chunk := List.First_Chunk'Unchecked_Access;
+
+ overriding procedure Finalize (List : in out Managed_Chunk_List);
+ -- Free any allocated chunks.
+
+ type Buffer_Type is new Mapping.Buffer_Type with record
+ List : Managed_Chunk_List;
+
+ Last_Used : Natural := 0;
+ -- Index of last used char in List.Current_Chunk.all; 0 if none used.
+ end record;
+
+end Ada.Strings.Text_Buffers.Unbounded;
diff --git a/gcc/ada/libgnat/a-stobfi.ads b/gcc/ada/libgnat/a-stbuut.adb
index 65e8e24..b32b2d3 100644
--- a/gcc/ada/libgnat/a-stobfi.ads
+++ b/gcc/ada/libgnat/a-stbuut.adb
@@ -2,11 +2,11 @@
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
--- ADA.STRINGS.TEXT_OUTPUT.BASIC_FILES --
+-- ADA.STRINGS.TEXT_BUFFERS.UTILS --
-- --
--- S p e c --
+-- B o d y --
-- --
--- Copyright (C) 2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2020-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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,38 +29,53 @@
-- --
------------------------------------------------------------------------------
-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.
+package body Ada.Strings.Text_Buffers.Utils is
- function Standard_Output return Sink_Access;
- function Standard_Error return Sink_Access;
+ procedure Put_7bit
+ (Buffer : in out Root_Buffer_Type'Class; Item : Character_7)
+ is
+ begin
+ Put (Buffer, (1 => Item));
+ end Put_7bit;
- type File (<>) is new Sink with private;
+ procedure Put_Character
+ (Buffer : in out Root_Buffer_Type'Class; Item : Character)
+ is
+ begin
+ Put (Buffer, (1 => Item));
+ end Put_Character;
- 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 Put_Wide_Character
+ (Buffer : in out Root_Buffer_Type'Class; Item : Wide_Character)
+ is
+ begin
+ Wide_Put (Buffer, (1 => Item));
+ end Put_Wide_Character;
- procedure Close (S : in out File'Class);
+ procedure Put_Wide_Wide_Character
+ (Buffer : in out Root_Buffer_Type'Class; Item : Wide_Wide_Character)
+ is
+ begin
+ Wide_Wide_Put (Buffer, (1 => Item));
+ end Put_Wide_Wide_Character;
-private
+ procedure Put_UTF_8_Lines
+ (Buffer : in out Root_Buffer_Type'Class; Item : UTF_8_Lines)
+ is
+ begin
+ Put (Buffer, Item);
+ end Put_UTF_8_Lines;
- package OS renames GNAT.OS_Lib;
+ function Column (Buffer : Root_Buffer_Type'Class) return Positive is
+ begin
+ return Buffer.UTF_8_Column;
+ end Column;
- type File is new Sink with record
- FD : OS.File_Descriptor := OS.Invalid_FD;
- end record;
+ procedure Tab_To_Column
+ (Buffer : in out Root_Buffer_Type'Class; Column : Positive)
+ is
+ begin
+ Put (Buffer, String'(1 .. Column - Utils.Column (Buffer) => ' '));
+ end Tab_To_Column;
- overriding procedure Full_Method (S : in out File);
- overriding procedure Flush_Method (S : in out File);
-
-end Ada.Strings.Text_Output.Basic_Files;
+end Ada.Strings.Text_Buffers.Utils;
diff --git a/gcc/ada/libgnat/a-stoubu.ads b/gcc/ada/libgnat/a-stbuut.ads
index faec897..d76b8cf 100644
--- a/gcc/ada/libgnat/a-stoubu.ads
+++ b/gcc/ada/libgnat/a-stbuut.ads
@@ -2,11 +2,11 @@
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
--- ADA.STRINGS.TEXT_OUTPUT.BUFFERS --
+-- ADA.STRINGS.TEXT_BUFFERS.UTILS --
-- --
-- S p e c --
-- --
--- Copyright (C) 2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2020-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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,45 +29,54 @@
-- --
------------------------------------------------------------------------------
-package Ada.Strings.Text_Output.Buffers is
+with Ada.Strings.UTF_Encoding.Wide_Wide_Strings;
- type Buffer (<>) is new Sink with private;
+package Ada.Strings.Text_Buffers.Utils with Pure is
- function New_Buffer
- (Indent_Amount : Natural := Default_Indent_Amount;
- Chunk_Length : Positive := Default_Chunk_Length) return Buffer;
+ -- Ada.Strings.Text_Buffers is a predefined unit (see Ada RM A.4.12).
+ -- This is a GNAT-defined child unit of that parent.
- 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.
+ subtype Character_7 is
+ Character range Character'Val (0) .. Character'Val (2**7 - 1);
- function Get_UTF_8 (S : Buffer'Class) return UTF_8_Lines;
- -- Get the characters in S, encoded as UTF-8.
+ procedure Put_7bit
+ (Buffer : in out Root_Buffer_Type'Class; Item : Character_7);
+ procedure Put_Character
+ (Buffer : in out Root_Buffer_Type'Class; Item : Character);
+ procedure Put_Wide_Character
+ (Buffer : in out Root_Buffer_Type'Class; Item : Wide_Character);
+ procedure Put_Wide_Wide_Character
+ (Buffer : in out Root_Buffer_Type'Class; Item : Wide_Wide_Character);
+ -- Single character output procedures.
- 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 Column (Buffer : Root_Buffer_Type'Class) return Positive with
+ Inline;
+ -- Current output column. The Column is initially 1, and is incremented for
+ -- each 8-bit character output. A call to New_Line sets Column back to 1.
+ -- The next character to be output will go in this column.
- 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.
+ procedure Tab_To_Column
+ (Buffer : in out Root_Buffer_Type'Class; Column : Positive);
+ -- Put spaces until we're at or past Column.
-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;
+ subtype Sink is Root_Buffer_Type;
+
+ function NL return Character is (ASCII.LF) with Inline;
+
+ function UTF_8_Length (Buffer : Root_Buffer_Type'Class) return Natural;
- overriding procedure Full_Method (S : in out Buffer);
- overriding procedure Flush_Method (S : in out Buffer) is null;
+ 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;
-end Ada.Strings.Text_Output.Buffers;
+ subtype UTF_8 is UTF_8_Lines with
+ Predicate => (for all UTF_8_Char of UTF_8 => UTF_8_Char /= NL);
+
+ procedure Put_UTF_8_Lines
+ (Buffer : in out Root_Buffer_Type'Class; Item : UTF_8_Lines);
+
+private
+ function UTF_8_Length (Buffer : Root_Buffer_Type'Class) return Natural
+ is (Buffer.UTF_8_Length);
+end Ada.Strings.Text_Buffers.Utils;
diff --git a/gcc/ada/libgnat/a-stmaco.ads b/gcc/ada/libgnat/a-stmaco.ads
index 8493bb3..4d280ec 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, 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-stobfi.adb b/gcc/ada/libgnat/a-stobfi.adb
deleted file mode 100644
index dd485ba..0000000
--- a/gcc/ada/libgnat/a-stobfi.adb
+++ /dev/null
@@ -1,118 +0,0 @@
-------------------------------------------------------------------------------
--- --
--- 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-storio.adb b/gcc/ada/libgnat/a-storio.adb
index 5c68082..424526d 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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
deleted file mode 100644
index 663d4ba..0000000
--- a/gcc/ada/libgnat/a-stoubu.adb
+++ /dev/null
@@ -1,148 +0,0 @@
-------------------------------------------------------------------------------
--- --
--- 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
-
- type Chunk_Access is access all Chunk;
-
- 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;
-
- -- We need type conversions of Chunk_Access values in the following two
- -- procedures, because the one in Text_Output has Storage_Size => 0,
- -- because Text_Output is Pure. We do not run afoul of 13.11.2(16/3),
- -- which requires the allocation and deallocation to have the same pool,
- -- because the allocation in Full_Method and the deallocation in Destroy
- -- use the same access type, and therefore the same pool.
-
- procedure Destroy (S : in out Buffer) is
- procedure Free is new Unchecked_Deallocation (Chunk, Chunk_Access);
- Cur : Chunk_Access := Chunk_Access (S.Initial_Chunk.Next);
- begin
- while Cur /= null loop
- declare
- Temp : constant Chunk_Access := 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 :=
- Text_Output.Chunk_Access (Chunk_Access'(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-stoufi.adb b/gcc/ada/libgnat/a-stoufi.adb
deleted file mode 100644
index 34086bb..0000000
--- a/gcc/ada/libgnat/a-stoufi.adb
+++ /dev/null
@@ -1,123 +0,0 @@
-------------------------------------------------------------------------------
--- --
--- 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-stouut.adb b/gcc/ada/libgnat/a-stouut.adb
deleted file mode 100644
index 2011408..0000000
--- a/gcc/ada/libgnat/a-stouut.adb
+++ /dev/null
@@ -1,272 +0,0 @@
-------------------------------------------------------------------------------
--- --
--- 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;
- S.Column := S.Column + 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;
- S.Column := S.Column + 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);
- 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
deleted file mode 100644
index 5056080..0000000
--- a/gcc/ada/libgnat/a-stouut.ads
+++ /dev/null
@@ -1,107 +0,0 @@
-------------------------------------------------------------------------------
--- --
--- 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 Pure 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, Post => Column (S) = 1;
- -- 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 d48798b..61b3d73 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 ebde112..f0cf7b2 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, 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 67d70c5..a7ef308 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2013-2021, 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 9a76ee3..a88d44f 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, 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 8105f30..ee72b6b 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -145,30 +145,26 @@ package body Ada.Strings.Fixed is
(Left : Natural;
Right : Character) return String
is
- Result : String (1 .. Left);
-
begin
- for J in Result'Range loop
- Result (J) := Right;
- end loop;
-
- return Result;
+ return Result : String (1 .. Left) do
+ for J in Result'Range loop
+ Result (J) := Right;
+ end loop;
+ end return;
end "*";
function "*"
(Left : Natural;
Right : String) return String
is
- Result : String (1 .. Left * Right'Length);
Ptr : Integer := 1;
-
begin
- for J in 1 .. Left loop
- Result (Ptr .. Ptr + Right'Length - 1) := Right;
- Ptr := Ptr + Right'Length;
- end loop;
-
- return Result;
+ return Result : String (1 .. Left * Right'Length) do
+ for J in 1 .. Left loop
+ Result (Ptr .. Ptr + Right'Length - 1) := Right;
+ Ptr := Ptr + Right'Length;
+ end loop;
+ end return;
end "*";
------------
@@ -180,6 +176,7 @@ package body Ada.Strings.Fixed is
From : Positive;
Through : Natural) return String
is
+ Front : Integer;
begin
if From > Through then
declare
@@ -207,18 +204,13 @@ package body Ada.Strings.Fixed is
end if;
else
- declare
- Front : constant Integer := From - Source'First;
- Result : String (1 .. Source'Length - (Through - From + 1));
-
- begin
+ Front := From - Source'First;
+ return Result : String (1 .. Source'Length - (Through - From + 1)) do
Result (1 .. Front) :=
Source (Source'First .. From - 1);
Result (Front + 1 .. Result'Last) :=
Source (Through + 1 .. Source'Last);
-
- return Result;
- end;
+ end return;
end if;
end Delete;
@@ -253,18 +245,13 @@ package body Ada.Strings.Fixed is
Result_Type (Source (Source'First .. Source'First + Count - 1));
else
- declare
- Result : Result_Type;
-
- begin
+ return Result : Result_Type do
Result (1 .. Source'Length) := Source;
for J in Source'Length + 1 .. Count loop
Result (J) := Pad;
end loop;
-
- return Result;
- end;
+ end return;
end if;
end Head;
@@ -291,7 +278,6 @@ package body Ada.Strings.Fixed is
Before : Positive;
New_Item : String) return String
is
- Result : String (1 .. Source'Length + New_Item'Length);
Front : constant Integer := Before - Source'First;
begin
@@ -299,14 +285,14 @@ package body Ada.Strings.Fixed is
raise Index_Error;
end if;
- Result (1 .. Front) :=
- Source (Source'First .. Before - 1);
- Result (Front + 1 .. Front + New_Item'Length) :=
- New_Item;
- Result (Front + New_Item'Length + 1 .. Result'Last) :=
- Source (Before .. Source'Last);
-
- return Result;
+ return Result : String (1 .. Source'Length + New_Item'Length) do
+ Result (1 .. Front) :=
+ Source (Source'First .. Before - 1);
+ Result (Front + 1 .. Front + New_Item'Length) :=
+ New_Item;
+ Result (Front + New_Item'Length + 1 .. Result'Last) :=
+ Source (Before .. Source'Last);
+ end return;
end Insert;
procedure Insert
@@ -435,8 +421,7 @@ package body Ada.Strings.Fixed is
function Overwrite
(Source : String;
Position : Positive;
- New_Item : String) return String
- is
+ New_Item : String) return String is
begin
if Position not in Source'First .. Source'Last + 1 then
raise Index_Error;
@@ -444,21 +429,17 @@ package body Ada.Strings.Fixed is
declare
Result_Length : constant Natural :=
- Integer'Max
- (Source'Length,
- Position - Source'First + New_Item'Length);
-
- Result : String (1 .. Result_Length);
- Front : constant Integer := Position - Source'First;
+ Integer'Max (Source'Length,
+ Position - Source'First + New_Item'Length);
+ Front : constant Integer := Position - Source'First;
begin
- Result (1 .. Front) :=
- Source (Source'First .. Position - 1);
- Result (Front + 1 .. Front + New_Item'Length) :=
- New_Item;
- Result (Front + New_Item'Length + 1 .. Result'Length) :=
- Source (Position + New_Item'Length .. Source'Last);
- return Result;
+ return Result : String (1 .. Result_Length) do
+ Result (1 .. Front) := Source (Source'First .. Position - 1);
+ Result (Front + 1 .. Front + New_Item'Length) := New_Item;
+ Result (Front + New_Item'Length + 1 .. Result'Length) :=
+ Source (Position + New_Item'Length .. Source'Last);
+ end return;
end;
end Overwrite;
@@ -495,24 +476,21 @@ package body Ada.Strings.Fixed is
Integer'Max (0, Low - Source'First);
-- Length of prefix of Source copied to result
- Back_Len : constant Integer :=
- Integer'Max (0, Source'Last - High);
+ Back_Len : constant Integer := Integer'Max (0, Source'Last - High);
-- Length of suffix of Source copied to result
Result_Length : constant Integer :=
Front_Len + By'Length + Back_Len;
-- Length of result
- Result : String (1 .. Result_Length);
-
begin
- Result (1 .. Front_Len) := Source (Source'First .. Low - 1);
- Result (Front_Len + 1 .. Front_Len + By'Length) := By;
- Result (Front_Len + By'Length + 1 .. Result'Length) :=
- Source (High + 1 .. Source'Last);
- return Result;
+ return Result : String (1 .. Result_Length) do
+ Result (1 .. Front_Len) := Source (Source'First .. Low - 1);
+ Result (Front_Len + 1 .. Front_Len + By'Length) := By;
+ Result (Front_Len + By'Length + 1 .. Result'Length) :=
+ Source (High + 1 .. Source'Last);
+ end return;
end;
-
else
return Insert (Source, Before => Low, New_Item => By);
end if;
@@ -549,17 +527,13 @@ package body Ada.Strings.Fixed is
-- Pad on left
else
- declare
- Result : Result_Type;
-
- begin
+ return Result : Result_Type do
for J in 1 .. Count - Source'Length loop
Result (J) := Pad;
end loop;
Result (Count - Source'Length + 1 .. Count) := Source;
- return Result;
- end;
+ end return;
end if;
end Tail;
@@ -585,14 +559,12 @@ package body Ada.Strings.Fixed is
(Source : String;
Mapping : Maps.Character_Mapping) return String
is
- Result : String (1 .. Source'Length);
-
begin
- for J in Source'Range loop
- Result (J - (Source'First - 1)) := Value (Mapping, Source (J));
- end loop;
-
- return Result;
+ return Result : String (1 .. Source'Length) do
+ for J in Source'Range loop
+ Result (J - (Source'First - 1)) := Value (Mapping, Source (J));
+ end loop;
+ end return;
end Translate;
procedure Translate
@@ -609,15 +581,13 @@ package body Ada.Strings.Fixed is
(Source : String;
Mapping : Maps.Character_Mapping_Function) return String
is
- Result : String (1 .. Source'Length);
pragma Unsuppress (Access_Check);
-
begin
- for J in Source'Range loop
- Result (J - (Source'First - 1)) := Mapping.all (Source (J));
- end loop;
-
- return Result;
+ return Result : String (1 .. Source'Length) do
+ for J in Source'Range loop
+ Result (J - (Source'First - 1)) := Mapping.all (Source (J));
+ end loop;
+ end return;
end Translate;
procedure Translate
diff --git a/gcc/ada/libgnat/a-strhas.adb b/gcc/ada/libgnat/a-strhas.adb
index 572b766..1732941 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 9f6e857..8ad9f12 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 c922f4e..c35c392 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, 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 b779090..d96a4c7 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 668b2e1..623c0f4 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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
index ae38b2d..2c6fa7d 100644
--- a/gcc/ada/libgnat/a-strsto.ads
+++ b/gcc/ada/libgnat/a-strsto.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2020-2021, 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-strsup.adb b/gcc/ada/libgnat/a-strsup.adb
index e11df76..1e85cc2 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2003-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 50607ae..9e568a8 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2003-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 7d1e6dd..4727f965 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -783,7 +783,8 @@ package body Ada.Strings.Unbounded is
---------------
procedure Put_Image
- (S : in out Ada.Strings.Text_Output.Sink'Class; V : Unbounded_String) is
+ (S : in out Ada.Strings.Text_Buffers.Root_Buffer_Type'Class;
+ V : Unbounded_String) is
begin
String'Put_Image (S, To_String (V));
end Put_Image;
diff --git a/gcc/ada/libgnat/a-strunb.ads b/gcc/ada/libgnat/a-strunb.ads
index 7de9bbc..13c7612 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, 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,7 @@ pragma Assertion_Policy (Pre => Ignore);
with Ada.Strings.Maps;
with Ada.Finalization;
-private with Ada.Strings.Text_Output;
+private with Ada.Strings.Text_Buffers;
-- The language-defined package Strings.Unbounded provides a private type
-- Unbounded_String and a set of operations. An object of type
@@ -81,7 +81,7 @@ is
--------------------------------------------------------
function To_Unbounded_String
- (Source : String) return Unbounded_String
+ (Source : String) return Unbounded_String
with
Post => Length (To_Unbounded_String'Result) = Source'Length,
Global => null;
@@ -91,8 +91,7 @@ is
(Length : Natural) return Unbounded_String
with
Post =>
- Ada.Strings.Unbounded.Length (To_Unbounded_String'Result)
- = Length,
+ Ada.Strings.Unbounded.Length (To_Unbounded_String'Result) = Length,
Global => null;
-- Returns an Unbounded_String that represents an uninitialized String
-- whose length is Length.
@@ -524,11 +523,11 @@ is
with
Pre =>
Low - 1 <= Length (Source)
- and then (if High >= Low
- then Low - 1
- <= Natural'Last - By'Length
- - Natural'Max (Length (Source) - High, 0)
- else Length (Source) <= Natural'Last - By'Length),
+ and then (if High >= Low
+ then Low - 1
+ <= Natural'Last - By'Length
+ - Natural'Max (Length (Source) - High, 0)
+ else Length (Source) <= Natural'Last - By'Length),
Contract_Cases =>
(High >= Low =>
Length (Replace_Slice'Result)
@@ -545,11 +544,11 @@ is
with
Pre =>
Low - 1 <= Length (Source)
- and then (if High >= Low
- then Low - 1
- <= Natural'Last - By'Length
- - Natural'Max (Length (Source) - High, 0)
- else Length (Source) <= Natural'Last - By'Length),
+ and then (if High >= Low
+ then Low - 1
+ <= Natural'Last - By'Length
+ - Natural'Max (Length (Source) - High, 0)
+ else Length (Source) <= Natural'Last - By'Length),
Contract_Cases =>
(High >= Low =>
Length (Source)
@@ -586,7 +585,7 @@ is
Pre => Position - 1 <= Length (Source)
and then (if New_Item'Length /= 0
then
- New_Item'Length <= Natural'Last - (Position - 1)),
+ New_Item'Length <= Natural'Last - (Position - 1)),
Post =>
Length (Overwrite'Result)
= Natural'Max (Length (Source), Position - 1 + New_Item'Length),
@@ -600,7 +599,7 @@ is
Pre => Position - 1 <= Length (Source)
and then (if New_Item'Length /= 0
then
- New_Item'Length <= Natural'Last - (Position - 1)),
+ New_Item'Length <= Natural'Last - (Position - 1)),
Post =>
Length (Source)
= Natural'Max (Length (Source)'Old, Position - 1 + New_Item'Length),
@@ -748,7 +747,8 @@ private
end record with Put_Image => Put_Image;
procedure Put_Image
- (S : in out Ada.Strings.Text_Output.Sink'Class; V : Unbounded_String);
+ (S : in out Ada.Strings.Text_Buffers.Root_Buffer_Type'Class;
+ V : Unbounded_String);
-- The Unbounded_String is using a buffered implementation to increase
-- speed of the Append/Delete/Insert procedures. The Reference string
diff --git a/gcc/ada/libgnat/a-strunb__shared.adb b/gcc/ada/libgnat/a-strunb__shared.adb
index 54a2932..506b614 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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,11 +50,13 @@ package body Ada.Strings.Unbounded is
-- align the returned memory on the maximum alignment as malloc does not
-- know the target alignment.
- function Aligned_Max_Length (Max_Length : Natural) return Natural;
+ function Aligned_Max_Length
+ (Required_Length : Natural;
+ Reserved_Length : Natural) return Natural;
-- Returns recommended length of the shared string which is greater or
- -- equal to specified length. Calculation take in sense alignment of the
- -- allocated memory segments to use memory effectively by Append/Insert/etc
- -- operations.
+ -- equal to specified required length and desired reserved length.
+ -- Calculation takes into account alignment of the 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
@@ -63,11 +65,6 @@ package body Ada.Strings.Unbounded is
-- 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.
-
---------
-- "&" --
---------
@@ -490,17 +487,24 @@ package body Ada.Strings.Unbounded is
-- Aligned_Max_Length --
------------------------
- function Aligned_Max_Length (Max_Length : Natural) return Natural is
+ function Aligned_Max_Length
+ (Required_Length : Natural;
+ Reserved_Length : Natural) return Natural
+ is
Static_Size : constant Natural :=
Empty_Shared_String'Size / Standard'Storage_Unit;
-- Total size of all Shared_String static components
begin
- if Max_Length > Natural'Last - Static_Size then
+ if Required_Length > Natural'Last - Static_Size - Reserved_Length then
+ -- Total requested length is larger than maximum possible length.
+ -- Use of Static_Size needed to avoid overflows in expression to
+ -- compute aligned length.
return Natural'Last;
+
else
return
- ((Static_Size + Max_Length - 1) / Min_Mul_Alloc + 2) * Min_Mul_Alloc
- - Static_Size;
+ ((Static_Size + Required_Length + Reserved_Length - 1)
+ / Min_Mul_Alloc + 2) * Min_Mul_Alloc - Static_Size;
end if;
end Aligned_Max_Length;
@@ -509,35 +513,21 @@ package body Ada.Strings.Unbounded is
--------------
function Allocate
- (Max_Length : Natural) return not null Shared_String_Access
+ (Required_Length : Natural;
+ Reserved_Length : Natural := 0) return not null Shared_String_Access
is
begin
-- Empty string requested, return shared empty string
- if Max_Length = 0 then
+ if Required_Length = 0 then
return Empty_Shared_String'Access;
-- Otherwise, allocate requested space (and probably some more room)
else
- return new Shared_String (Aligned_Max_Length (Max_Length));
- 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);
+ return
+ new Shared_String
+ (Aligned_Max_Length (Required_Length, Reserved_Length));
end if;
end Allocate;
@@ -657,7 +647,7 @@ package body Ada.Strings.Unbounded is
System.Atomic_Counters.Is_One (Item.Counter)
and then Item.Max_Length >= Length
and then Item.Max_Length <=
- Aligned_Max_Length (Length + Length / Growth_Factor);
+ Aligned_Max_Length (Length, Length / Growth_Factor);
end Can_Be_Reused;
-----------
@@ -1301,7 +1291,8 @@ package body Ada.Strings.Unbounded is
---------------
procedure Put_Image
- (S : in out Ada.Strings.Text_Output.Sink'Class; V : Unbounded_String) is
+ (S : in out Ada.Strings.Text_Buffers.Root_Buffer_Type'Class;
+ V : Unbounded_String) is
begin
String'Put_Image (S, To_String (V));
end Put_Image;
diff --git a/gcc/ada/libgnat/a-strunb__shared.ads b/gcc/ada/libgnat/a-strunb__shared.ads
index 2cd8166..2091bde 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, 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 --
@@ -78,7 +78,7 @@ pragma Assertion_Policy (Pre => Ignore);
with Ada.Strings.Maps;
private with Ada.Finalization;
private with System.Atomic_Counters;
-private with Ada.Strings.Text_Output;
+private with Ada.Strings.Text_Buffers;
package Ada.Strings.Unbounded with
Initial_Condition => Length (Null_Unbounded_String) = 0
@@ -363,9 +363,8 @@ is
Going : Direction := Forward;
Mapping : Maps.Character_Mapping := Maps.Identity) return Natural
with
- Pre => (if Length (Source) /= 0
- then From <= Length (Source))
- and then Pattern'Length /= 0,
+ Pre => (if Length (Source) /= 0 then From <= Length (Source))
+ and then Pattern'Length /= 0,
Global => null;
pragma Ada_05 (Index);
@@ -376,11 +375,9 @@ is
Going : Direction := Forward;
Mapping : Maps.Character_Mapping_Function) return Natural
with
- Pre => (if Length (Source) /= 0
- then From <= Length (Source))
- and then Pattern'Length /= 0,
+ Pre => (if Length (Source) /= 0 then From <= Length (Source))
+ and then Pattern'Length /= 0,
Global => null;
-
pragma Ada_05 (Index);
function Index
@@ -725,10 +722,12 @@ private
-- store string with specified length effectively.
function Allocate
- (Max_Length : Natural) return not null Shared_String_Access;
- -- Allocates new Shared_String with at least specified maximum length.
- -- Actual maximum length of the allocated Shared_String can be slightly
- -- greater. Returns reference to Empty_Shared_String when requested length
+ (Required_Length : Natural;
+ Reserved_Length : Natural := 0) return not null Shared_String_Access;
+ -- Allocates new Shared_String. Actual maximum length of allocated object
+ -- is at least the specified required length. Additional storage is
+ -- allocated to allow to store up to the specified reserved length when
+ -- possible. Returns reference to Empty_Shared_String when requested length
-- is zero.
Empty_Shared_String : aliased Shared_String (0);
@@ -742,7 +741,8 @@ private
end record with Put_Image => Put_Image;
procedure Put_Image
- (S : in out Ada.Strings.Text_Output.Sink'Class; V : Unbounded_String);
+ (S : in out Ada.Strings.Text_Buffers.Root_Buffer_Type'Class;
+ V : Unbounded_String);
pragma Stream_Convert (Unbounded_String, To_Unbounded, To_String);
-- Provide stream routines without dragging in Ada.Streams
diff --git a/gcc/ada/libgnat/a-ststbo.adb b/gcc/ada/libgnat/a-ststbo.adb
index 16c6d00..59dec1c 100644
--- a/gcc/ada/libgnat/a-ststbo.adb
+++ b/gcc/ada/libgnat/a-ststbo.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2020-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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-ststbo.ads b/gcc/ada/libgnat/a-ststbo.ads
index fe41c2c..0cece80 100644
--- a/gcc/ada/libgnat/a-ststbo.ads
+++ b/gcc/ada/libgnat/a-ststbo.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2020-2021, 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-ststio.adb b/gcc/ada/libgnat/a-ststio.adb
index 5ed5e00..176dabf 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 71482a4..22f37f9 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, 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
index cf3a250..9b4cc61 100644
--- a/gcc/ada/libgnat/a-ststun.adb
+++ b/gcc/ada/libgnat/a-ststun.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2020-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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-ststun.ads b/gcc/ada/libgnat/a-ststun.ads
index 2945bca..3d00e7f 100644
--- a/gcc/ada/libgnat/a-ststun.ads
+++ b/gcc/ada/libgnat/a-ststun.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2020-2021, 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-sttebu.adb b/gcc/ada/libgnat/a-sttebu.adb
new file mode 100644
index 0000000..bc0c6ce
--- /dev/null
+++ b/gcc/ada/libgnat/a-sttebu.adb
@@ -0,0 +1,121 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- ADA.STRINGS.TEXT_BUFFERS --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 2020-2021, Free Software Foundation, Inc. --
+-- --
+-- GNAT is 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_Strings;
+with Ada.Strings.UTF_Encoding.Wide_Wide_Strings;
+
+package body Ada.Strings.Text_Buffers is
+ function Current_Indent
+ (Buffer : Root_Buffer_Type) return Text_Buffer_Count is
+ (Text_Buffer_Count (Buffer.Indentation));
+
+ procedure Increase_Indent
+ (Buffer : in out Root_Buffer_Type;
+ Amount : Text_Buffer_Count := Standard_Indent)
+ is
+ begin
+ Buffer.Indentation := @ + Natural (Amount);
+ end Increase_Indent;
+
+ procedure Decrease_Indent
+ (Buffer : in out Root_Buffer_Type;
+ Amount : Text_Buffer_Count := Standard_Indent)
+ is
+ begin
+ Buffer.Indentation := @ - Natural (Amount);
+ end Decrease_Indent;
+
+ package body Output_Mapping is
+ -- Implement indentation in Put_UTF_8 and New_Line.
+ -- Implement other output procedures using Put_UTF_8.
+
+ procedure Put (Buffer : in out Buffer_Type; Item : String) is
+ begin
+ Put_UTF_8 (Buffer, Item);
+ end Put;
+
+ procedure Wide_Put (Buffer : in out Buffer_Type; Item : Wide_String) is
+ begin
+ Buffer.All_8_Bits :=
+ @ and then
+ (for all WChar of Item => Wide_Character'Pos (WChar) < 256);
+
+ Put_UTF_8 (Buffer, UTF_Encoding.Wide_Strings.Encode (Item));
+ end Wide_Put;
+
+ procedure Wide_Wide_Put
+ (Buffer : in out Buffer_Type; Item : Wide_Wide_String)
+ is
+ begin
+ Buffer.All_8_Bits :=
+ @ and then
+ (for all WWChar of Item => Wide_Wide_Character'Pos (WWChar) < 256);
+
+ Put_UTF_8 (Buffer, UTF_Encoding.Wide_Wide_Strings.Encode (Item));
+ end Wide_Wide_Put;
+
+ procedure Put_UTF_8
+ (Buffer : in out Buffer_Type;
+ Item : UTF_Encoding.UTF_8_String) is
+ begin
+ if Item'Length = 0 then
+ return;
+ end if;
+
+ if Buffer.Indent_Pending then
+ Buffer.Indent_Pending := False;
+ if Buffer.Indentation > 0 then
+ Put_UTF_8_Implementation
+ (Buffer, (1 .. Buffer.Indentation => ' '));
+ end if;
+ end if;
+
+ Put_UTF_8_Implementation (Buffer, Item);
+ end Put_UTF_8;
+
+ procedure Wide_Put_UTF_16
+ (Buffer : in out Buffer_Type; Item : UTF_Encoding.UTF_16_Wide_String)
+ is
+ begin
+ Wide_Wide_Put (Buffer, UTF_Encoding.Wide_Wide_Strings.Decode (Item));
+ end Wide_Put_UTF_16;
+
+ procedure New_Line (Buffer : in out Buffer_Type) is
+ begin
+ Buffer.Indent_Pending := False; -- just for a moment
+ Put (Buffer, (1 => ASCII.LF));
+ Buffer.Indent_Pending := True;
+ Buffer.UTF_8_Column := 1;
+ end New_Line;
+
+ end Output_Mapping;
+
+end Ada.Strings.Text_Buffers;
diff --git a/gcc/ada/libgnat/a-sttebu.ads b/gcc/ada/libgnat/a-sttebu.ads
new file mode 100644
index 0000000..39144a6
--- /dev/null
+++ b/gcc/ada/libgnat/a-sttebu.ads
@@ -0,0 +1,136 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- ADA.STRINGS.TEXT_BUFFERS --
+-- --
+-- S p e c --
+-- --
+-- This specification is derived from the Ada Reference Manual for use with --
+-- GNAT. In accordance with the copyright of that document, you can freely --
+-- copy and modify this specification, provided that if you redistribute a --
+-- modified version, any changes that you have made are clearly indicated. --
+-- --
+------------------------------------------------------------------------------
+
+with Ada.Strings.UTF_Encoding;
+package Ada.Strings.Text_Buffers with
+ Pure
+is
+
+ type Text_Buffer_Count is range 0 .. Integer'Last;
+
+ New_Line_Count : constant Text_Buffer_Count := 1;
+ -- There is no support for two-character CR/LF line endings.
+
+ type Root_Buffer_Type is abstract tagged limited private with
+ Default_Initial_Condition => Current_Indent (Root_Buffer_Type) = 0;
+
+ procedure Put (Buffer : in out Root_Buffer_Type; Item : String) is abstract;
+
+ procedure Wide_Put
+ (Buffer : in out Root_Buffer_Type; Item : Wide_String) is abstract;
+
+ procedure Wide_Wide_Put
+ (Buffer : in out Root_Buffer_Type; Item : Wide_Wide_String) is abstract;
+
+ procedure Put_UTF_8
+ (Buffer : in out Root_Buffer_Type;
+ Item : UTF_Encoding.UTF_8_String) is abstract;
+
+ procedure Wide_Put_UTF_16
+ (Buffer : in out Root_Buffer_Type;
+ Item : UTF_Encoding.UTF_16_Wide_String) is abstract;
+
+ procedure New_Line (Buffer : in out Root_Buffer_Type) is abstract;
+
+ Standard_Indent : constant Text_Buffer_Count := 3;
+
+ function Current_Indent
+ (Buffer : Root_Buffer_Type) return Text_Buffer_Count;
+
+ procedure Increase_Indent
+ (Buffer : in out Root_Buffer_Type;
+ Amount : Text_Buffer_Count := Standard_Indent) with
+ Post'Class => Current_Indent (Buffer) =
+ Current_Indent (Buffer)'Old + Amount;
+
+ procedure Decrease_Indent
+ (Buffer : in out Root_Buffer_Type;
+ Amount : Text_Buffer_Count := Standard_Indent) with
+ Pre'Class => Current_Indent (Buffer) >= Amount
+ -- or else raise Constraint_Error,
+ or else Boolean'Val (Current_Indent (Buffer) - Amount),
+ Post'Class => Current_Indent (Buffer) =
+ Current_Indent (Buffer)'Old - Amount;
+
+private
+
+ type Root_Buffer_Type is abstract tagged limited record
+ Indentation : Natural := 0;
+ -- Current indentation
+
+ Indent_Pending : Boolean := True;
+ -- Set by calls to New_Line, cleared when indentation emitted.
+
+ UTF_8_Length : Natural := 0;
+ -- Count of UTF_8 characters in the buffer
+
+ UTF_8_Column : Positive := 1;
+ -- Column in which next character will be written.
+ -- Calling New_Line resets to 1.
+
+ All_7_Bits : Boolean := True;
+ -- True if all characters seen so far fit in 7 bits
+ All_8_Bits : Boolean := True;
+ -- True if all characters seen so far fit in 8 bits
+
+ end record;
+
+ generic
+ -- This generic allows a client to extend Root_Buffer_Type without
+ -- having to implement any of the abstract subprograms other than
+ -- Put_UTF_8 (i.e., Put, Wide_Put, Wide_Wide_Put, Wide_Put_UTF_16,
+ -- and New_Line). Without this generic, each client would have to
+ -- duplicate the implementations of those 5 subprograms.
+ -- This generic also takes care of handling indentation, thereby
+ -- avoiding further code duplication. The name "Output_Mapping" isn't
+ -- wonderful, but it refers to the idea that this package knows how
+ -- to implement all the other output operations in terms of
+ -- just Put_UTF_8.
+ --
+ -- The classwide parameter type here is somewhat tricky;
+ -- there are no dispatching calls associated with this parameter.
+ -- It would be more accurate to say that the parameter is of type
+ -- Output_Mapping.Buffer_Type'Class, but that type hasn't been declared
+ -- yet. Instantiators will typically declare a non-abstract extension,
+ -- B2, of the buffer type, B1, declared in their instantiation. The
+ -- actual Put_UTF_8_Implementation parameter may then have a
+ -- precondition "Buffer in B2'Class" and that subprogram can safely
+ -- access components declared as part of the declaration of B2.
+
+ with procedure Put_UTF_8_Implementation
+ (Buffer : in out Root_Buffer_Type'Class;
+ Item : UTF_Encoding.UTF_8_String);
+ package Output_Mapping is
+ type Buffer_Type is abstract new Root_Buffer_Type with null record;
+
+ overriding procedure Put (Buffer : in out Buffer_Type; Item : String);
+
+ overriding procedure Wide_Put
+ (Buffer : in out Buffer_Type; Item : Wide_String);
+
+ overriding procedure Wide_Wide_Put
+ (Buffer : in out Buffer_Type; Item : Wide_Wide_String);
+
+ overriding procedure Put_UTF_8
+ (Buffer : in out Buffer_Type;
+ Item : UTF_Encoding.UTF_8_String);
+
+ overriding procedure Wide_Put_UTF_16
+ (Buffer : in out Buffer_Type; Item : UTF_Encoding.UTF_16_Wide_String);
+
+ overriding procedure New_Line (Buffer : in out Buffer_Type);
+ end Output_Mapping;
+
+end Ada.Strings.Text_Buffers;
diff --git a/gcc/ada/libgnat/a-stteou.ads b/gcc/ada/libgnat/a-stteou.ads
deleted file mode 100644
index 9eaf98a..0000000
--- a/gcc/ada/libgnat/a-stteou.ads
+++ /dev/null
@@ -1,193 +0,0 @@
-------------------------------------------------------------------------------
--- --
--- 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 Pure 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.
- --
- -- Users are not expected to extend type Sink.
- --
- -- 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
- -- 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 with Storage_Size => 0;
- 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 a0e2eda..28aee55 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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,11 +52,17 @@ package body Ada.Strings.Unbounded.Aux is
-- Set_String --
----------------
- procedure Set_String (UP : in out Unbounded_String; S : String_Access) is
+ procedure Set_String
+ (U : out Unbounded_String;
+ Length : Positive;
+ Set : not null access procedure (S : out String))
+ is
+ Old : String_Access := U.Reference;
begin
- Finalize (UP);
- UP.Reference := S;
- UP.Last := UP.Reference'Length;
+ U.Last := Length;
+ U.Reference := new String (1 .. Length);
+ Set (U.Reference.all);
+ Free (Old);
end Set_String;
end Ada.Strings.Unbounded.Aux;
diff --git a/gcc/ada/libgnat/a-stunau.ads b/gcc/ada/libgnat/a-stunau.ads
index bac37ef..f313187 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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,22 +56,24 @@ package Ada.Strings.Unbounded.Aux is
S : out Big_String_Access;
L : out Natural);
pragma Inline (Get_String);
- -- This procedure returns the internal string pointer used in the
- -- representation of an unbounded string as well as the actual current
- -- length (which may be less than S.all'Length because in general there
- -- can be extra space assigned). The characters of this string may be
- -- not be modified via the returned pointer, and are valid only as
- -- long as the original unbounded string is not accessed or modified.
+ -- Return the internal string pointer used in the representation of an
+ -- unbounded string as well as the actual current length (which may be less
+ -- than S.all'Length because in general there can be extra space assigned).
+ -- The characters of this string may be not be modified via the returned
+ -- pointer, and are valid only as long as the original unbounded string is
+ -- not accessed or modified.
--
-- This procedure is much more efficient than the use of To_String
-- since it avoids the need to copy the string. The lower bound of the
-- referenced string returned by this call is always one, so the actual
-- string data is always accessible as S (1 .. L).
- procedure Set_String (UP : in out Unbounded_String; S : String_Access);
+ procedure Set_String
+ (U : out Unbounded_String;
+ Length : Positive;
+ Set : not null access procedure (S : out String));
pragma Inline (Set_String);
- -- This version of Set_Unbounded_String takes a string access value, rather
- -- than a string. The lower bound of the string value is required to be
- -- one, and this requirement is not checked.
+ -- Create an unbounded string U with the given Length, using Set to fill
+ -- the contents of U.
end Ada.Strings.Unbounded.Aux;
diff --git a/gcc/ada/libgnat/a-stunau__shared.adb b/gcc/ada/libgnat/a-stunau__shared.adb
index 5f903f1..3160e14 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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,12 +51,30 @@ package body Ada.Strings.Unbounded.Aux is
-- Set_String --
----------------
- procedure Set_String (UP : in out Unbounded_String; S : String_Access) is
- X : String_Access := S;
-
+ procedure Set_String
+ (U : out Unbounded_String;
+ Length : Positive;
+ Set : not null access procedure (S : out String))
+ is
+ TR : constant Shared_String_Access := U.Reference;
+ DR : Shared_String_Access;
begin
- Set_Unbounded_String (UP, S.all);
- Free (X);
+ -- Try to reuse existing shared string
+
+ if Can_Be_Reused (TR, Length) then
+ Reference (TR);
+ DR := TR;
+
+ -- Otherwise allocate new shared string
+
+ else
+ DR := Allocate (Length);
+ U.Reference := DR;
+ end if;
+
+ Set (DR.Data (1 .. Length));
+ DR.Last := Length;
+ Unreference (TR);
end Set_String;
end Ada.Strings.Unbounded.Aux;
diff --git a/gcc/ada/libgnat/a-stunha.adb b/gcc/ada/libgnat/a-stunha.adb
index e92ad27..32f4e6d 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 d6654b2..04321a6 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2010-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 46e1b41..f045a3c 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 ba35134..9b3d0ad 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, 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 05e58e9..456e907 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 b25614a..d02b641 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 1cc7d67..09b192f 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 24c6bb84..fba510a 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, 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 f93c5cb..e9ce76c 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 0573157..3d3ef63 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 8c343fe..b81be14 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2003-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 387e012..9761bcc 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2003-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 912af42..269c8c9 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 00d5c3d..40f2796 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, 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 b61139b1..1d0521c 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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 Ada.Strings.Wide_Unbounded is
Reference (Empty_Shared_Wide_String'Access);
DR := Empty_Shared_Wide_String'Access;
- -- Left string is empty, return Rigth string
+ -- Left string is empty, return Right string
elsif LR.Last = 0 then
Reference (RR);
diff --git a/gcc/ada/libgnat/a-stwiun__shared.ads b/gcc/ada/libgnat/a-stwiun__shared.ads
index 3d29939..a88c4ec 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, 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 60afeec..cbf3f5e 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 f5bbcf3..d49d577 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, 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 ea97b13..55599ea 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 c055de6..091bdfe 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2009-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 2e1cd5d..b2c9ee5 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 9cfa5ed..14650da 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, 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 9982b75..3d990c9 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 bdd27d5..1eb7ad4 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 e4558e5..92790a1 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2003-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 b128010..24ab18c 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2003-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 f32b3ed..5bd5408 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 7ee8a56..8ef5cb6 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, 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 86bed5c..99a545e 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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 Ada.Strings.Wide_Wide_Unbounded is
Reference (Empty_Shared_Wide_Wide_String'Access);
DR := Empty_Shared_Wide_Wide_String'Access;
- -- Left string is empty, return Rigth string
+ -- Left string is empty, return Right string
elsif LR.Last = 0 then
Reference (RR);
diff --git a/gcc/ada/libgnat/a-stzunb__shared.ads b/gcc/ada/libgnat/a-stzunb__shared.ads
index 5079d63..8a7fd5c 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, 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 4336538..c64dcb1 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2011-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 6578191..7aaccb7 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2011-2021, 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 0b10a63..c135358 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2010-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 ff730e8..8ac078c 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2010-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 25a671a..7acabb4 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2010-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 951a171..389709e 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2010-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 98de7a1..7af768b 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2011-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 20aa236..d8d8495 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2011-2021, 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 10df730..b201ad4 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2011-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 174ec4b..e77faa3 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2011-2021, 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 28d8435..7c7b735 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1997-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 fda5b3c..34b8016 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1997-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 fc28aaa..6bb8e03 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1997-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 7ad420c..6c9a5bf 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 9e71851..0f92502 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, 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 e77a34c..e6e9ed9 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 a2bf6d1..de76b79 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 16ffd82..87eb9f0 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 2ff28b0..9276942 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 e664d3d..8149ba6 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1997-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 6eb9e58..0dd04c4 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1997-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 96680e2..165c97e 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1997-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 e6f6936..292e566 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 eaaf116..82f0a6b 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, 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 f9c263e..744190e 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 2795dbe..8a8ed81 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 fcd14eb..980fb8b 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 00cad7c..8958154 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 239d319..bccaf09 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1997-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 0e7f1f5..53297ef 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1997-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 9f486e2..c506a3c 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1997-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 7138f76..c6a9d25 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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.ads b/gcc/ada/libgnat/a-tags.ads
index 203f7ca..0c9afff 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, 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-teioed.adb b/gcc/ada/libgnat/a-teioed.adb
index f3b0928..6f198e5 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 273291e..110b613 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, 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 b36d28b..717f529 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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,15 +171,15 @@ is
-- is required (RM A.10.3(23)) but it seems reasonable, and besides
-- ACVC test CE3208A expects this behavior.
- if File_Type (File) = Current_In then
+ if File = Current_In then
Current_In := null;
- elsif File_Type (File) = Current_Out then
+ elsif File = Current_Out then
Current_Out := null;
- elsif File_Type (File) = Current_Err then
+ elsif File = Current_Err then
Current_Err := null;
end if;
- Terminate_Line (File_Type (File));
+ Terminate_Line (File.all'Access);
end AFCB_Close;
---------------
@@ -187,10 +187,9 @@ is
---------------
procedure AFCB_Free (File : not null access Text_AFCB) is
- type FCB_Ptr is access all Text_AFCB;
- FT : FCB_Ptr := FCB_Ptr (File);
+ FT : File_Type := File.all'Access;
- procedure Free is new Ada.Unchecked_Deallocation (Text_AFCB, FCB_Ptr);
+ procedure Free is new Ada.Unchecked_Deallocation (Text_AFCB, File_Type);
begin
Free (FT);
diff --git a/gcc/ada/libgnat/a-textio.ads b/gcc/ada/libgnat/a-textio.ads
index 36a4b65..a06a35c 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, 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 --
@@ -85,9 +85,6 @@ is
-- Line and page length
subtype Field is Integer range 0 .. 255;
- -- Note: if for any reason, there is a need to increase this value, then it
- -- will be necessary to change the corresponding value in System.Img_Real
- -- in file s-imgrea.adb.
subtype Number_Base is Integer range 2 .. 16;
@@ -718,7 +715,7 @@ private
-- Returns the system-specific character indicating the end of a text file.
-- This is exported for use by child packages such as Enumeration_Aux to
-- eliminate their needing to depend directly on Interfaces.C_Streams,
- -- which is not available in certain target environments (such as AAMP).
+ -- which might not be available in certain target environments.
procedure Initialize_Standard_Files;
-- Initializes the file control blocks for the standard files. Called from
diff --git a/gcc/ada/libgnat/a-tiboio.adb b/gcc/ada/libgnat/a-tiboio.adb
index e212356..340199c 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1997-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 cf94305..1fa9364 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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,6 @@
with Ada.Text_IO.Generic_Aux; use Ada.Text_IO.Generic_Aux;
-with System.Img_Real; use System.Img_Real;
-
package body Ada.Text_IO.Complex_Aux is
---------
@@ -171,9 +169,9 @@ package body Ada.Text_IO.Complex_Aux is
-- Both parts are initially converted with a Fore of 0
Rptr := 0;
- Set_Image_Real (Long_Long_Float (ItemR), R_String, Rptr, 0, Aft, Exp);
+ Aux.Set_Image (ItemR, R_String, Rptr, 0, Aft, Exp);
Iptr := 0;
- Set_Image_Real (Long_Long_Float (ItemI), I_String, Iptr, 0, Aft, Exp);
+ Aux.Set_Image (ItemI, I_String, Iptr, 0, Aft, Exp);
-- Check room for both parts plus parens plus comma (RM G.1.3(34))
diff --git a/gcc/ada/libgnat/a-ticoau.ads b/gcc/ada/libgnat/a-ticoau.ads
index 22555cf..2b5ea66 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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,7 @@ private generic
type Num is digits <>;
- with package Aux is new Ada.Text_IO.Float_Aux (Num, <>);
+ with package Aux is new Ada.Text_IO.Float_Aux (Num, <>, <>);
package Ada.Text_IO.Complex_Aux is
diff --git a/gcc/ada/libgnat/a-ticoio.adb b/gcc/ada/libgnat/a-ticoio.adb
index e35a745..a94c826 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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,6 +31,9 @@
with Ada.Text_IO.Complex_Aux;
with Ada.Text_IO.Float_Aux;
+with System.Img_Flt; use System.Img_Flt;
+with System.Img_LFlt; use System.Img_LFlt;
+with System.Img_LLF; use System.Img_LLF;
with System.Val_Flt; use System.Val_Flt;
with System.Val_LFlt; use System.Val_LFlt;
with System.Val_LLF; use System.Val_LLF;
@@ -40,22 +43,24 @@ package body Ada.Text_IO.Complex_IO is
use Complex_Types;
package Scalar_Float is new
- Ada.Text_IO.Float_Aux (Float, Scan_Float);
+ Ada.Text_IO.Float_Aux (Float, Scan_Float, Set_Image_Float);
package Scalar_Long_Float is new
- Ada.Text_IO.Float_Aux (Long_Float, Scan_Long_Float);
+ Ada.Text_IO.Float_Aux
+ (Long_Float, Scan_Long_Float, Set_Image_Long_Float);
package Scalar_Long_Long_Float is new
- Ada.Text_IO.Float_Aux (Long_Long_Float, Scan_Long_Long_Float);
+ Ada.Text_IO.Float_Aux
+ (Long_Long_Float, Scan_Long_Long_Float, Set_Image_Long_Long_Float);
package Aux_Float is new
- Ada.Text_IO.Complex_Aux (Float, Scalar_Float);
+ Ada.Text_IO.Complex_Aux (Float, Scalar_Float);
package Aux_Long_Float is new
- Ada.Text_IO.Complex_Aux (Long_Float, Scalar_Long_Float);
+ Ada.Text_IO.Complex_Aux (Long_Float, Scalar_Long_Float);
package Aux_Long_Long_Float is new
- Ada.Text_IO.Complex_Aux (Long_Long_Float, Scalar_Long_Long_Float);
+ Ada.Text_IO.Complex_Aux (Long_Long_Float, Scalar_Long_Long_Float);
-- Throughout this generic body, we distinguish between the case where type
-- Float is OK, where type Long_Float is OK and where type Long_Long_Float
diff --git a/gcc/ada/libgnat/a-ticoio.ads b/gcc/ada/libgnat/a-ticoio.ads
index b0e3d8c..1463478 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, 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 ac751c1..9be119d 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 522e351..469e7c9 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 f71cf2d..5987d71 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 83e72aa..3d9a4f2 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, 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-tideio__128.adb b/gcc/ada/libgnat/a-tideio__128.adb
index a8cdf9f..76c69e2 100644
--- a/gcc/ada/libgnat/a-tideio__128.adb
+++ b/gcc/ada/libgnat/a-tideio__128.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2020-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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.adb b/gcc/ada/libgnat/a-tienau.adb
index 87dce4b..af30fef 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 27b15c1..f1a8ea7 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 adc93db..c64d713 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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-tifiau.adb b/gcc/ada/libgnat/a-tifiau.adb
index c6f4430..baec136 100644
--- a/gcc/ada/libgnat/a-tifiau.adb
+++ b/gcc/ada/libgnat/a-tifiau.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2020-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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-tifiau.ads b/gcc/ada/libgnat/a-tifiau.ads
index 32701c5..6ce8b2c 100644
--- a/gcc/ada/libgnat/a-tifiau.ads
+++ b/gcc/ada/libgnat/a-tifiau.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2020-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 412740e..d51abb4 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -158,16 +158,17 @@ with Ada.Text_IO.Fixed_Aux;
with Ada.Text_IO.Float_Aux;
with System.Img_Fixed_32; use System.Img_Fixed_32;
with System.Img_Fixed_64; use System.Img_Fixed_64;
+with System.Img_LFlt; use System.Img_LFlt;
with System.Val_Fixed_32; use System.Val_Fixed_32;
with System.Val_Fixed_64; use System.Val_Fixed_64;
-with System.Val_LLF; use System.Val_LLF;
+with System.Val_LFlt; use System.Val_LFlt;
package body Ada.Text_IO.Fixed_IO with SPARK_Mode => Off is
-- Note: we still use the floating-point I/O routines for types whose small
-- is not the ratio of two sufficiently small integers. This will result in
-- inaccuracies for fixed point types that require more precision than is
- -- available in Long_Long_Float.
+ -- available in Long_Float.
subtype Int32 is Interfaces.Integer_32; use type Int32;
subtype Int64 is Interfaces.Integer_64; use type Int64;
@@ -178,8 +179,8 @@ package body Ada.Text_IO.Fixed_IO with SPARK_Mode => Off is
package Aux64 is new
Ada.Text_IO.Fixed_Aux (Int64, Scan_Fixed64, Set_Image_Fixed64);
- package Aux_Long_Long_Float is new
- Ada.Text_IO.Float_Aux (Long_Long_Float, Scan_Long_Long_Float);
+ package Aux_Long_Float is new
+ Ada.Text_IO.Float_Aux (Long_Float, Scan_Long_Float, Set_Image_Long_Float);
-- Throughout this generic body, we distinguish between the case where type
-- Int32 is OK and where type Int64 is OK. These boolean constants are used
@@ -283,7 +284,7 @@ package body Ada.Text_IO.Fixed_IO with SPARK_Mode => Off is
-Num'Small_Numerator,
-Num'Small_Denominator));
else
- Aux_Long_Long_Float.Get (File, Long_Long_Float (Item), Width);
+ Aux_Long_Float.Get (File, Long_Float (Item), Width);
end if;
exception
@@ -317,7 +318,7 @@ package body Ada.Text_IO.Fixed_IO with SPARK_Mode => Off is
-Num'Small_Numerator,
-Num'Small_Denominator));
else
- Aux_Long_Long_Float.Gets (From, Long_Long_Float (Item), Last);
+ Aux_Long_Float.Gets (From, Long_Float (Item), Last);
end if;
exception
@@ -345,8 +346,7 @@ package body Ada.Text_IO.Fixed_IO with SPARK_Mode => Off is
-Num'Small_Numerator, -Num'Small_Denominator,
For0, Num'Aft);
else
- Aux_Long_Long_Float.Put
- (File, Long_Long_Float (Item), Fore, Aft, Exp);
+ Aux_Long_Float.Put (File, Long_Float (Item), Fore, Aft, Exp);
end if;
end Put;
@@ -376,7 +376,7 @@ package body Ada.Text_IO.Fixed_IO with SPARK_Mode => Off is
-Num'Small_Numerator, -Num'Small_Denominator,
For0, Num'Aft);
else
- Aux_Long_Long_Float.Puts (To, Long_Long_Float (Item), Aft, Exp);
+ Aux_Long_Float.Puts (To, Long_Float (Item), Aft, Exp);
end if;
end Put;
diff --git a/gcc/ada/libgnat/a-tifiio__128.adb b/gcc/ada/libgnat/a-tifiio__128.adb
index f50e4c9..b161e89 100644
--- a/gcc/ada/libgnat/a-tifiio__128.adb
+++ b/gcc/ada/libgnat/a-tifiio__128.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2020-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -159,17 +159,18 @@ with Ada.Text_IO.Float_Aux;
with System.Img_Fixed_32; use System.Img_Fixed_32;
with System.Img_Fixed_64; use System.Img_Fixed_64;
with System.Img_Fixed_128; use System.Img_Fixed_128;
+with System.Img_LFlt; use System.Img_LFlt;
with System.Val_Fixed_32; use System.Val_Fixed_32;
with System.Val_Fixed_64; use System.Val_Fixed_64;
with System.Val_Fixed_128; use System.Val_Fixed_128;
-with System.Val_LLF; use System.Val_LLF;
+with System.Val_LFlt; use System.Val_LFlt;
package body Ada.Text_IO.Fixed_IO with SPARK_Mode => Off is
-- Note: we still use the floating-point I/O routines for types whose small
-- is not the ratio of two sufficiently small integers. This will result in
-- inaccuracies for fixed point types that require more precision than is
- -- available in Long_Long_Float.
+ -- available in Long_Float.
subtype Int32 is Interfaces.Integer_32; use type Int32;
subtype Int64 is Interfaces.Integer_64; use type Int64;
@@ -184,8 +185,8 @@ package body Ada.Text_IO.Fixed_IO with SPARK_Mode => Off is
package Aux128 is new
Ada.Text_IO.Fixed_Aux (Int128, Scan_Fixed128, Set_Image_Fixed128);
- package Aux_Long_Long_Float is new
- Ada.Text_IO.Float_Aux (Long_Long_Float, Scan_Long_Long_Float);
+ package Aux_Long_Float is new
+ Ada.Text_IO.Float_Aux (Long_Float, Scan_Long_Float, Set_Image_Long_Float);
-- Throughout this generic body, we distinguish between the case where type
-- Int32 is OK, where type Int64 is OK and where type Int128 is OK. These
@@ -323,7 +324,7 @@ package body Ada.Text_IO.Fixed_IO with SPARK_Mode => Off is
-Num'Small_Numerator,
-Num'Small_Denominator));
else
- Aux_Long_Long_Float.Get (File, Long_Long_Float (Item), Width);
+ Aux_Long_Float.Get (File, Long_Float (Item), Width);
end if;
exception
@@ -362,7 +363,7 @@ package body Ada.Text_IO.Fixed_IO with SPARK_Mode => Off is
-Num'Small_Numerator,
-Num'Small_Denominator));
else
- Aux_Long_Long_Float.Gets (From, Long_Long_Float (Item), Last);
+ Aux_Long_Float.Gets (From, Long_Float (Item), Last);
end if;
exception
@@ -394,8 +395,7 @@ package body Ada.Text_IO.Fixed_IO with SPARK_Mode => Off is
-Num'Small_Numerator, -Num'Small_Denominator,
For0, Num'Aft);
else
- Aux_Long_Long_Float.Put
- (File, Long_Long_Float (Item), Fore, Aft, Exp);
+ Aux_Long_Float.Put (File, Long_Float (Item), Fore, Aft, Exp);
end if;
end Put;
@@ -429,7 +429,7 @@ package body Ada.Text_IO.Fixed_IO with SPARK_Mode => Off is
-Num'Small_Numerator, -Num'Small_Denominator,
For0, Num'Aft);
else
- Aux_Long_Long_Float.Puts (To, Long_Long_Float (Item), Aft, Exp);
+ Aux_Long_Float.Puts (To, Long_Float (Item), Aft, Exp);
end if;
end Put;
diff --git a/gcc/ada/libgnat/a-tiflau.adb b/gcc/ada/libgnat/a-tiflau.adb
index 4955a99..fa10f3f 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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 @@
with Ada.Text_IO.Generic_Aux; use Ada.Text_IO.Generic_Aux;
-with System.Img_Real; use System.Img_Real;
+with System.Img_Util; use System.Img_Util;
package body Ada.Text_IO.Float_Aux is
@@ -96,7 +96,7 @@ package body Ada.Text_IO.Float_Aux is
Ptr : Natural := 0;
begin
- Set_Image_Real (Long_Long_Float (Item), Buf, Ptr, Fore, Aft, Exp);
+ Set_Image (Item, Buf, Ptr, Fore, Aft, Exp);
Put_Item (File, Buf (1 .. Ptr));
end Put;
@@ -114,8 +114,7 @@ package body Ada.Text_IO.Float_Aux is
Ptr : Natural := 0;
begin
- Set_Image_Real
- (Long_Long_Float (Item), Buf, Ptr, Fore => 1, Aft => Aft, Exp => Exp);
+ Set_Image (Item, Buf, Ptr, Fore => 1, Aft => Aft, Exp => Exp);
if Ptr > To'Length then
raise Layout_Error;
diff --git a/gcc/ada/libgnat/a-tiflau.ads b/gcc/ada/libgnat/a-tiflau.ads
index 2dfe76d..a095846 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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,14 @@ private generic
Ptr : not null access Integer;
Max : Integer) return Num;
+ with procedure Set_Image
+ (V : Num;
+ S : in out String;
+ P : in out Natural;
+ Fore : Natural;
+ Aft : Natural;
+ Exp : Natural);
+
package Ada.Text_IO.Float_Aux is
procedure Get
diff --git a/gcc/ada/libgnat/a-tiflio.adb b/gcc/ada/libgnat/a-tiflio.adb
index db1cea2..1df3590 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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,6 +30,9 @@
------------------------------------------------------------------------------
with Ada.Text_IO.Float_Aux;
+with System.Img_Flt; use System.Img_Flt;
+with System.Img_LFlt; use System.Img_LFlt;
+with System.Img_LLF; use System.Img_LLF;
with System.Val_Flt; use System.Val_Flt;
with System.Val_LFlt; use System.Val_LFlt;
with System.Val_LLF; use System.Val_LLF;
@@ -37,13 +40,15 @@ with System.Val_LLF; use System.Val_LLF;
package body Ada.Text_IO.Float_IO with SPARK_Mode => Off is
package Aux_Float is new
- Ada.Text_IO.Float_Aux (Float, Scan_Float);
+ Ada.Text_IO.Float_Aux (Float, Scan_Float, Set_Image_Float);
package Aux_Long_Float is new
- Ada.Text_IO.Float_Aux (Long_Float, Scan_Long_Float);
+ Ada.Text_IO.Float_Aux
+ (Long_Float, Scan_Long_Float, Set_Image_Long_Float);
package Aux_Long_Long_Float is new
- Ada.Text_IO.Float_Aux (Long_Long_Float, Scan_Long_Long_Float);
+ Ada.Text_IO.Float_Aux
+ (Long_Long_Float, Scan_Long_Long_Float, Set_Image_Long_Long_Float);
-- Throughout this generic body, we distinguish between the case where type
-- Float is OK, where type Long_Float is OK and where type Long_Long_Float
diff --git a/gcc/ada/libgnat/a-tiflio.ads b/gcc/ada/libgnat/a-tiflio.ads
index d61b9e7..9aab165 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, 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 5e13dae..ef86ae0 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 d6acd8d..40753e7 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 3dad18b..9cd328c 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 a0bb5c6..4aaa93d 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 e149221..611849f 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 4133bec..495c652 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 2998764..833136c 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, 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-tiinio__128.adb b/gcc/ada/libgnat/a-tiinio__128.adb
index e82b447..4c42818 100644
--- a/gcc/ada/libgnat/a-tiinio__128.adb
+++ b/gcc/ada/libgnat/a-tiinio__128.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 83dbafa..3843d7b 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 aa1de6b..55c536b 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1993-2021, 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-timoio__128.adb b/gcc/ada/libgnat/a-timoio__128.adb
index 45856e2..d475ce5 100644
--- a/gcc/ada/libgnat/a-timoio__128.adb
+++ b/gcc/ada/libgnat/a-timoio__128.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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.adb b/gcc/ada/libgnat/a-tiocst.adb
index aea0995..b870878 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 0f4f8a5..c2a05f0 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 a5d217c..5c00c77 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2009-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 e3f8caa..7aed7ba 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2009-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 e0d13dc..db51b9e 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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-uncdea.ads b/gcc/ada/libgnat/a-uncdea.ads
index a61cd50..439fa61 100644
--- a/gcc/ada/libgnat/a-uncdea.ads
+++ b/gcc/ada/libgnat/a-uncdea.ads
@@ -17,7 +17,10 @@ generic
type Object (<>) is limited private;
type Name is access Object;
-procedure Ada.Unchecked_Deallocation (X : in out Name);
+procedure Ada.Unchecked_Deallocation (X : in out Name) with
+ Depends => (X => null, -- X on exit does not depend on its input value
+ null => X), -- X's input value has no effect
+ Post => X = null; -- X's output value is null
pragma Preelaborate (Unchecked_Deallocation);
pragma Import (Intrinsic, Ada.Unchecked_Deallocation);
diff --git a/gcc/ada/libgnat/a-undesu.adb b/gcc/ada/libgnat/a-undesu.adb
index 8fd8a77..4728048 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2011-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 feccc23..da8e39f 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2010-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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-wichun.adb b/gcc/ada/libgnat/a-wichun.adb
index 09cbad2..9bfb589 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2005-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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-wichun.ads b/gcc/ada/libgnat/a-wichun.ads
index 9e42749..27ce111 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2005-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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.adb b/gcc/ada/libgnat/a-witeio.adb
index 6bc3f48..7dbd3b3 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -136,15 +136,15 @@ package body Ada.Wide_Text_IO is
-- is required (RM A.10.3(23)) but it seems reasonable, and besides
-- ACVC test CE3208A expects this behavior.
- if File_Type (File) = Current_In then
+ if File = Current_In then
Current_In := null;
- elsif File_Type (File) = Current_Out then
+ elsif File = Current_Out then
Current_Out := null;
- elsif File_Type (File) = Current_Err then
+ elsif File = Current_Err then
Current_Err := null;
end if;
- Terminate_Line (File_Type (File));
+ Terminate_Line (File.all'Access);
end AFCB_Close;
---------------
@@ -152,11 +152,10 @@ package body Ada.Wide_Text_IO is
---------------
procedure AFCB_Free (File : not null access Wide_Text_AFCB) is
- type FCB_Ptr is access all Wide_Text_AFCB;
- FT : FCB_Ptr := FCB_Ptr (File);
+ FT : File_Type := File.all'Access;
procedure Free is
- new Ada.Unchecked_Deallocation (Wide_Text_AFCB, FCB_Ptr);
+ new Ada.Unchecked_Deallocation (Wide_Text_AFCB, File_Type);
begin
Free (FT);
diff --git a/gcc/ada/libgnat/a-witeio.ads b/gcc/ada/libgnat/a-witeio.ads
index 9dcfda0..910154d 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, 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 --
@@ -73,9 +73,6 @@ package Ada.Wide_Text_IO is
-- Line and page length
subtype Field is Integer range 0 .. 255;
- -- Note: if for any reason, there is a need to increase this value, then it
- -- will be necessary to change the corresponding value in System.Img_Real
- -- in file s-imgrea.adb.
subtype Number_Base is Integer range 2 .. 16;
diff --git a/gcc/ada/libgnat/a-wrstfi.adb b/gcc/ada/libgnat/a-wrstfi.adb
index 95e66ba..ce8ce44 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2009-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 e8bf4d1..b389bc7 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2009-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 05a6d9d..d8dd79f 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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,6 @@
with Ada.Wide_Text_IO.Generic_Aux; use Ada.Wide_Text_IO.Generic_Aux;
-with System.Img_Real; use System.Img_Real;
-
package body Ada.Wide_Text_IO.Complex_Aux is
---------
@@ -171,9 +169,9 @@ package body Ada.Wide_Text_IO.Complex_Aux is
-- Both parts are initially converted with a Fore of 0
Rptr := 0;
- Set_Image_Real (Long_Long_Float (ItemR), R_String, Rptr, 0, Aft, Exp);
+ Aux.Set_Image (ItemR, R_String, Rptr, 0, Aft, Exp);
Iptr := 0;
- Set_Image_Real (Long_Long_Float (ItemI), I_String, Iptr, 0, Aft, Exp);
+ Aux.Set_Image (ItemI, I_String, Iptr, 0, Aft, Exp);
-- Check room for both parts plus parens plus comma (RM G.1.3(34))
diff --git a/gcc/ada/libgnat/a-wtcoau.ads b/gcc/ada/libgnat/a-wtcoau.ads
index affb969..5541983 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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,7 @@ private generic
type Num is digits <>;
- with package Aux is new Ada.Wide_Text_IO.Float_Aux (Num, <>);
+ with package Aux is new Ada.Wide_Text_IO.Float_Aux (Num, <>, <>);
package Ada.Wide_Text_IO.Complex_Aux is
diff --git a/gcc/ada/libgnat/a-wtcoio.adb b/gcc/ada/libgnat/a-wtcoio.adb
index 8e9ff7a..fcca1bb 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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,6 +31,9 @@
with Ada.Wide_Text_IO.Complex_Aux;
with Ada.Wide_Text_IO.Float_Aux;
+with System.Img_Flt; use System.Img_Flt;
+with System.Img_LFlt; use System.Img_LFlt;
+with System.Img_LLF; use System.Img_LLF;
with System.Val_Flt; use System.Val_Flt;
with System.Val_LFlt; use System.Val_LFlt;
with System.Val_LLF; use System.Val_LLF;
@@ -42,22 +45,24 @@ package body Ada.Wide_Text_IO.Complex_IO is
use Complex_Types;
package Scalar_Float is new
- Ada.Wide_Text_IO.Float_Aux (Float, Scan_Float);
+ Ada.Wide_Text_IO.Float_Aux (Float, Scan_Float, Set_Image_Float);
package Scalar_Long_Float is new
- Ada.Wide_Text_IO.Float_Aux (Long_Float, Scan_Long_Float);
+ Ada.Wide_Text_IO.Float_Aux
+ (Long_Float, Scan_Long_Float, Set_Image_Long_Float);
package Scalar_Long_Long_Float is new
- Ada.Wide_Text_IO.Float_Aux (Long_Long_Float, Scan_Long_Long_Float);
+ Ada.Wide_Text_IO.Float_Aux
+ (Long_Long_Float, Scan_Long_Long_Float, Set_Image_Long_Long_Float);
package Aux_Float is new
- Ada.Wide_Text_IO.Complex_Aux (Float, Scalar_Float);
+ Ada.Wide_Text_IO.Complex_Aux (Float, Scalar_Float);
package Aux_Long_Float is new
- Ada.Wide_Text_IO.Complex_Aux (Long_Float, Scalar_Long_Float);
+ Ada.Wide_Text_IO.Complex_Aux (Long_Float, Scalar_Long_Float);
package Aux_Long_Long_Float is new
- Ada.Wide_Text_IO.Complex_Aux (Long_Long_Float, Scalar_Long_Long_Float);
+ Ada.Wide_Text_IO.Complex_Aux (Long_Long_Float, Scalar_Long_Long_Float);
-- Throughout this generic body, we distinguish between the case where type
-- Float is OK, where type Long_Float is OK and where type Long_Long_Float
diff --git a/gcc/ada/libgnat/a-wtcstr.adb b/gcc/ada/libgnat/a-wtcstr.adb
index c039677..acb6cc5 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 414a5e9..e062d09 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 57fcc92..f1a65e0 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 5c0c4d6..00fbca59 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 c503a20..f8c91d1 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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__128.adb b/gcc/ada/libgnat/a-wtdeio__128.adb
index 796c724..6a483e2 100644
--- a/gcc/ada/libgnat/a-wtdeio__128.adb
+++ b/gcc/ada/libgnat/a-wtdeio__128.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2020-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 e8a4b57..57ed1dd 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 4d74578..1736a15 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, 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 6dcda30..8a4dde9 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 b9b7566..b26bc8a 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 f89359c..5a406f8 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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-wtfiau.adb b/gcc/ada/libgnat/a-wtfiau.adb
index 611b76d..66376b7 100644
--- a/gcc/ada/libgnat/a-wtfiau.adb
+++ b/gcc/ada/libgnat/a-wtfiau.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2020-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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-wtfiau.ads b/gcc/ada/libgnat/a-wtfiau.ads
index f487931..e557283 100644
--- a/gcc/ada/libgnat/a-wtfiau.ads
+++ b/gcc/ada/libgnat/a-wtfiau.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2020-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 e2537ae..954ab95 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -34,9 +34,10 @@ with Ada.Wide_Text_IO.Fixed_Aux;
with Ada.Wide_Text_IO.Float_Aux;
with System.Img_Fixed_32; use System.Img_Fixed_32;
with System.Img_Fixed_64; use System.Img_Fixed_64;
+with System.Img_LFlt; use System.Img_LFlt;
with System.Val_Fixed_32; use System.Val_Fixed_32;
with System.Val_Fixed_64; use System.Val_Fixed_64;
-with System.Val_LLF; use System.Val_LLF;
+with System.Val_LFlt; use System.Val_LFlt;
with System.WCh_Con; use System.WCh_Con;
with System.WCh_WtS; use System.WCh_WtS;
@@ -45,7 +46,7 @@ package body Ada.Wide_Text_IO.Fixed_IO is
-- Note: we still use the floating-point I/O routines for types whose small
-- is not the ratio of two sufficiently small integers. This will result in
-- inaccuracies for fixed point types that require more precision than is
- -- available in Long_Long_Float.
+ -- available in Long_Float.
subtype Int32 is Interfaces.Integer_32; use type Int32;
subtype Int64 is Interfaces.Integer_64; use type Int64;
@@ -56,8 +57,9 @@ package body Ada.Wide_Text_IO.Fixed_IO is
package Aux64 is new
Ada.Wide_Text_IO.Fixed_Aux (Int64, Scan_Fixed64, Set_Image_Fixed64);
- package Aux_Long_Long_Float is new
- Ada.Wide_Text_IO.Float_Aux (Long_Long_Float, Scan_Long_Long_Float);
+ package Aux_Long_Float is new
+ Ada.Wide_Text_IO.Float_Aux
+ (Long_Float, Scan_Long_Float, Set_Image_Long_Float);
-- Throughout this generic body, we distinguish between the case where type
-- Int32 is OK and where type Int64 is OK. These boolean constants are used
@@ -161,7 +163,7 @@ package body Ada.Wide_Text_IO.Fixed_IO is
-Num'Small_Numerator,
-Num'Small_Denominator));
else
- Aux_Long_Long_Float.Get (File, Long_Long_Float (Item), Width);
+ Aux_Long_Float.Get (File, Long_Float (Item), Width);
end if;
exception
@@ -201,7 +203,7 @@ package body Ada.Wide_Text_IO.Fixed_IO is
-Num'Small_Numerator,
-Num'Small_Denominator));
else
- Aux_Long_Long_Float.Gets (S, Long_Long_Float (Item), Last);
+ Aux_Long_Float.Gets (S, Long_Float (Item), Last);
end if;
exception
@@ -229,8 +231,7 @@ package body Ada.Wide_Text_IO.Fixed_IO is
-Num'Small_Numerator, -Num'Small_Denominator,
For0, Num'Aft);
else
- Aux_Long_Long_Float.Put
- (File, Long_Long_Float (Item), Fore, Aft, Exp);
+ Aux_Long_Float.Put (File, Long_Float (Item), Fore, Aft, Exp);
end if;
end Put;
@@ -262,7 +263,7 @@ package body Ada.Wide_Text_IO.Fixed_IO is
-Num'Small_Numerator, -Num'Small_Denominator,
For0, Num'Aft);
else
- Aux_Long_Long_Float.Puts (S, Long_Long_Float (Item), Aft, Exp);
+ Aux_Long_Float.Puts (S, Long_Float (Item), Aft, Exp);
end if;
for J in S'Range loop
diff --git a/gcc/ada/libgnat/a-wtfiio__128.adb b/gcc/ada/libgnat/a-wtfiio__128.adb
index a5801be..d74902e 100644
--- a/gcc/ada/libgnat/a-wtfiio__128.adb
+++ b/gcc/ada/libgnat/a-wtfiio__128.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2020-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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,10 +35,11 @@ with Ada.Wide_Text_IO.Float_Aux;
with System.Img_Fixed_32; use System.Img_Fixed_32;
with System.Img_Fixed_64; use System.Img_Fixed_64;
with System.Img_Fixed_128; use System.Img_Fixed_128;
+with System.Img_LFlt; use System.Img_LFlt;
with System.Val_Fixed_32; use System.Val_Fixed_32;
with System.Val_Fixed_64; use System.Val_Fixed_64;
with System.Val_Fixed_128; use System.Val_Fixed_128;
-with System.Val_LLF; use System.Val_LLF;
+with System.Val_LFlt; use System.Val_LFlt;
with System.WCh_Con; use System.WCh_Con;
with System.WCh_WtS; use System.WCh_WtS;
@@ -47,7 +48,7 @@ package body Ada.Wide_Text_IO.Fixed_IO is
-- Note: we still use the floating-point I/O routines for types whose small
-- is not the ratio of two sufficiently small integers. This will result in
-- inaccuracies for fixed point types that require more precision than is
- -- available in Long_Long_Float.
+ -- available in Long_Float.
subtype Int32 is Interfaces.Integer_32; use type Int32;
subtype Int64 is Interfaces.Integer_64; use type Int64;
@@ -62,8 +63,9 @@ package body Ada.Wide_Text_IO.Fixed_IO is
package Aux128 is new
Ada.Wide_Text_IO.Fixed_Aux (Int128, Scan_Fixed128, Set_Image_Fixed128);
- package Aux_Long_Long_Float is new
- Ada.Wide_Text_IO.Float_Aux (Long_Long_Float, Scan_Long_Long_Float);
+ package Aux_Long_Float is new
+ Ada.Wide_Text_IO.Float_Aux
+ (Long_Float, Scan_Long_Float, Set_Image_Long_Float);
-- Throughout this generic body, we distinguish between the case where type
-- Int32 is OK, where type Int64 is OK and where type Int128 is OK. These
@@ -201,7 +203,7 @@ package body Ada.Wide_Text_IO.Fixed_IO is
-Num'Small_Numerator,
-Num'Small_Denominator));
else
- Aux_Long_Long_Float.Get (File, Long_Long_Float (Item), Width);
+ Aux_Long_Float.Get (File, Long_Float (Item), Width);
end if;
exception
@@ -246,7 +248,7 @@ package body Ada.Wide_Text_IO.Fixed_IO is
-Num'Small_Numerator,
-Num'Small_Denominator));
else
- Aux_Long_Long_Float.Gets (S, Long_Long_Float (Item), Last);
+ Aux_Long_Float.Gets (S, Long_Float (Item), Last);
end if;
exception
@@ -278,8 +280,7 @@ package body Ada.Wide_Text_IO.Fixed_IO is
-Num'Small_Numerator, -Num'Small_Denominator,
For0, Num'Aft);
else
- Aux_Long_Long_Float.Put
- (File, Long_Long_Float (Item), Fore, Aft, Exp);
+ Aux_Long_Float.Put (File, Long_Float (Item), Fore, Aft, Exp);
end if;
end Put;
@@ -315,7 +316,7 @@ package body Ada.Wide_Text_IO.Fixed_IO is
-Num'Small_Numerator, -Num'Small_Denominator,
For0, Num'Aft);
else
- Aux_Long_Long_Float.Puts (S, Long_Long_Float (Item), Aft, Exp);
+ Aux_Long_Float.Puts (S, Long_Float (Item), Aft, Exp);
end if;
for J in S'Range loop
diff --git a/gcc/ada/libgnat/a-wtflau.adb b/gcc/ada/libgnat/a-wtflau.adb
index 7db1b78..6f486b7 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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 @@
with Ada.Wide_Text_IO.Generic_Aux; use Ada.Wide_Text_IO.Generic_Aux;
-with System.Img_Real; use System.Img_Real;
+with System.Img_Util; use System.Img_Util;
package body Ada.Wide_Text_IO.Float_Aux is
@@ -96,7 +96,7 @@ package body Ada.Wide_Text_IO.Float_Aux is
Ptr : Natural := 0;
begin
- Set_Image_Real (Long_Long_Float (Item), Buf, Ptr, Fore, Aft, Exp);
+ Set_Image (Item, Buf, Ptr, Fore, Aft, Exp);
Put_Item (File, Buf (1 .. Ptr));
end Put;
@@ -114,8 +114,7 @@ package body Ada.Wide_Text_IO.Float_Aux is
Ptr : Natural := 0;
begin
- Set_Image_Real
- (Long_Long_Float (Item), Buf, Ptr, Fore => 1, Aft => Aft, Exp => Exp);
+ Set_Image (Item, Buf, Ptr, Fore => 1, Aft => Aft, Exp => Exp);
if Ptr > To'Length then
raise Layout_Error;
diff --git a/gcc/ada/libgnat/a-wtflau.ads b/gcc/ada/libgnat/a-wtflau.ads
index 82ace79..0303b63 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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,14 @@ private generic
Ptr : not null access Integer;
Max : Integer) return Num;
+ with procedure Set_Image
+ (V : Num;
+ S : in out String;
+ P : in out Natural;
+ Fore : Natural;
+ Aft : Natural;
+ Exp : Natural);
+
package Ada.Wide_Text_IO.Float_Aux is
procedure Get
diff --git a/gcc/ada/libgnat/a-wtflio.adb b/gcc/ada/libgnat/a-wtflio.adb
index 3691786..acbe1f5 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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,6 +30,9 @@
------------------------------------------------------------------------------
with Ada.Wide_Text_IO.Float_Aux;
+with System.Img_Flt; use System.Img_Flt;
+with System.Img_LFlt; use System.Img_LFlt;
+with System.Img_LLF; use System.Img_LLF;
with System.Val_Flt; use System.Val_Flt;
with System.Val_LFlt; use System.Val_LFlt;
with System.Val_LLF; use System.Val_LLF;
@@ -39,13 +42,15 @@ with System.WCh_WtS; use System.WCh_WtS;
package body Ada.Wide_Text_IO.Float_IO is
package Aux_Float is new
- Ada.Wide_Text_IO.Float_Aux (Float, Scan_Float);
+ Ada.Wide_Text_IO.Float_Aux (Float, Scan_Float, Set_Image_Float);
package Aux_Long_Float is new
- Ada.Wide_Text_IO.Float_Aux (Long_Float, Scan_Long_Float);
+ Ada.Wide_Text_IO.Float_Aux
+ (Long_Float, Scan_Long_Float, Set_Image_Long_Float);
package Aux_Long_Long_Float is new
- Ada.Wide_Text_IO.Float_Aux (Long_Long_Float, Scan_Long_Long_Float);
+ Ada.Wide_Text_IO.Float_Aux
+ (Long_Long_Float, Scan_Long_Long_Float, Set_Image_Long_Long_Float);
-- Throughout this generic body, we distinguish between the case where type
-- Float is OK, where type Long_Float is OK and where type Long_Long_Float
diff --git a/gcc/ada/libgnat/a-wtgeau.adb b/gcc/ada/libgnat/a-wtgeau.adb
index bc9b459..ed823f1 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 7c89971..b3c1fa4 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 b614b39..1630428 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 f139f77..661f25e 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 b322433..336b591 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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__128.adb b/gcc/ada/libgnat/a-wtinio__128.adb
index 0eea7b5..8c0191d 100644
--- a/gcc/ada/libgnat/a-wtinio__128.adb
+++ b/gcc/ada/libgnat/a-wtinio__128.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 efab035..ffefa13 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 b28aacd..d772c41 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, 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-wtmoio__128.adb b/gcc/ada/libgnat/a-wtmoio__128.adb
index a32eaf2..155f312 100644
--- a/gcc/ada/libgnat/a-wtmoio__128.adb
+++ b/gcc/ada/libgnat/a-wtmoio__128.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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-wttest.adb b/gcc/ada/libgnat/a-wttest.adb
index 01b6688..69eb6be 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 4602596..a5c85a1 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1997-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 6930121..3f2a91b 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2010-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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-zchuni.adb b/gcc/ada/libgnat/a-zchuni.adb
index 203c3aa..2bbe584 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2005-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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-zchuni.ads b/gcc/ada/libgnat/a-zchuni.ads
index 7f4a30b..51f7c92 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2005-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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.adb b/gcc/ada/libgnat/a-zrstfi.adb
index aa73032..ba07af8 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2009-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 86a6fc5..56d3ef4 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2009-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 bb33680..a367827 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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,6 @@
with Ada.Wide_Wide_Text_IO.Generic_Aux; use Ada.Wide_Wide_Text_IO.Generic_Aux;
-with System.Img_Real; use System.Img_Real;
-
package body Ada.Wide_Wide_Text_IO.Complex_Aux is
---------
@@ -171,9 +169,9 @@ package body Ada.Wide_Wide_Text_IO.Complex_Aux is
-- Both parts are initially converted with a Fore of 0
Rptr := 0;
- Set_Image_Real (Long_Long_Float (ItemR), R_String, Rptr, 0, Aft, Exp);
+ Aux.Set_Image (ItemR, R_String, Rptr, 0, Aft, Exp);
Iptr := 0;
- Set_Image_Real (Long_Long_Float (ItemI), I_String, Iptr, 0, Aft, Exp);
+ Aux.Set_Image (ItemI, I_String, Iptr, 0, Aft, Exp);
-- Check room for both parts plus parens plus comma (RM G.1.3(34))
diff --git a/gcc/ada/libgnat/a-ztcoau.ads b/gcc/ada/libgnat/a-ztcoau.ads
index 43546d8..953ed5d 100644
--- a/gcc/ada/libgnat/a-ztcoau.ads
+++ b/gcc/ada/libgnat/a-ztcoau.ads
@@ -26,7 +26,7 @@ private generic
type Num is digits <>;
- with package Aux is new Ada.Wide_Wide_Text_IO.Float_Aux (Num, <>);
+ with package Aux is new Ada.Wide_Wide_Text_IO.Float_Aux (Num, <>, <>);
package Ada.Wide_Wide_Text_IO.Complex_Aux is
diff --git a/gcc/ada/libgnat/a-ztcoio.adb b/gcc/ada/libgnat/a-ztcoio.adb
index 5103191..9ec590a 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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,36 +31,39 @@
with Ada.Wide_Wide_Text_IO.Complex_Aux;
with Ada.Wide_Wide_Text_IO.Float_Aux;
+with System.Img_Flt; use System.Img_Flt;
+with System.Img_LFlt; use System.Img_LFlt;
+with System.Img_LLF; use System.Img_LLF;
with System.Val_Flt; use System.Val_Flt;
with System.Val_LFlt; use System.Val_LFlt;
with System.Val_LLF; use System.Val_LLF;
with System.WCh_Con; use System.WCh_Con;
with System.WCh_WtS; use System.WCh_WtS;
-with Ada.Unchecked_Conversion;
-
package body Ada.Wide_Wide_Text_IO.Complex_IO is
use Complex_Types;
package Scalar_Float is new
- Ada.Wide_Wide_Text_IO.Float_Aux (Float, Scan_Float);
+ Ada.Wide_Wide_Text_IO.Float_Aux (Float, Scan_Float, Set_Image_Float);
package Scalar_Long_Float is new
- Ada.Wide_Wide_Text_IO.Float_Aux (Long_Float, Scan_Long_Float);
+ Ada.Wide_Wide_Text_IO.Float_Aux
+ (Long_Float, Scan_Long_Float, Set_Image_Long_Float);
package Scalar_Long_Long_Float is new
- Ada.Wide_Wide_Text_IO.Float_Aux (Long_Long_Float, Scan_Long_Long_Float);
+ Ada.Wide_Wide_Text_IO.Float_Aux
+ (Long_Long_Float, Scan_Long_Long_Float, Set_Image_Long_Long_Float);
package Aux_Float is new
- Ada.Wide_Wide_Text_IO.Complex_Aux (Float, Scalar_Float);
+ Ada.Wide_Wide_Text_IO.Complex_Aux (Float, Scalar_Float);
package Aux_Long_Float is new
- Ada.Wide_Wide_Text_IO.Complex_Aux (Long_Float, Scalar_Long_Float);
+ Ada.Wide_Wide_Text_IO.Complex_Aux (Long_Float, Scalar_Long_Float);
package Aux_Long_Long_Float is new
- Ada.Wide_Wide_Text_IO.Complex_Aux
- (Long_Long_Float, Scalar_Long_Long_Float);
+ Ada.Wide_Wide_Text_IO.Complex_Aux
+ (Long_Long_Float, Scalar_Long_Long_Float);
-- Throughout this generic body, we distinguish between the case where type
-- Float is OK, where type Long_Float is OK and where type Long_Long_Float
diff --git a/gcc/ada/libgnat/a-ztcstr.adb b/gcc/ada/libgnat/a-ztcstr.adb
index 8ce9d66..e4aa3c1 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 80c30fc..86c65d79 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 ec6431b..71e214c1 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 962f479..b70fb21 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 1d9f5d8..c8bf59f 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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__128.adb b/gcc/ada/libgnat/a-ztdeio__128.adb
index 156a66d..11cbb01 100644
--- a/gcc/ada/libgnat/a-ztdeio__128.adb
+++ b/gcc/ada/libgnat/a-ztdeio__128.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2020-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 a23074d..b044621 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 54cd24a..d846432 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, 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 f3b11af..f4bffec 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 dd31182..263072f 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 6c35b9f..998632b 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 dcd6f9e..71d733e 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -136,15 +136,15 @@ package body Ada.Wide_Wide_Text_IO is
-- is required (RM A.10.3(23)) but it seems reasonable, and besides
-- ACVC test CE3208A expects this behavior.
- if File_Type (File) = Current_In then
+ if File = Current_In then
Current_In := null;
- elsif File_Type (File) = Current_Out then
+ elsif File = Current_Out then
Current_Out := null;
- elsif File_Type (File) = Current_Err then
+ elsif File = Current_Err then
Current_Err := null;
end if;
- Terminate_Line (File_Type (File));
+ Terminate_Line (File.all'Access);
end AFCB_Close;
---------------
@@ -152,11 +152,10 @@ package body Ada.Wide_Wide_Text_IO is
---------------
procedure AFCB_Free (File : not null access Wide_Wide_Text_AFCB) is
- type FCB_Ptr is access all Wide_Wide_Text_AFCB;
- FT : FCB_Ptr := FCB_Ptr (File);
+ FT : File_Type := File.all'Access;
procedure Free is new
- Ada.Unchecked_Deallocation (Wide_Wide_Text_AFCB, FCB_Ptr);
+ Ada.Unchecked_Deallocation (Wide_Wide_Text_AFCB, File_Type);
begin
Free (FT);
diff --git a/gcc/ada/libgnat/a-ztexio.ads b/gcc/ada/libgnat/a-ztexio.ads
index 85ea6b5..5983e0e 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, 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 --
@@ -73,9 +73,6 @@ package Ada.Wide_Wide_Text_IO is
-- Line and page length
subtype Field is Integer range 0 .. 255;
- -- Note: if for any reason, there is a need to increase this value, then it
- -- will be necessary to change the corresponding value in System.Img_Real
- -- in file s-imgrea.adb.
subtype Number_Base is Integer range 2 .. 16;
diff --git a/gcc/ada/libgnat/a-ztfiau.adb b/gcc/ada/libgnat/a-ztfiau.adb
index 1e94fef..340b90a 100644
--- a/gcc/ada/libgnat/a-ztfiau.adb
+++ b/gcc/ada/libgnat/a-ztfiau.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2020-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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-ztfiau.ads b/gcc/ada/libgnat/a-ztfiau.ads
index aac4e42..23a7ee9 100644
--- a/gcc/ada/libgnat/a-ztfiau.ads
+++ b/gcc/ada/libgnat/a-ztfiau.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2020-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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-ztfiio.adb b/gcc/ada/libgnat/a-ztfiio.adb
index 53ed45b..5c12e2a 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -34,9 +34,10 @@ with Ada.Wide_Wide_Text_IO.Fixed_Aux;
with Ada.Wide_Wide_Text_IO.Float_Aux;
with System.Img_Fixed_32; use System.Img_Fixed_32;
with System.Img_Fixed_64; use System.Img_Fixed_64;
+with System.Img_LFlt; use System.Img_LFlt;
with System.Val_Fixed_32; use System.Val_Fixed_32;
with System.Val_Fixed_64; use System.Val_Fixed_64;
-with System.Val_LLF; use System.Val_LLF;
+with System.Val_LFlt; use System.Val_LFlt;
with System.WCh_Con; use System.WCh_Con;
with System.WCh_WtS; use System.WCh_WtS;
@@ -45,7 +46,7 @@ package body Ada.Wide_Wide_Text_IO.Fixed_IO is
-- Note: we still use the floating-point I/O routines for types whose small
-- is not the ratio of two sufficiently small integers. This will result in
-- inaccuracies for fixed point types that require more precision than is
- -- available in Long_Long_Float.
+ -- available in Long_Float.
subtype Int32 is Interfaces.Integer_32; use type Int32;
subtype Int64 is Interfaces.Integer_64; use type Int64;
@@ -56,8 +57,9 @@ package body Ada.Wide_Wide_Text_IO.Fixed_IO is
package Aux64 is new
Ada.Wide_Wide_Text_IO.Fixed_Aux (Int64, Scan_Fixed64, Set_Image_Fixed64);
- package Aux_Long_Long_Float is new
- Ada.Wide_Wide_Text_IO.Float_Aux (Long_Long_Float, Scan_Long_Long_Float);
+ package Aux_Long_Float is new
+ Ada.Wide_Wide_Text_IO.Float_Aux
+ (Long_Float, Scan_Long_Float, Set_Image_Long_Float);
-- Throughout this generic body, we distinguish between the case where type
-- Int32 is OK and where type Int64 is OK. These boolean constants are used
@@ -161,7 +163,7 @@ package body Ada.Wide_Wide_Text_IO.Fixed_IO is
-Num'Small_Numerator,
-Num'Small_Denominator));
else
- Aux_Long_Long_Float.Get (File, Long_Long_Float (Item), Width);
+ Aux_Long_Float.Get (File, Long_Float (Item), Width);
end if;
exception
@@ -201,7 +203,7 @@ package body Ada.Wide_Wide_Text_IO.Fixed_IO is
-Num'Small_Numerator,
-Num'Small_Denominator));
else
- Aux_Long_Long_Float.Gets (S, Long_Long_Float (Item), Last);
+ Aux_Long_Float.Gets (S, Long_Float (Item), Last);
end if;
exception
@@ -229,8 +231,7 @@ package body Ada.Wide_Wide_Text_IO.Fixed_IO is
-Num'Small_Numerator, -Num'Small_Denominator,
For0, Num'Aft);
else
- Aux_Long_Long_Float.Put
- (File, Long_Long_Float (Item), Fore, Aft, Exp);
+ Aux_Long_Float.Put (File, Long_Float (Item), Fore, Aft, Exp);
end if;
end Put;
@@ -262,7 +263,7 @@ package body Ada.Wide_Wide_Text_IO.Fixed_IO is
-Num'Small_Numerator, -Num'Small_Denominator,
For0, Num'Aft);
else
- Aux_Long_Long_Float.Puts (S, Long_Long_Float (Item), Aft, Exp);
+ Aux_Long_Float.Puts (S, Long_Float (Item), Aft, Exp);
end if;
for J in S'Range loop
diff --git a/gcc/ada/libgnat/a-ztfiio__128.adb b/gcc/ada/libgnat/a-ztfiio__128.adb
index 13ed410..f089fd6 100644
--- a/gcc/ada/libgnat/a-ztfiio__128.adb
+++ b/gcc/ada/libgnat/a-ztfiio__128.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2020-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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,10 +35,11 @@ with Ada.Wide_Wide_Text_IO.Float_Aux;
with System.Img_Fixed_32; use System.Img_Fixed_32;
with System.Img_Fixed_64; use System.Img_Fixed_64;
with System.Img_Fixed_128; use System.Img_Fixed_128;
+with System.Img_LFlt; use System.Img_LFlt;
with System.Val_Fixed_32; use System.Val_Fixed_32;
with System.Val_Fixed_64; use System.Val_Fixed_64;
with System.Val_Fixed_128; use System.Val_Fixed_128;
-with System.Val_LLF; use System.Val_LLF;
+with System.Val_LFlt; use System.Val_LFlt;
with System.WCh_Con; use System.WCh_Con;
with System.WCh_WtS; use System.WCh_WtS;
@@ -47,7 +48,7 @@ package body Ada.Wide_Wide_Text_IO.Fixed_IO is
-- Note: we still use the floating-point I/O routines for types whose small
-- is not the ratio of two sufficiently small integers. This will result in
-- inaccuracies for fixed point types that require more precision than is
- -- available in Long_Long_Float.
+ -- available in Long_Float.
subtype Int32 is Interfaces.Integer_32; use type Int32;
subtype Int64 is Interfaces.Integer_64; use type Int64;
@@ -63,8 +64,9 @@ package body Ada.Wide_Wide_Text_IO.Fixed_IO is
Ada.Wide_Wide_Text_IO.Fixed_Aux
(Int128, Scan_Fixed128, Set_Image_Fixed128);
- package Aux_Long_Long_Float is new
- Ada.Wide_Wide_Text_IO.Float_Aux (Long_Long_Float, Scan_Long_Long_Float);
+ package Aux_Long_Float is new
+ Ada.Wide_Wide_Text_IO.Float_Aux
+ (Long_Float, Scan_Long_Float, Set_Image_Long_Float);
-- Throughout this generic body, we distinguish between the case where type
-- Int32 is OK, where type Int64 is OK and where type Int128 is OK. These
@@ -202,7 +204,7 @@ package body Ada.Wide_Wide_Text_IO.Fixed_IO is
-Num'Small_Numerator,
-Num'Small_Denominator));
else
- Aux_Long_Long_Float.Get (File, Long_Long_Float (Item), Width);
+ Aux_Long_Float.Get (File, Long_Float (Item), Width);
end if;
exception
@@ -247,7 +249,7 @@ package body Ada.Wide_Wide_Text_IO.Fixed_IO is
-Num'Small_Numerator,
-Num'Small_Denominator));
else
- Aux_Long_Long_Float.Gets (S, Long_Long_Float (Item), Last);
+ Aux_Long_Float.Gets (S, Long_Float (Item), Last);
end if;
exception
@@ -279,8 +281,7 @@ package body Ada.Wide_Wide_Text_IO.Fixed_IO is
-Num'Small_Numerator, -Num'Small_Denominator,
For0, Num'Aft);
else
- Aux_Long_Long_Float.Put
- (File, Long_Long_Float (Item), Fore, Aft, Exp);
+ Aux_Long_Float.Put (File, Long_Float (Item), Fore, Aft, Exp);
end if;
end Put;
@@ -316,7 +317,7 @@ package body Ada.Wide_Wide_Text_IO.Fixed_IO is
-Num'Small_Numerator, -Num'Small_Denominator,
For0, Num'Aft);
else
- Aux_Long_Long_Float.Puts (S, Long_Long_Float (Item), Aft, Exp);
+ Aux_Long_Float.Puts (S, Long_Float (Item), Aft, Exp);
end if;
for J in S'Range loop
diff --git a/gcc/ada/libgnat/a-ztflau.adb b/gcc/ada/libgnat/a-ztflau.adb
index 1bddcd8..d7dd9e2 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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 @@
with Ada.Wide_Wide_Text_IO.Generic_Aux; use Ada.Wide_Wide_Text_IO.Generic_Aux;
-with System.Img_Real; use System.Img_Real;
+with System.Img_Util; use System.Img_Util;
package body Ada.Wide_Wide_Text_IO.Float_Aux is
@@ -96,7 +96,7 @@ package body Ada.Wide_Wide_Text_IO.Float_Aux is
Ptr : Natural := 0;
begin
- Set_Image_Real (Long_Long_Float (Item), Buf, Ptr, Fore, Aft, Exp);
+ Set_Image (Item, Buf, Ptr, Fore, Aft, Exp);
Put_Item (File, Buf (1 .. Ptr));
end Put;
@@ -114,8 +114,7 @@ package body Ada.Wide_Wide_Text_IO.Float_Aux is
Ptr : Natural := 0;
begin
- Set_Image_Real
- (Long_Long_Float (Item), Buf, Ptr, Fore => 1, Aft => Aft, Exp => Exp);
+ Set_Image (Item, Buf, Ptr, Fore => 1, Aft => Aft, Exp => Exp);
if Ptr > To'Length then
raise Layout_Error;
diff --git a/gcc/ada/libgnat/a-ztflau.ads b/gcc/ada/libgnat/a-ztflau.ads
index 48fba82..769e20e 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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,14 @@ private generic
Ptr : not null access Integer;
Max : Integer) return Num;
+ with procedure Set_Image
+ (V : Num;
+ S : in out String;
+ P : in out Natural;
+ Fore : Natural;
+ Aft : Natural;
+ Exp : Natural);
+
package Ada.Wide_Wide_Text_IO.Float_Aux is
procedure Get
diff --git a/gcc/ada/libgnat/a-ztflio.adb b/gcc/ada/libgnat/a-ztflio.adb
index e491e62..7550695 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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,6 +30,9 @@
------------------------------------------------------------------------------
with Ada.Wide_Wide_Text_IO.Float_Aux;
+with System.Img_Flt; use System.Img_Flt;
+with System.Img_LFlt; use System.Img_LFlt;
+with System.Img_LLF; use System.Img_LLF;
with System.Val_Flt; use System.Val_Flt;
with System.Val_LFlt; use System.Val_LFlt;
with System.Val_LLF; use System.Val_LLF;
@@ -39,13 +42,15 @@ with System.WCh_WtS; use System.WCh_WtS;
package body Ada.Wide_Wide_Text_IO.Float_IO is
package Aux_Float is new
- Ada.Wide_Wide_Text_IO.Float_Aux (Float, Scan_Float);
+ Ada.Wide_Wide_Text_IO.Float_Aux (Float, Scan_Float, Set_Image_Float);
package Aux_Long_Float is new
- Ada.Wide_Wide_Text_IO.Float_Aux (Long_Float, Scan_Long_Float);
+ Ada.Wide_Wide_Text_IO.Float_Aux
+ (Long_Float, Scan_Long_Float, Set_Image_Long_Float);
package Aux_Long_Long_Float is new
- Ada.Wide_Wide_Text_IO.Float_Aux (Long_Long_Float, Scan_Long_Long_Float);
+ Ada.Wide_Wide_Text_IO.Float_Aux
+ (Long_Long_Float, Scan_Long_Long_Float, Set_Image_Long_Long_Float);
-- Throughout this generic body, we distinguish between the case where type
-- Float is OK, where type Long_Float is OK and where type Long_Long_Float
diff --git a/gcc/ada/libgnat/a-ztgeau.adb b/gcc/ada/libgnat/a-ztgeau.adb
index 6b5e4c5..9a4fdb0 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 6b80ed4..c885028 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 f7b49a1..8693557 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 914f120..dc40c7e 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 c19c8a6..5050188 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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__128.adb b/gcc/ada/libgnat/a-ztinio__128.adb
index 19dcc34..942df64 100644
--- a/gcc/ada/libgnat/a-ztinio__128.adb
+++ b/gcc/ada/libgnat/a-ztinio__128.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 ba854ff..a312091 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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__128.adb b/gcc/ada/libgnat/a-ztmoio__128.adb
index 2101508..41991c2 100644
--- a/gcc/ada/libgnat/a-ztmoio__128.adb
+++ b/gcc/ada/libgnat/a-ztmoio__128.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 71004bb..d4c1ef0 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 a41aadc..8cdc027 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1997-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 ab23380..9b381d3 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 a3aa5b6..5dc7230 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -258,7 +258,7 @@ package body GNAT.Altivec.Low_Level_Vectors is
pragma Convention (LL_Altivec, vspltisx);
type Bit_Operation is
- access function
+ not null access function
(Value : Component_Type;
Amount : Natural) return Component_Type;
diff --git a/gcc/ada/libgnat/g-alleve.ads b/gcc/ada/libgnat/g-alleve.ads
index 3c39b11..cf0028a 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 7934091..f2f8ac2 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 318f72d..b8a3281 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 589ba6c..58975f4 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2005-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 173d0d0..ad84a80 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2009-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 455ebe7..32e603a 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 b889778..65a1115 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 644b3c4..3250fdf 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 66cac0c..3fec714 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 adf463c..8c10959 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2005-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 8770030..6a8518b 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2002-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 099d499..3d943c0 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2002-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 cd2031f..c48d7ef 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-2020, AdaCore --
+-- Copyright (C) 2000-2021, 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 21b008b..b499101 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-2020, AdaCore --
+-- Copyright (C) 2000-2021, 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 95ef997..e10fb96 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2015-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 dab454a..ba9a9b1 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2015-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 3559b0a..21ae351 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-2020, AdaCore --
+-- Copyright (C) 2019-2021, 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 f36c5a9c..70d50fc 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-2020, AdaCore --
+-- Copyright (C) 1995-2021, 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 5eeb5dd..acf47ed 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-2020, AdaCore --
+-- Copyright (C) 1995-2021, 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 125afee..08317e7 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-2020, AdaCore --
+-- Copyright (C) 1995-2021, 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 11a3d75..670e7b6 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-2020, AdaCore --
+-- Copyright (C) 1995-2021, 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 543a197..0f74f59 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-2020, AdaCore --
+-- Copyright (C) 1995-2021, 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 fc6546a..64d6d03 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-2020, AdaCore --
+-- Copyright (C) 1995-2021, 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 635f4b4..451549d 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-2020, AdaCore --
+-- Copyright (C) 2006-2021, 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 ac0d812..e7b6275 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-2020, AdaCore --
+-- Copyright (C) 2006-2021, 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 f34730f..c37073e 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-2020, AdaCore --
+-- Copyright (C) 2006-2021, 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.ads b/gcc/ada/libgnat/g-bytswa.ads
index 01d4501..d8bbb00 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-2020, AdaCore --
+-- Copyright (C) 2006-2021, 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 55fb181..8200b60 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-2020, AdaCore --
+-- Copyright (C) 1999-2021, 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.ads b/gcc/ada/libgnat/g-calend.ads
index e153e08..29f055f 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1999-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 7baa43a..d18f452 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-2020, AdaCore --
+-- Copyright (C) 1995-2021, 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,10 +29,8 @@
-- --
------------------------------------------------------------------------------
--- This is a dummy body, required because if we remove the body we have
--- bootstrap path problems (this unit used to have a body, and if we do not
--- supply a dummy body, the old incorrect body is picked up during the
--- bootstrap process.
+-- This package does not require a body, since it is a package renaming. We
+-- provide a dummy file containing a No_Body pragma so that previous versions
+-- of the body (which did exist) will not interfere.
-package body GNAT.Case_Util is
-end GNAT.Case_Util;
+pragma No_Body;
diff --git a/gcc/ada/libgnat/g-casuti.ads b/gcc/ada/libgnat/g-casuti.ads
index 5468e25..f711711 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-2020, AdaCore --
+-- Copyright (C) 1995-2021, 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- --
@@ -40,38 +40,4 @@
with System.Case_Util;
-package GNAT.Case_Util is
- pragma Pure;
- pragma Elaborate_Body;
- -- The elaborate body is because we have a dummy body to deal with
- -- bootstrap path problems (we used to have a real body, and now we don't
- -- need it any more, but the bootstrap requires that we have a dummy body,
- -- since otherwise the old body gets picked up.
-
- -- Note: all the following functions handle the full Latin-1 set
-
- function To_Upper (A : Character) return Character
- renames System.Case_Util.To_Upper;
- -- Converts A to upper case if it is a lower case letter, otherwise
- -- returns the input argument unchanged.
-
- procedure To_Upper (A : in out String)
- renames System.Case_Util.To_Upper;
- -- Folds all characters of string A to upper case
-
- function To_Lower (A : Character) return Character
- renames System.Case_Util.To_Lower;
- -- Converts A to lower case if it is an upper case letter, otherwise
- -- returns the input argument unchanged.
-
- procedure To_Lower (A : in out String)
- renames System.Case_Util.To_Lower;
- -- Folds all characters of string A to lower case
-
- procedure To_Mixed (A : in out String)
- renames System.Case_Util.To_Mixed;
- -- Converts A to mixed case (i.e. lower case, except for initial
- -- character and any character after an underscore, which are
- -- converted to upper case.
-
-end GNAT.Case_Util;
+package GNAT.Case_Util renames System.Case_Util;
diff --git a/gcc/ada/libgnat/g-catiio.adb b/gcc/ada/libgnat/g-catiio.adb
index cd2df6a..462e0d2 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-2020, AdaCore --
+-- Copyright (C) 1999-2021, 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.ads b/gcc/ada/libgnat/g-catiio.ads
index 6bb9847..3c2cef9 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-2020, AdaCore --
+-- Copyright (C) 1999-2021, 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.adb b/gcc/ada/libgnat/g-cgi.adb
index 495b6dd..0c3b6a4 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-2020, AdaCore --
+-- Copyright (C) 2001-2021, 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 4b2b9dc..2108cda 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-2020, AdaCore --
+-- Copyright (C) 2000-2021, 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 0f4444a..4f5f120 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-2020, AdaCore --
+-- Copyright (C) 2000-2021, 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 42b79db..4e59abc 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-2020, AdaCore --
+-- Copyright (C) 2000-2021, 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 7ce04a1..f127ded 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-2020, AdaCore --
+-- Copyright (C) 2000-2021, 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 5ae3bdd..bb9a0f3 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-2020, AdaCore --
+-- Copyright (C) 2000-2021, 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 0ca82f8..7f7040b 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1999-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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.ads b/gcc/ada/libgnat/g-comlin.ads
index aa25118..e5f493e 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-2020, AdaCore --
+-- Copyright (C) 1999-2021, 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 fbc1469..575caac 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-2020, AdaCore --
+-- Copyright (C) 2002-2021, 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- --
@@ -33,6 +33,8 @@
-- GNAT compiler used to compile the program. It relies on the generated
-- constant in the binder generated package that records this information.
+with System;
+
package body GNAT.Compiler_Version is
Ver_Len_Max : constant := 256;
@@ -43,8 +45,15 @@ package body GNAT.Compiler_Version is
-- This is logically a reference to Gnatvsn.Ver_Prefix but we cannot
-- import this directly since run-time units cannot WITH compiler units.
+ GNAT_Version_Address : constant System.Address;
+ pragma Import (C, GNAT_Version_Address, "__gnat_version_address");
+
GNAT_Version : constant String (1 .. Ver_Len_Max + Ver_Prefix'Length);
- pragma Import (C, GNAT_Version, "__gnat_version");
+ pragma Import (Ada, GNAT_Version);
+ for GNAT_Version'Address use GNAT_Version_Address;
+ -- Use a level of indirection via __gnat_version_address to avoid LTO
+ -- type mismtch warnings between two string objects of potentially
+ -- different size.
-------------
-- Version --
diff --git a/gcc/ada/libgnat/g-comver.ads b/gcc/ada/libgnat/g-comver.ads
index 0b56b78..7de2811 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-2020, AdaCore --
+-- Copyright (C) 2002-2021, 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 691780f..f20eb7e 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-2020, AdaCore --
+-- Copyright (C) 2013-2021, 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 3781c13..ddfa02c 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-2020, AdaCore --
+-- Copyright (C) 2013-2021, 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 3adcf60..16beef1 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-2020, AdaCore --
+-- Copyright (C) 2001-2021, 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 b3d6005..3b59c3c 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-2020, AdaCore --
+-- Copyright (C) 2004-2021, 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 82d66b9..d238781 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-2020, AdaCore --
+-- Copyright (C) 2002-2021, 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 c3f2cc8..d46e4e7 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-2020, AdaCore --
+-- Copyright (C) 2002-2021, 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 2af5cd8..82d1cd6 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-2020, AdaCore --
+-- Copyright (C) 1996-2021, 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 b6523ca..0092139 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -362,7 +362,7 @@ package body GNAT.Debug_Pools is
-- These procedures are used as markers when computing the stacktraces,
-- so that addresses in the debug pool itself are not reported to the user.
- Code_Address_For_Allocate_End : System.Address;
+ Code_Address_For_Allocate_End : System.Address := System.Null_Address;
Code_Address_For_Deallocate_End : System.Address;
Code_Address_For_Dereference_End : System.Address;
-- Taking the address of the above procedures will not work on some
diff --git a/gcc/ada/libgnat/g-debpoo.ads b/gcc/ada/libgnat/g-debpoo.ads
index 88cffe8..fce04c4 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 5b1277d..d064401 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-2020, AdaCore --
+-- Copyright (C) 1997-2021, 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 dab5131..109f56a 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-2020, AdaCore --
+-- Copyright (C) 1995-2021, 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 64ae297..89824095 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-2020, AdaCore --
+-- Copyright (C) 2007-2021, 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 9e82b75..cf6f5c3 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-2020, AdaCore --
+-- Copyright (C) 2007-2021, 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 e4ae4e19..f8f9087 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-2020, AdaCore --
+-- Copyright (C) 2007-2021, 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 1e8627e..3090bee 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-2020, AdaCore --
+-- Copyright (C) 2001-2021, 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 952d795..9eec0f6 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-2020, AdaCore --
+-- Copyright (C) 2001-2021, 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 3078130..ba68626 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-2020, AdaCore --
+-- Copyright (C) 1998-2021, 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.ads b/gcc/ada/libgnat/g-dirope.ads
index 03a062f..3568f77 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-2020, AdaCore --
+-- Copyright (C) 1998-2021, 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 4c8dda5..75d1e61 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-2020, AdaCore --
+-- Copyright (C) 2002-2021, 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 3e4f561..27ea715 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-2020, AdaCore --
+-- Copyright (C) 1995-2021, 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 4c53f15..9f14b68 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-2020, AdaCore --
+-- Copyright (C) 2000-2021, 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 7a6c9fa..1cb26b4 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-2020, AdaCore --
+-- Copyright (C) 2000-2021, 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 cb07631..c9e62ab 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2003-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 62fff77..e701bc6 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2007-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 0e2fdf4..fc1e97d 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-2020, AdaCore --
+-- Copyright (C) 2007-2021, 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 e5b20cf..06a1a99 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-2020, AdaCore --
+-- Copyright (C) 2007-2021, 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 202d9e2..7184559 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2002-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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.ads b/gcc/ada/libgnat/g-excact.ads
index c38f6a0..d4bda84 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2002-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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-except.ads b/gcc/ada/libgnat/g-except.ads
index 6d13f5a..8e33a4e 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-2020, AdaCore --
+-- Copyright (C) 2000-2021, 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 1db76b7..819e204 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-2020, AdaCore --
+-- Copyright (C) 2000-2021, 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 3ae90f4..1cfe661 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-2020, AdaCore --
+-- Copyright (C) 2000-2021, 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 0f9d0b9..b945731 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-2020, AdaCore --
+-- Copyright (C) 2000-2021, 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 19e704b..985e73d 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-2020, AdaCore --
+-- Copyright (C) 2000-2021, 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 bc239e4..d5ad5bb 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-2020, AdaCore --
+-- Copyright (C) 2000-2021, 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.ads b/gcc/ada/libgnat/g-exptty.ads
index ede147c..7c7a7c7 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-2020, AdaCore --
+-- Copyright (C) 2000-2021, 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-flocon.ads b/gcc/ada/libgnat/g-flocon.ads
index bdc9b0e..cc8859b 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-2020, AdaCore --
+-- Copyright (C) 2000-2021, 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 94492e9..64c4cb6 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2014-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 9c15845..7ef5f7d 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2014-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 410b6ca..2565204 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2018-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 ec3fbbc..d593f9f 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2018-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 449cf8d..4984a35 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-2020, AdaCore --
+-- Copyright (C) 1995-2021, 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 bab0c5b..6bc026f 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-2020, AdaCore --
+-- Copyright (C) 1995-2021, 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- --
@@ -46,6 +46,8 @@
-- Note: GNAT.Heap_Sort replaces and obsoletes GNAT.Heap_Sort_A, which is
-- retained in the GNAT library for backwards compatibility.
+pragma Compiler_Unit_Warning;
+
package GNAT.Heap_Sort is
pragma Pure;
diff --git a/gcc/ada/libgnat/g-hesora.adb b/gcc/ada/libgnat/g-hesora.adb
index f4610e2..28926dd 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-2020, AdaCore --
+-- Copyright (C) 1995-2021, 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 f7064e4..62dd10b 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-2020, AdaCore --
+-- Copyright (C) 1995-2021, 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 89de591..0575af2 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-2020, AdaCore --
+-- Copyright (C) 1995-2021, 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.ads b/gcc/ada/libgnat/g-hesorg.ads
index e2a3b8e..e24e82d 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-2020, AdaCore --
+-- Copyright (C) 1995-2021, 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 31bce1d..4aeeb1d 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-2020, AdaCore --
+-- Copyright (C) 1995-2021, 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 b7c464d..373b2e9 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-2020, AdaCore --
+-- Copyright (C) 1995-2021, 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 135e435..29307f9 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-2020, AdaCore --
+-- Copyright (C) 1995-2021, 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 c2c1ffa..24b041f 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-2020, AdaCore --
+-- Copyright (C) 1995-2021, 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.ads b/gcc/ada/libgnat/g-io.ads
index 2ba9362..4700347 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-2020, AdaCore --
+-- Copyright (C) 1995-2021, 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 0590199..e904f37 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-2020, AdaCore --
+-- Copyright (C) 1995-2021, 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 aa9978a..a78a168 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-2020, AdaCore --
+-- Copyright (C) 1995-2021, 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 e9414e7..99414f6 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2018-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 29cda7a..3525877b 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2018-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 7112704..75a7d8a 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1998-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 4ef4912..5005ded 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-2020, AdaCore --
+-- Copyright (C) 1995-2021, 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 f89a563..cb7ecd2 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 f3d7e5e..28b66fb 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, 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 2e4498d..a35787b 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 6c65469..d761e18 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, 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 90f2242..b977af0 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2009-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 f599c8b..62131e3 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2009-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 ffc8d02..cd8f7ca 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-2020, AdaCore --
+-- Copyright (C) 2003-2021, 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 cfb9ad9..be74588 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-2020, AdaCore --
+-- Copyright (C) 2003-2021, 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- --
@@ -46,9 +46,9 @@ package GNAT.Memory_Dump is
-- Dumps indicated number (Count) of bytes, starting at the address given
-- by Addr. The coding of this routine in its current form assumes the case
-- of a byte addressable machine (and is therefore inapplicable to machines
- -- like the AAMP, where the storage unit is not 8 bits). The output is one
- -- or more lines in the following format, which is for the case of 32-bit
- -- addresses (64-bit addresses are handled appropriately):
+ -- where the storage unit is not 8 bits). The output is one or more lines
+ -- in the following format, which is for the case of 32-bit addresses
+ -- (64-bit addresses are handled appropriately):
--
-- 0234_3368: 66 67 68 . . . 73 74 75 "fghijklmnopqstuv"
--
diff --git a/gcc/ada/libgnat/g-moreex.adb b/gcc/ada/libgnat/g-moreex.adb
index 6802b4de..f61cd94 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-2020, AdaCore --
+-- Copyright (C) 2000-2021, 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 15c5c67..7b0b87d 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-2020, AdaCore --
+-- Copyright (C) 2000-2021, 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 608f685..0bb7aec 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-2020, AdaCore --
+-- Copyright (C) 1995-2021, 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 c178465..56ce37b 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1995-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 a2c25f1..606656b 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-2020, AdaCore --
+-- Copyright (C) 2002-2021, 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- --
@@ -31,124 +31,18 @@
with Ada.IO_Exceptions; use Ada.IO_Exceptions;
with Ada.Characters.Handling; use Ada.Characters.Handling;
-with Ada.Directories;
-with GNAT.Heap_Sort_G;
-with GNAT.OS_Lib; use GNAT.OS_Lib;
-with GNAT.Table;
+with GNAT.OS_Lib; use GNAT.OS_Lib;
package body GNAT.Perfect_Hash_Generators is
- -- We are using the algorithm of J. Czech as described in Zbigniew J.
- -- Czech, George Havas, and Bohdan S. Majewski ``An Optimal Algorithm for
- -- Generating Minimal Perfect Hash Functions'', Information Processing
- -- Letters, 43(1992) pp.257-264, Oct.1992
-
- -- This minimal perfect hash function generator is based on random graphs
- -- and produces a hash function of the form:
-
- -- h (w) = (g (f1 (w)) + g (f2 (w))) mod m
-
- -- where f1 and f2 are functions that map strings into integers, and g is
- -- a function that maps integers into [0, m-1]. h can be order preserving.
- -- For instance, let W = {w_0, ..., w_i, ..., w_m-1}, h can be defined
- -- such that h (w_i) = i.
-
- -- This algorithm defines two possible constructions of f1 and f2. Method
- -- b) stores the hash function in less memory space at the expense of
- -- greater CPU time.
-
- -- a) fk (w) = sum (for i in 1 .. length (w)) (Tk (i, w (i))) mod n
-
- -- size (Tk) = max (for w in W) (length (w)) * size (used char set)
-
- -- b) fk (w) = sum (for i in 1 .. length (w)) (Tk (i) * w (i)) mod n
-
- -- size (Tk) = max (for w in W) (length (w)) but the table lookups are
- -- replaced by multiplications.
-
- -- where Tk values are randomly generated. n is defined later on but the
- -- algorithm recommends to use a value a little bit greater than 2m. Note
- -- that for large values of m, the main memory space requirements comes
- -- from the memory space for storing function g (>= 2m entries).
-
- -- Random graphs are frequently used to solve difficult problems that do
- -- not have polynomial solutions. This algorithm is based on a weighted
- -- undirected graph. It comprises two steps: mapping and assignment.
-
- -- In the mapping step, a graph G = (V, E) is constructed, where = {0, 1,
- -- ..., n-1} and E = {(for w in W) (f1 (w), f2 (w))}. In order for the
- -- assignment step to be successful, G has to be acyclic. To have a high
- -- probability of generating an acyclic graph, n >= 2m. If it is not
- -- acyclic, Tk have to be regenerated.
-
- -- In the assignment step, the algorithm builds function g. As G is
- -- acyclic, there is a vertex v1 with only one neighbor v2. Let w_i be
- -- the word such that v1 = f1 (w_i) and v2 = f2 (w_i). Let g (v1) = 0 by
- -- construction and g (v2) = (i - g (v1)) mod n (or h (i) - g (v1) mod n).
- -- If word w_j is such that v2 = f1 (w_j) and v3 = f2 (w_j), g (v3) = (j -
- -- g (v2)) mod (or to be general, (h (j) - g (v2)) mod n). If w_i has no
- -- neighbor, then another vertex is selected. The algorithm traverses G to
- -- assign values to all the vertices. It cannot assign a value to an
- -- already assigned vertex as G is acyclic.
-
- subtype Word_Id is Integer;
- subtype Key_Id is Integer;
- subtype Vertex_Id is Integer;
- subtype Edge_Id is Integer;
- subtype Table_Id is Integer;
-
- No_Vertex : constant Vertex_Id := -1;
- No_Edge : constant Edge_Id := -1;
- No_Table : constant Table_Id := -1;
-
- type Word_Type is new String_Access;
- procedure Free_Word (W : in out Word_Type) renames Free;
- function New_Word (S : String) return Word_Type;
-
- procedure Resize_Word (W : in out Word_Type; Len : Natural);
- -- Resize string W to have a length Len
-
- type Key_Type is record
- Edge : Edge_Id;
- end record;
- -- A key corresponds to an edge in the algorithm graph
-
- type Vertex_Type is record
- First : Edge_Id;
- Last : Edge_Id;
- end record;
- -- A vertex can be involved in several edges. First and Last are the bounds
- -- of an array of edges stored in a global edge table.
-
- type Edge_Type is record
- X : Vertex_Id;
- Y : Vertex_Id;
- Key : Key_Id;
- end record;
- -- An edge is a peer of vertices. In the algorithm, a key is associated to
- -- an edge.
-
- package WT is new GNAT.Table (Word_Type, Word_Id, 0, 32, 32);
- package IT is new GNAT.Table (Integer, Integer, 0, 32, 32);
- -- The two main tables. WT is used to store the words in their initial
- -- version and in their reduced version (that is words reduced to their
- -- significant characters). As an instance of GNAT.Table, WT does not
- -- initialize string pointers to null. This initialization has to be done
- -- manually when the table is allocated. IT is used to store several
- -- tables of components containing only integers.
+ use SPHG;
function Image (Int : Integer; W : Natural := 0) return String;
function Image (Str : String; W : Natural := 0) return String;
-- Return a string which includes string Str or integer Int preceded by
-- leading spaces if required by width W.
- function Trim_Trailing_Nuls (Str : String) return String;
- -- Return Str with trailing NUL characters removed
-
- Output : File_Descriptor renames GNAT.OS_Lib.Standout;
- -- Shortcuts
-
EOL : constant Character := ASCII.LF;
Max : constant := 78;
@@ -156,6 +50,12 @@ package body GNAT.Perfect_Hash_Generators is
Line : String (1 .. Max);
-- Use this line to provide buffered IO
+ NK : Natural := 0;
+ -- NK : Number of Keys
+
+ Opt : Optimization;
+ -- Optimization mode (memory vs CPU)
+
procedure Add (C : Character);
procedure Add (S : String);
-- Add a character or a string in Line and update Last
@@ -185,324 +85,21 @@ package body GNAT.Perfect_Hash_Generators is
procedure Put (File : File_Descriptor; Str : String);
-- Simulate Ada.Text_IO.Put with GNAT.OS_Lib
- procedure Put_Used_Char_Set (File : File_Descriptor; Title : String);
- -- Output a title and a used character set
-
- procedure Put_Int_Vector
- (File : File_Descriptor;
- Title : String;
- Vector : Integer;
- Length : Natural);
- -- Output a title and a vector
-
procedure Put_Int_Matrix
(File : File_Descriptor;
Title : String;
- Table : Table_Id;
+ Table : Table_Name;
Len_1 : Natural;
Len_2 : Natural);
-- Output a title and a matrix. When the matrix has only one non-empty
-- dimension (Len_2 = 0), output a vector.
- procedure Put_Edges (File : File_Descriptor; Title : String);
- -- Output a title and an edge table
-
- procedure Put_Initial_Keys (File : File_Descriptor; Title : String);
- -- Output a title and a key table
-
- procedure Put_Reduced_Keys (File : File_Descriptor; Title : String);
- -- Output a title and a key table
-
- procedure Put_Vertex_Table (File : File_Descriptor; Title : String);
- -- Output a title and a vertex table
-
function Ada_File_Base_Name (Pkg_Name : String) return String;
-- Return the base file name (i.e. without .ads/.adb extension) for an
-- Ada source file containing the named package, using the standard GNAT
-- file-naming convention. For example, if Pkg_Name is "Parent.Child", we
-- return "parent-child".
- ----------------------------------
- -- Character Position Selection --
- ----------------------------------
-
- -- We reduce the maximum key size by selecting representative positions
- -- in these keys. We build a matrix with one word per line. We fill the
- -- remaining space of a line with ASCII.NUL. The heuristic selects the
- -- position that induces the minimum number of collisions. If there are
- -- collisions, select another position on the reduced key set responsible
- -- of the collisions. Apply the heuristic until there is no more collision.
-
- procedure Apply_Position_Selection;
- -- Apply Position selection and build the reduced key table
-
- procedure Parse_Position_Selection (Argument : String);
- -- Parse Argument and compute the position set. Argument is list of
- -- substrings separated by commas. Each substring represents a position
- -- or a range of positions (like x-y).
-
- procedure Select_Character_Set;
- -- Define an optimized used character set like Character'Pos in order not
- -- to allocate tables of 256 entries.
-
- procedure Select_Char_Position;
- -- Find a min char position set in order to reduce the max key length. The
- -- heuristic selects the position that induces the minimum number of
- -- collisions. If there are collisions, select another position on the
- -- reduced key set responsible of the collisions. Apply the heuristic until
- -- there is no collision.
-
- -----------------------------
- -- Random Graph Generation --
- -----------------------------
-
- procedure Random (Seed : in out Natural);
- -- Simulate Ada.Discrete_Numerics.Random
-
- procedure Generate_Mapping_Table
- (Tab : Table_Id;
- L1 : Natural;
- L2 : Natural;
- Seed : in out Natural);
- -- Random generation of the tables below. T is already allocated
-
- procedure Generate_Mapping_Tables
- (Opt : Optimization;
- Seed : in out Natural);
- -- Generate the mapping tables T1 and T2. They are used to define fk (w) =
- -- sum (for i in 1 .. length (w)) (Tk (i, w (i))) mod n. Keys, NK and Chars
- -- are used to compute the matrix size.
-
- ---------------------------
- -- Algorithm Computation --
- ---------------------------
-
- procedure Compute_Edges_And_Vertices (Opt : Optimization);
- -- Compute the edge and vertex tables. These are empty when a self loop is
- -- detected (f1 (w) = f2 (w)). The edge table is sorted by X value and then
- -- Y value. Keys is the key table and NK the number of keys. Chars is the
- -- set of characters really used in Keys. NV is the number of vertices
- -- recommended by the algorithm. T1 and T2 are the mapping tables needed to
- -- compute f1 (w) and f2 (w).
-
- function Acyclic return Boolean;
- -- Return True when the graph is acyclic. Vertices is the current vertex
- -- table and Edges the current edge table.
-
- procedure Assign_Values_To_Vertices;
- -- Execute the assignment step of the algorithm. Keys is the current key
- -- table. Vertices and Edges represent the random graph. G is the result of
- -- the assignment step such that:
- -- h (w) = (g (f1 (w)) + g (f2 (w))) mod m
-
- function Sum
- (Word : Word_Type;
- Table : Table_Id;
- Opt : Optimization) return Natural;
- -- For an optimization of CPU_Time return
- -- fk (w) = sum (for i in 1 .. length (w)) (Tk (i, w (i))) mod n
- -- For an optimization of Memory_Space return
- -- fk (w) = sum (for i in 1 .. length (w)) (Tk (i) * w (i)) mod n
- -- Here NV = n
-
- -------------------------------
- -- Internal Table Management --
- -------------------------------
-
- function Allocate (N : Natural; S : Natural := 1) return Table_Id;
- -- Allocate N * S ints from IT table
-
- ----------
- -- Keys --
- ----------
-
- Keys : Table_Id := No_Table;
- NK : Natural := 0;
- -- NK : Number of Keys
-
- function Initial (K : Key_Id) return Word_Id;
- pragma Inline (Initial);
-
- function Reduced (K : Key_Id) return Word_Id;
- pragma Inline (Reduced);
-
- function Get_Key (N : Key_Id) return Key_Type;
- procedure Set_Key (N : Key_Id; Item : Key_Type);
- -- Get or Set Nth element of Keys table
-
- ------------------
- -- Char_Pos_Set --
- ------------------
-
- Char_Pos_Set : Table_Id := No_Table;
- Char_Pos_Set_Len : Natural;
- -- Character Selected Position Set
-
- function Get_Char_Pos (P : Natural) return Natural;
- procedure Set_Char_Pos (P : Natural; Item : Natural);
- -- Get or Set the string position of the Pth selected character
-
- -------------------
- -- Used_Char_Set --
- -------------------
-
- Used_Char_Set : Table_Id := No_Table;
- Used_Char_Set_Len : Natural;
- -- Used Character Set : Define a new character mapping. When all the
- -- characters are not present in the keys, in order to reduce the size
- -- of some tables, we redefine the character mapping.
-
- function Get_Used_Char (C : Character) return Natural;
- procedure Set_Used_Char (C : Character; Item : Natural);
-
- ------------
- -- Tables --
- ------------
-
- T1 : Table_Id := No_Table;
- T2 : Table_Id := No_Table;
- T1_Len : Natural;
- T2_Len : Natural;
- -- T1 : Values table to compute F1
- -- T2 : Values table to compute F2
-
- function Get_Table (T : Integer; X, Y : Natural) return Natural;
- procedure Set_Table (T : Integer; X, Y : Natural; Item : Natural);
-
- -----------
- -- Graph --
- -----------
-
- G : Table_Id := No_Table;
- G_Len : Natural;
- -- Values table to compute G
-
- NT : Natural := Default_Tries;
- -- Number of tries running the algorithm before raising an error
-
- function Get_Graph (N : Natural) return Integer;
- procedure Set_Graph (N : Natural; Item : Integer);
- -- Get or Set Nth element of graph
-
- -----------
- -- Edges --
- -----------
-
- Edge_Size : constant := 3;
- Edges : Table_Id := No_Table;
- Edges_Len : Natural;
- -- Edges : Edge table of the random graph G
-
- function Get_Edges (F : Natural) return Edge_Type;
- procedure Set_Edges (F : Natural; Item : Edge_Type);
-
- --------------
- -- Vertices --
- --------------
-
- Vertex_Size : constant := 2;
-
- Vertices : Table_Id := No_Table;
- -- Vertex table of the random graph G
-
- NV : Natural;
- -- Number of Vertices
-
- function Get_Vertices (F : Natural) return Vertex_Type;
- procedure Set_Vertices (F : Natural; Item : Vertex_Type);
- -- Comments needed ???
-
- K2V : Float;
- -- Ratio between Keys and Vertices (parameter of Czech's algorithm)
-
- Opt : Optimization;
- -- Optimization mode (memory vs CPU)
-
- Max_Key_Len : Natural := 0;
- Min_Key_Len : Natural := 0;
- -- Maximum and minimum of all the word length
-
- S : Natural;
- -- Seed
-
- function Type_Size (L : Natural) return Natural;
- -- Given the last L of an unsigned integer type T, return its size
-
- -------------
- -- Acyclic --
- -------------
-
- function Acyclic return Boolean is
- Marks : array (0 .. NV - 1) of Vertex_Id := (others => No_Vertex);
-
- function Traverse (Edge : Edge_Id; Mark : Vertex_Id) return Boolean;
- -- Propagate Mark from X to Y. X is already marked. Mark Y and propagate
- -- it to the edges of Y except the one representing the same key. Return
- -- False when Y is marked with Mark.
-
- --------------
- -- Traverse --
- --------------
-
- function Traverse (Edge : Edge_Id; Mark : Vertex_Id) return Boolean is
- E : constant Edge_Type := Get_Edges (Edge);
- K : constant Key_Id := E.Key;
- Y : constant Vertex_Id := E.Y;
- M : constant Vertex_Id := Marks (E.Y);
- V : Vertex_Type;
-
- begin
- if M = Mark then
- return False;
-
- elsif M = No_Vertex then
- Marks (Y) := Mark;
- V := Get_Vertices (Y);
-
- for J in V.First .. V.Last loop
-
- -- Do not propagate to the edge representing the same key
-
- if Get_Edges (J).Key /= K
- and then not Traverse (J, Mark)
- then
- return False;
- end if;
- end loop;
- end if;
-
- return True;
- end Traverse;
-
- Edge : Edge_Type;
-
- -- Start of processing for Acyclic
-
- begin
- -- Edges valid range is
-
- for J in 1 .. Edges_Len - 1 loop
-
- Edge := Get_Edges (J);
-
- -- Mark X of E when it has not been already done
-
- if Marks (Edge.X) = No_Vertex then
- Marks (Edge.X) := Edge.X;
- end if;
-
- -- Traverse E when this has not already been done
-
- if Marks (Edge.Y) = No_Vertex
- and then not Traverse (J, Edge.X)
- then
- return False;
- end if;
- end loop;
-
- return True;
- end Acyclic;
-
------------------------
-- Ada_File_Base_Name --
------------------------
@@ -547,559 +144,25 @@ package body GNAT.Perfect_Hash_Generators is
Last := Last + Len;
end Add;
- --------------
- -- Allocate --
- --------------
-
- function Allocate (N : Natural; S : Natural := 1) return Table_Id is
- L : constant Integer := IT.Last;
- begin
- IT.Set_Last (L + N * S);
-
- -- Initialize, so debugging printouts don't trip over uninitialized
- -- components.
-
- for J in L + 1 .. IT.Last loop
- IT.Table (J) := -1;
- end loop;
-
- return L + 1;
- end Allocate;
-
- ------------------------------
- -- Apply_Position_Selection --
- ------------------------------
-
- procedure Apply_Position_Selection is
- begin
- for J in 0 .. NK - 1 loop
- declare
- IW : constant String := WT.Table (Initial (J)).all;
- RW : String (1 .. IW'Length) := (others => ASCII.NUL);
- N : Natural := IW'First - 1;
-
- begin
- -- Select the characters of Word included in the position
- -- selection.
-
- for C in 0 .. Char_Pos_Set_Len - 1 loop
- exit when IW (Get_Char_Pos (C)) = ASCII.NUL;
- N := N + 1;
- RW (N) := IW (Get_Char_Pos (C));
- end loop;
-
- -- Build the new table with the reduced word. Be careful
- -- to deallocate the old version to avoid memory leaks.
-
- Free_Word (WT.Table (Reduced (J)));
- WT.Table (Reduced (J)) := New_Word (RW);
- Set_Key (J, (Edge => No_Edge));
- end;
- end loop;
- end Apply_Position_Selection;
-
- -------------------------------
- -- Assign_Values_To_Vertices --
- -------------------------------
-
- procedure Assign_Values_To_Vertices is
- X : Vertex_Id;
-
- procedure Assign (X : Vertex_Id);
- -- Execute assignment on X's neighbors except the vertex that we are
- -- coming from which is already assigned.
-
- ------------
- -- Assign --
- ------------
-
- procedure Assign (X : Vertex_Id) is
- E : Edge_Type;
- V : constant Vertex_Type := Get_Vertices (X);
-
- begin
- for J in V.First .. V.Last loop
- 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;
- end loop;
- end Assign;
-
- -- Start of processing for Assign_Values_To_Vertices
-
- begin
- -- Value -1 denotes an uninitialized value as it is supposed to
- -- be in the range 0 .. NK.
-
- if G = No_Table then
- G_Len := NV;
- G := Allocate (G_Len, 1);
- end if;
-
- for J in 0 .. G_Len - 1 loop
- Set_Graph (J, -1);
- end loop;
-
- for K in 0 .. NK - 1 loop
- X := Get_Edges (Get_Key (K).Edge).X;
-
- if Get_Graph (X) = -1 then
- Set_Graph (X, 0);
- Assign (X);
- end if;
- end loop;
-
- for J in 0 .. G_Len - 1 loop
- if Get_Graph (J) = -1 then
- Set_Graph (J, 0);
- end if;
- end loop;
-
- if Verbose then
- Put_Int_Vector (Output, "Assign Values To Vertices", G, G_Len);
- end if;
- end Assign_Values_To_Vertices;
-
-------------
-- Compute --
-------------
procedure Compute (Position : String := Default_Position) is
- Success : Boolean := False;
-
begin
- if NK = 0 then
- raise Program_Error with "keywords set cannot be empty";
- end if;
-
- if Verbose then
- Put_Initial_Keys (Output, "Initial Key Table");
- end if;
-
- if Position'Length /= 0 then
- Parse_Position_Selection (Position);
- else
- Select_Char_Position;
- end if;
-
- if Verbose then
- Put_Int_Vector
- (Output, "Char Position Set", Char_Pos_Set, Char_Pos_Set_Len);
- end if;
-
- Apply_Position_Selection;
-
- if Verbose then
- Put_Reduced_Keys (Output, "Reduced Keys Table");
- end if;
-
- Select_Character_Set;
-
- if Verbose then
- Put_Used_Char_Set (Output, "Character Position Table");
- end if;
-
- -- Perform Czech's algorithm
-
- for J in 1 .. NT loop
- Generate_Mapping_Tables (Opt, S);
- Compute_Edges_And_Vertices (Opt);
-
- -- When graph is not empty (no self-loop from previous operation) and
- -- not acyclic.
-
- if 0 < Edges_Len and then Acyclic then
- Success := True;
- exit;
- end if;
- end loop;
-
- if not Success then
- raise Too_Many_Tries;
- end if;
-
- Assign_Values_To_Vertices;
+ SPHG.Compute (Position);
end Compute;
- --------------------------------
- -- Compute_Edges_And_Vertices --
- --------------------------------
-
- procedure Compute_Edges_And_Vertices (Opt : Optimization) is
- X : Natural;
- Y : Natural;
- Key : Key_Type;
- Edge : Edge_Type;
- Vertex : Vertex_Type;
- Not_Acyclic : Boolean := False;
-
- procedure Move (From : Natural; To : Natural);
- function Lt (L, R : Natural) return Boolean;
- -- Subprograms needed for GNAT.Heap_Sort_G
-
- --------
- -- Lt --
- --------
-
- function Lt (L, R : Natural) return Boolean is
- EL : constant Edge_Type := Get_Edges (L);
- ER : constant Edge_Type := Get_Edges (R);
- begin
- return EL.X < ER.X or else (EL.X = ER.X and then EL.Y < ER.Y);
- end Lt;
-
- ----------
- -- Move --
- ----------
-
- procedure Move (From : Natural; To : Natural) is
- begin
- Set_Edges (To, Get_Edges (From));
- end Move;
-
- package Sorting is new GNAT.Heap_Sort_G (Move, Lt);
-
- -- Start of processing for Compute_Edges_And_Vertices
-
- begin
- -- We store edges from 1 to 2 * NK and leave zero alone in order to use
- -- GNAT.Heap_Sort_G.
-
- Edges_Len := 2 * NK + 1;
-
- if Edges = No_Table then
- Edges := Allocate (Edges_Len, Edge_Size);
- end if;
-
- if Vertices = No_Table then
- Vertices := Allocate (NV, Vertex_Size);
- end if;
-
- for J in 0 .. NV - 1 loop
- Set_Vertices (J, (No_Vertex, No_Vertex - 1));
- end loop;
-
- -- For each w, X = f1 (w) and Y = f2 (w)
-
- for J in 0 .. NK - 1 loop
- Key := Get_Key (J);
- Key.Edge := No_Edge;
- Set_Key (J, Key);
-
- X := Sum (WT.Table (Reduced (J)), T1, Opt);
- Y := Sum (WT.Table (Reduced (J)), T2, Opt);
-
- -- Discard T1 and T2 as soon as we discover a self loop
-
- if X = Y then
- Not_Acyclic := True;
- exit;
- end if;
-
- -- We store (X, Y) and (Y, X) to ease assignment step
-
- Set_Edges (2 * J + 1, (X, Y, J));
- Set_Edges (2 * J + 2, (Y, X, J));
- end loop;
-
- -- Return an empty graph when self loop detected
-
- if Not_Acyclic then
- Edges_Len := 0;
-
- else
- if Verbose then
- Put_Edges (Output, "Unsorted Edge Table");
- Put_Int_Matrix (Output, "Function Table 1", T1,
- T1_Len, T2_Len);
- Put_Int_Matrix (Output, "Function Table 2", T2,
- T1_Len, T2_Len);
- end if;
-
- -- Enforce consistency between edges and keys. Construct Vertices and
- -- compute the list of neighbors of a vertex First .. Last as Edges
- -- is sorted by X and then Y. To compute the neighbor list, sort the
- -- edges.
-
- Sorting.Sort (Edges_Len - 1);
-
- if Verbose then
- Put_Edges (Output, "Sorted Edge Table");
- Put_Int_Matrix (Output, "Function Table 1", T1,
- T1_Len, T2_Len);
- Put_Int_Matrix (Output, "Function Table 2", T2,
- T1_Len, T2_Len);
- end if;
-
- -- Edges valid range is 1 .. 2 * NK
-
- for E in 1 .. Edges_Len - 1 loop
- Edge := Get_Edges (E);
- Key := Get_Key (Edge.Key);
-
- if Key.Edge = No_Edge then
- Key.Edge := E;
- Set_Key (Edge.Key, Key);
- end if;
-
- Vertex := Get_Vertices (Edge.X);
-
- if Vertex.First = No_Edge then
- Vertex.First := E;
- end if;
-
- Vertex.Last := E;
- Set_Vertices (Edge.X, Vertex);
- end loop;
-
- if Verbose then
- Put_Reduced_Keys (Output, "Key Table");
- Put_Edges (Output, "Edge Table");
- Put_Vertex_Table (Output, "Vertex Table");
- end if;
- end if;
- end Compute_Edges_And_Vertices;
-
- ------------
- -- Define --
- ------------
-
- procedure Define
- (Name : Table_Name;
- Item_Size : out Natural;
- Length_1 : out Natural;
- Length_2 : out Natural)
- is
- begin
- case Name is
- when Character_Position =>
- Item_Size := 8;
- Length_1 := Char_Pos_Set_Len;
- Length_2 := 0;
-
- when Used_Character_Set =>
- Item_Size := 8;
- Length_1 := 256;
- Length_2 := 0;
-
- when Function_Table_1
- | Function_Table_2
- =>
- Item_Size := Type_Size (NV);
- Length_1 := T1_Len;
- Length_2 := T2_Len;
-
- when Graph_Table =>
- Item_Size := Type_Size (NK);
- Length_1 := NV;
- Length_2 := 0;
- end case;
- end Define;
-
--------------
-- Finalize --
--------------
procedure Finalize is
begin
- if Verbose then
- Put (Output, "Finalize");
- New_Line (Output);
- end if;
-
- -- Deallocate all the WT components (both initial and reduced ones) to
- -- avoid memory leaks.
-
- for W in 0 .. WT.Last loop
-
- -- Note: WT.Table (NK) is a temporary variable, do not free it since
- -- this would cause a double free.
-
- if W /= NK then
- Free_Word (WT.Table (W));
- end if;
- end loop;
-
- WT.Release;
- IT.Release;
-
- -- Reset all variables for next usage
-
- Keys := No_Table;
-
- Char_Pos_Set := No_Table;
- Char_Pos_Set_Len := 0;
-
- Used_Char_Set := No_Table;
- Used_Char_Set_Len := 0;
-
- T1 := No_Table;
- T2 := No_Table;
-
- T1_Len := 0;
- T2_Len := 0;
-
- G := No_Table;
- G_Len := 0;
-
- Edges := No_Table;
- Edges_Len := 0;
-
- Vertices := No_Table;
- NV := 0;
-
NK := 0;
- Max_Key_Len := 0;
- Min_Key_Len := 0;
+ SPHG.Finalize;
end Finalize;
- ----------------------------
- -- Generate_Mapping_Table --
- ----------------------------
-
- procedure Generate_Mapping_Table
- (Tab : Integer;
- L1 : Natural;
- L2 : Natural;
- Seed : in out Natural)
- is
- begin
- for J in 0 .. L1 - 1 loop
- for K in 0 .. L2 - 1 loop
- Random (Seed);
- Set_Table (Tab, J, K, Seed mod NV);
- end loop;
- end loop;
- end Generate_Mapping_Table;
-
- -----------------------------
- -- Generate_Mapping_Tables --
- -----------------------------
-
- procedure Generate_Mapping_Tables
- (Opt : Optimization;
- Seed : in out Natural)
- is
- begin
- -- If T1 and T2 are already allocated no need to do it twice. Reuse them
- -- as their size has not changed.
-
- if T1 = No_Table and then T2 = No_Table then
- declare
- Used_Char_Last : Natural := 0;
- Used_Char : Natural;
-
- begin
- if Opt = CPU_Time then
- for P in reverse Character'Range loop
- Used_Char := Get_Used_Char (P);
- if Used_Char /= 0 then
- Used_Char_Last := Used_Char;
- exit;
- end if;
- end loop;
- end if;
-
- T1_Len := Char_Pos_Set_Len;
- T2_Len := Used_Char_Last + 1;
- T1 := Allocate (T1_Len * T2_Len);
- T2 := Allocate (T1_Len * T2_Len);
- end;
- end if;
-
- Generate_Mapping_Table (T1, T1_Len, T2_Len, Seed);
- Generate_Mapping_Table (T2, T1_Len, T2_Len, Seed);
-
- if Verbose then
- Put_Used_Char_Set (Output, "Used Character Set");
- Put_Int_Matrix (Output, "Function Table 1", T1,
- T1_Len, T2_Len);
- Put_Int_Matrix (Output, "Function Table 2", T2,
- T1_Len, T2_Len);
- end if;
- end Generate_Mapping_Tables;
-
- ------------------
- -- Get_Char_Pos --
- ------------------
-
- function Get_Char_Pos (P : Natural) return Natural is
- N : constant Natural := Char_Pos_Set + P;
- begin
- return IT.Table (N);
- end Get_Char_Pos;
-
- ---------------
- -- Get_Edges --
- ---------------
-
- function Get_Edges (F : Natural) return Edge_Type is
- N : constant Natural := Edges + (F * Edge_Size);
- E : Edge_Type;
- begin
- E.X := IT.Table (N);
- E.Y := IT.Table (N + 1);
- E.Key := IT.Table (N + 2);
- return E;
- end Get_Edges;
-
- ---------------
- -- Get_Graph --
- ---------------
-
- function Get_Graph (N : Natural) return Integer is
- begin
- return IT.Table (G + N);
- end Get_Graph;
-
- -------------
- -- Get_Key --
- -------------
-
- function Get_Key (N : Key_Id) return Key_Type is
- K : Key_Type;
- begin
- K.Edge := IT.Table (Keys + N);
- return K;
- end Get_Key;
-
- ---------------
- -- Get_Table --
- ---------------
-
- function Get_Table (T : Integer; X, Y : Natural) return Natural is
- N : constant Natural := T + (Y * T1_Len) + X;
- begin
- return IT.Table (N);
- end Get_Table;
-
- -------------------
- -- Get_Used_Char --
- -------------------
-
- function Get_Used_Char (C : Character) return Natural is
- N : constant Natural := Used_Char_Set + Character'Pos (C);
- begin
- return IT.Table (N);
- end Get_Used_Char;
-
- ------------------
- -- Get_Vertices --
- ------------------
-
- function Get_Vertices (F : Natural) return Vertex_Type is
- N : constant Natural := Vertices + (F * Vertex_Size);
- V : Vertex_Type;
- begin
- V.First := IT.Table (N);
- V.Last := IT.Table (N + 1);
- return V;
- end Get_Vertices;
-
-----------
-- Image --
-----------
@@ -1164,15 +227,6 @@ package body GNAT.Perfect_Hash_Generators is
end;
end Image;
- -------------
- -- Initial --
- -------------
-
- function Initial (K : Key_Id) return Word_Id is
- begin
- return K;
- end Initial;
-
----------------
-- Initialize --
----------------
@@ -1183,87 +237,11 @@ package body GNAT.Perfect_Hash_Generators is
Optim : Optimization := Memory_Space;
Tries : Positive := Default_Tries)
is
- begin
- if Verbose then
- Put (Output, "Initialize");
- New_Line (Output);
- end if;
-
- -- Deallocate the part of the table concerning the reduced words.
- -- Initial words are already present in the table. We may have reduced
- -- words already there because a previous computation failed. We are
- -- currently retrying and the reduced words have to be deallocated.
-
- for W in Reduced (0) .. WT.Last loop
- Free_Word (WT.Table (W));
- end loop;
-
- IT.Init;
-
- -- Initialize of computation variables
-
- Keys := No_Table;
-
- Char_Pos_Set := No_Table;
- Char_Pos_Set_Len := 0;
-
- Used_Char_Set := No_Table;
- Used_Char_Set_Len := 0;
-
- T1 := No_Table;
- T2 := No_Table;
-
- T1_Len := 0;
- T2_Len := 0;
-
- G := No_Table;
- G_Len := 0;
-
- Edges := No_Table;
- Edges_Len := 0;
+ V : constant Positive := Positive (Float (NK) * K_To_V);
- Vertices := No_Table;
- NV := 0;
-
- S := Seed;
- K2V := K_To_V;
- Opt := Optim;
- NT := Tries;
-
- if K2V <= 2.0 then
- raise Program_Error with "K to V ratio cannot be lower than 2.0";
- end if;
-
- -- Do not accept a value of K2V too close to 2.0 such that once
- -- rounded up, NV = 2 * NK because the algorithm would not converge.
-
- NV := Natural (Float (NK) * K2V);
- if NV <= 2 * NK then
- NV := 2 * NK + 1;
- end if;
-
- Keys := Allocate (NK);
-
- -- Resize initial words to have all of them at the same size
- -- (so the size of the largest one).
-
- for K in 0 .. NK - 1 loop
- Resize_Word (WT.Table (Initial (K)), Max_Key_Len);
- end loop;
-
- -- Allocated the table to store the reduced words. As WT is a
- -- GNAT.Table (using C memory management), pointers have to be
- -- explicitly initialized to null.
-
- WT.Set_Last (Reduced (NK - 1));
-
- -- Note: Reduced (0) = NK + 1
-
- WT.Table (NK) := null;
-
- for W in 0 .. NK - 1 loop
- WT.Table (Reduced (W)) := null;
- end loop;
+ begin
+ Opt := Optim;
+ SPHG.Initialize (Seed, V, SPHG.Optimization (Optim), Tries);
end Initialize;
------------
@@ -1271,30 +249,9 @@ package body GNAT.Perfect_Hash_Generators is
------------
procedure Insert (Value : String) is
- Len : constant Natural := Value'Length;
-
begin
- if Verbose then
- Put (Output, "Inserting """ & Value & """");
- New_Line (Output);
- end if;
-
- for J in Value'Range loop
- pragma Assert (Value (J) /= ASCII.NUL);
- null;
- end loop;
-
- WT.Set_Last (NK);
- WT.Table (NK) := New_Word (Value);
NK := NK + 1;
-
- if Max_Key_Len < Len then
- Max_Key_Len := Len;
- end if;
-
- if Min_Key_Len = 0 or else Len < Min_Key_Len then
- Min_Key_Len := Len;
- end if;
+ SPHG.Insert (Value);
end Insert;
--------------
@@ -1308,126 +265,6 @@ package body GNAT.Perfect_Hash_Generators is
end if;
end New_Line;
- --------------
- -- New_Word --
- --------------
-
- function New_Word (S : String) return Word_Type is
- begin
- return new String'(S);
- end New_Word;
-
- ------------------------------
- -- Parse_Position_Selection --
- ------------------------------
-
- procedure Parse_Position_Selection (Argument : String) is
- N : Natural := Argument'First;
- L : constant Natural := Argument'Last;
- M : constant Natural := Max_Key_Len;
-
- T : array (1 .. M) of Boolean := (others => False);
-
- function Parse_Index return Natural;
- -- Parse argument starting at index N to find an index
-
- -----------------
- -- Parse_Index --
- -----------------
-
- function Parse_Index return Natural is
- C : Character := Argument (N);
- V : Natural := 0;
-
- begin
- if C = '$' then
- N := N + 1;
- return M;
- end if;
-
- if C not in '0' .. '9' then
- raise Program_Error with "cannot read position argument";
- end if;
-
- while C in '0' .. '9' loop
- V := V * 10 + (Character'Pos (C) - Character'Pos ('0'));
- N := N + 1;
- exit when L < N;
- C := Argument (N);
- end loop;
-
- return V;
- end Parse_Index;
-
- -- Start of processing for Parse_Position_Selection
-
- begin
- -- Empty specification means all the positions
-
- if L < N then
- Char_Pos_Set_Len := M;
- Char_Pos_Set := Allocate (Char_Pos_Set_Len);
-
- for C in 0 .. Char_Pos_Set_Len - 1 loop
- Set_Char_Pos (C, C + 1);
- end loop;
-
- else
- loop
- declare
- First, Last : Natural;
-
- begin
- First := Parse_Index;
- Last := First;
-
- -- Detect a range
-
- if N <= L and then Argument (N) = '-' then
- N := N + 1;
- Last := Parse_Index;
- end if;
-
- -- Include the positions in the selection
-
- for J in First .. Last loop
- T (J) := True;
- end loop;
- end;
-
- exit when L < N;
-
- if Argument (N) /= ',' then
- raise Program_Error with "cannot read position argument";
- end if;
-
- N := N + 1;
- end loop;
-
- -- Compute position selection length
-
- N := 0;
- for J in T'Range loop
- if T (J) then
- N := N + 1;
- end if;
- end loop;
-
- -- Fill position selection
-
- Char_Pos_Set_Len := N;
- Char_Pos_Set := Allocate (Char_Pos_Set_Len);
-
- N := 0;
- for J in T'Range loop
- if T (J) then
- Set_Char_Pos (N, J);
- N := N + 1;
- end if;
- end loop;
- end if;
- end Parse_Position_Selection;
-
-------------
-- Produce --
-------------
@@ -1438,6 +275,9 @@ package body GNAT.Perfect_Hash_Generators is
is
File : File_Descriptor := Standout;
+ Siz, L1, L2 : Natural;
+ -- For calls to Define
+
Status : Boolean;
-- For call to Close
@@ -1447,8 +287,8 @@ package body GNAT.Perfect_Hash_Generators is
function Range_Img (F, L : Natural; T : String := "") return String;
-- Return string "[T range ]F .. L"
- function Type_Img (L : Natural) return String;
- -- Return the larger unsigned type T such that T'Last < L
+ function Type_Img (Siz : Positive) return String;
+ -- Return the name of the unsigned type of size S
---------------
-- Array_Img --
@@ -1510,8 +350,8 @@ package body GNAT.Perfect_Hash_Generators is
-- Type_Img --
--------------
- function Type_Img (L : Natural) return String is
- S : constant String := Image (Type_Size (L));
+ function Type_Img (Siz : Positive) return String is
+ S : constant String := Image (Siz);
U : String := "Unsigned_ ";
N : Natural := 9;
@@ -1524,8 +364,6 @@ package body GNAT.Perfect_Hash_Generators is
return U (1 .. N);
end Type_Img;
- F : Natural;
- L : Natural;
P : Natural;
FName : String := Ada_File_Base_Name (Pkg_Name) & ".ads";
@@ -1535,13 +373,6 @@ package body GNAT.Perfect_Hash_Generators is
-- Start of processing for Produce
begin
-
- if Verbose and then not Use_Stdout then
- Put (Output,
- "Producing " & Ada.Directories.Current_Directory & "/" & FName);
- New_Line (Output);
- end if;
-
if not Use_Stdout then
File := Create_File (FName, Binary);
@@ -1592,75 +423,89 @@ package body GNAT.Perfect_Hash_Generators is
New_Line (File);
if Opt = CPU_Time then
- Put (File, Array_Img ("C", Type_Img (256), "Character"));
- New_Line (File);
+ -- The format of this table is fixed
- F := Character'Pos (Character'First);
- L := Character'Pos (Character'Last);
+ Define (Used_Character_Set, Siz, L1, L2);
+ pragma Assert (L1 = 256 and then L2 = 0);
+
+ Put (File, Array_Img ("C", Type_Img (Siz), "Character"));
+ New_Line (File);
- for J in Character'Range loop
- P := Get_Used_Char (J);
- Put (File, Image (P), 1, 0, 1, F, L, Character'Pos (J));
+ for J in 0 .. 255 loop
+ P := Value (Used_Character_Set, J);
+ Put (File, Image (P), 1, 0, 1, 0, 255, J);
end loop;
New_Line (File);
end if;
- F := 0;
- L := Char_Pos_Set_Len - 1;
+ Define (Character_Position, Siz, L1, L2);
+ pragma Assert (Siz = 31 and then L2 = 0);
- Put (File, Array_Img ("P", "Natural", Range_Img (F, L)));
+ Put (File, Array_Img ("P", "Natural", Range_Img (0, L1 - 1)));
New_Line (File);
- for J in F .. L loop
- Put (File, Image (Get_Char_Pos (J)), 1, 0, 1, F, L, J);
+ for J in 0 .. L1 - 1 loop
+ P := Value (Character_Position, J);
+ Put (File, Image (P), 1, 0, 1, 0, L1 - 1, J);
end loop;
New_Line (File);
+ Define (Function_Table_1, Siz, L1, L2);
+
case Opt is
when CPU_Time =>
Put_Int_Matrix
(File,
- Array_Img ("T1", Type_Img (NV),
- Range_Img (0, T1_Len - 1),
- Range_Img (0, T2_Len - 1, Type_Img (256))),
- T1, T1_Len, T2_Len);
+ Array_Img ("T1", Type_Img (Siz),
+ Range_Img (0, L1 - 1),
+ Range_Img (0, L2 - 1, Type_Img (8))),
+ Function_Table_1, L1, L2);
when Memory_Space =>
Put_Int_Matrix
(File,
- Array_Img ("T1", Type_Img (NV),
- Range_Img (0, T1_Len - 1)),
- T1, T1_Len, 0);
+ Array_Img ("T1", Type_Img (Siz),
+ Range_Img (0, L1 - 1)),
+ Function_Table_1, L1, 0);
end case;
New_Line (File);
+ Define (Function_Table_2, Siz, L1, L2);
+
case Opt is
when CPU_Time =>
Put_Int_Matrix
(File,
- Array_Img ("T2", Type_Img (NV),
- Range_Img (0, T1_Len - 1),
- Range_Img (0, T2_Len - 1, Type_Img (256))),
- T2, T1_Len, T2_Len);
+ Array_Img ("T2", Type_Img (Siz),
+ Range_Img (0, L1 - 1),
+ Range_Img (0, L2 - 1, Type_Img (8))),
+ Function_Table_2, L1, L2);
when Memory_Space =>
Put_Int_Matrix
(File,
- Array_Img ("T2", Type_Img (NV),
- Range_Img (0, T1_Len - 1)),
- T2, T1_Len, 0);
+ Array_Img ("T2", Type_Img (Siz),
+ Range_Img (0, L1 - 1)),
+ Function_Table_2, L1, 0);
end case;
New_Line (File);
- Put_Int_Vector
- (File,
- Array_Img ("G", Type_Img (NK),
- Range_Img (0, G_Len - 1)),
- G, G_Len);
+ Define (Graph_Table, Siz, L1, L2);
+ pragma Assert (L2 = 0);
+
+ Put (File, Array_Img ("G", Type_Img (Siz),
+ Range_Img (0, L1 - 1)));
+ New_Line (File);
+
+ for J in 0 .. L1 - 1 loop
+ P := Value (Graph_Table, J);
+ Put (File, Image (P), 1, 0, 1, 0, L1 - 1, J);
+ end loop;
+
New_Line (File);
Put (File, " function Hash (S : String) return Natural is");
@@ -1676,7 +521,7 @@ package body GNAT.Perfect_Hash_Generators is
case Opt is
when CPU_Time =>
- Put (File, Type_Img (256));
+ Put (File, Type_Img (8));
when Memory_Space =>
Put (File, "Natural");
@@ -1717,7 +562,7 @@ package body GNAT.Perfect_Hash_Generators is
end if;
Put (File, ") mod ");
- Put (File, Image (NV));
+ Put (File, Image (L1));
Put (File, ";");
New_Line (File);
@@ -1734,7 +579,7 @@ package body GNAT.Perfect_Hash_Generators is
end if;
Put (File, ") mod ");
- Put (File, Image (NV));
+ Put (File, Image (L1));
Put (File, ";");
New_Line (File);
@@ -1874,54 +719,6 @@ package body GNAT.Perfect_Hash_Generators is
end if;
end Put;
- ---------------
- -- Put_Edges --
- ---------------
-
- procedure Put_Edges (File : File_Descriptor; Title : String) is
- E : Edge_Type;
- F1 : constant Natural := 1;
- L1 : constant Natural := Edges_Len - 1;
- M : constant Natural := Max / 5;
-
- begin
- Put (File, Title);
- New_Line (File);
-
- -- Edges valid range is 1 .. Edge_Len - 1
-
- for J in F1 .. L1 loop
- E := Get_Edges (J);
- Put (File, Image (J, M), F1, L1, J, 1, 4, 1);
- Put (File, Image (E.X, M), F1, L1, J, 1, 4, 2);
- Put (File, Image (E.Y, M), F1, L1, J, 1, 4, 3);
- Put (File, Image (E.Key, M), F1, L1, J, 1, 4, 4);
- end loop;
- end Put_Edges;
-
- ----------------------
- -- Put_Initial_Keys --
- ----------------------
-
- procedure Put_Initial_Keys (File : File_Descriptor; Title : String) is
- F1 : constant Natural := 0;
- L1 : constant Natural := NK - 1;
- M : constant Natural := Max / 5;
- K : Key_Type;
-
- begin
- Put (File, Title);
- New_Line (File);
-
- for J in F1 .. L1 loop
- K := Get_Key (J);
- Put (File, Image (J, M), F1, L1, J, 1, 3, 1);
- Put (File, Image (K.Edge, M), F1, L1, J, 1, 3, 2);
- Put (File, Trim_Trailing_Nuls (WT.Table (Initial (J)).all),
- F1, L1, J, 1, 3, 3);
- end loop;
- end Put_Initial_Keys;
-
--------------------
-- Put_Int_Matrix --
--------------------
@@ -1929,7 +726,7 @@ package body GNAT.Perfect_Hash_Generators is
procedure Put_Int_Matrix
(File : File_Descriptor;
Title : String;
- Table : Integer;
+ Table : Table_Name;
Len_1 : Natural;
Len_2 : Natural)
is
@@ -1945,665 +742,18 @@ package body GNAT.Perfect_Hash_Generators is
if Len_2 = 0 then
for J in F1 .. L1 loop
- Ix := IT.Table (Table + J);
+ Ix := Value (Table, J, 0);
Put (File, Image (Ix), 1, 0, 1, F1, L1, J);
end loop;
else
for J in F1 .. L1 loop
for K in F2 .. L2 loop
- Ix := IT.Table (Table + J + K * Len_1);
+ Ix := Value (Table, J, K);
Put (File, Image (Ix), F1, L1, J, F2, L2, K);
end loop;
end loop;
end if;
end Put_Int_Matrix;
- --------------------
- -- Put_Int_Vector --
- --------------------
-
- procedure Put_Int_Vector
- (File : File_Descriptor;
- Title : String;
- Vector : Integer;
- Length : Natural)
- is
- F2 : constant Natural := 0;
- L2 : constant Natural := Length - 1;
-
- begin
- Put (File, Title);
- New_Line (File);
-
- for J in F2 .. L2 loop
- Put (File, Image (IT.Table (Vector + J)), 1, 0, 1, F2, L2, J);
- end loop;
- end Put_Int_Vector;
-
- ----------------------
- -- Put_Reduced_Keys --
- ----------------------
-
- procedure Put_Reduced_Keys (File : File_Descriptor; Title : String) is
- F1 : constant Natural := 0;
- L1 : constant Natural := NK - 1;
- M : constant Natural := Max / 5;
- K : Key_Type;
-
- begin
- Put (File, Title);
- New_Line (File);
-
- for J in F1 .. L1 loop
- K := Get_Key (J);
- Put (File, Image (J, M), F1, L1, J, 1, 3, 1);
- Put (File, Image (K.Edge, M), F1, L1, J, 1, 3, 2);
- Put (File, Trim_Trailing_Nuls (WT.Table (Reduced (J)).all),
- F1, L1, J, 1, 3, 3);
- end loop;
- end Put_Reduced_Keys;
-
- -----------------------
- -- Put_Used_Char_Set --
- -----------------------
-
- procedure Put_Used_Char_Set (File : File_Descriptor; Title : String) is
- F : constant Natural := Character'Pos (Character'First);
- L : constant Natural := Character'Pos (Character'Last);
-
- begin
- Put (File, Title);
- New_Line (File);
-
- for J in Character'Range loop
- Put
- (File, Image (Get_Used_Char (J)), 1, 0, 1, F, L, Character'Pos (J));
- end loop;
- end Put_Used_Char_Set;
-
- ----------------------
- -- Put_Vertex_Table --
- ----------------------
-
- procedure Put_Vertex_Table (File : File_Descriptor; Title : String) is
- F1 : constant Natural := 0;
- L1 : constant Natural := NV - 1;
- M : constant Natural := Max / 4;
- V : Vertex_Type;
-
- begin
- Put (File, Title);
- New_Line (File);
-
- for J in F1 .. L1 loop
- V := Get_Vertices (J);
- Put (File, Image (J, M), F1, L1, J, 1, 3, 1);
- Put (File, Image (V.First, M), F1, L1, J, 1, 3, 2);
- Put (File, Image (V.Last, M), F1, L1, J, 1, 3, 3);
- end loop;
- end Put_Vertex_Table;
-
- ------------
- -- Random --
- ------------
-
- procedure Random (Seed : in out Natural) is
-
- -- Park & Miller Standard Minimal using Schrage's algorithm to avoid
- -- overflow: Xn+1 = 16807 * Xn mod (2 ** 31 - 1)
-
- R : Natural;
- Q : Natural;
- X : Integer;
-
- begin
- R := Seed mod 127773;
- Q := Seed / 127773;
- X := 16807 * R - 2836 * Q;
-
- Seed := (if X < 0 then X + 2147483647 else X);
- end Random;
-
- -------------
- -- Reduced --
- -------------
-
- function Reduced (K : Key_Id) return Word_Id is
- begin
- return K + NK + 1;
- end Reduced;
-
- -----------------
- -- Resize_Word --
- -----------------
-
- procedure Resize_Word (W : in out Word_Type; Len : Natural) is
- S1 : constant String := W.all;
- S2 : String (1 .. Len) := (others => ASCII.NUL);
- L : constant Natural := S1'Length;
- begin
- if L /= Len then
- Free_Word (W);
- S2 (1 .. L) := S1;
- W := New_Word (S2);
- end if;
- end Resize_Word;
-
- --------------------------
- -- Select_Char_Position --
- --------------------------
-
- procedure Select_Char_Position is
-
- type Vertex_Table_Type is array (Natural range <>) of Vertex_Type;
-
- procedure Build_Identical_Keys_Sets
- (Table : in out Vertex_Table_Type;
- Last : in out Natural;
- Pos : Natural);
- -- Build a list of keys subsets that are identical with the current
- -- position selection plus Pos. Once this routine is called, reduced
- -- words are sorted by subsets and each item (First, Last) in Sets
- -- defines the range of identical keys.
- -- Need comment saying exactly what Last is ???
-
- function Count_Different_Keys
- (Table : Vertex_Table_Type;
- Last : Natural;
- Pos : Natural) return Natural;
- -- For each subset in Sets, count the number of different keys if we add
- -- Pos to the current position selection.
-
- Sel_Position : IT.Table_Type (1 .. Max_Key_Len);
- Last_Sel_Pos : Natural := 0;
- Max_Sel_Pos : Natural := 0;
-
- -------------------------------
- -- Build_Identical_Keys_Sets --
- -------------------------------
-
- procedure Build_Identical_Keys_Sets
- (Table : in out Vertex_Table_Type;
- Last : in out Natural;
- Pos : Natural)
- is
- S : constant Vertex_Table_Type := Table (Table'First .. Last);
- C : constant Natural := Pos;
- -- Shortcuts (why are these not renames ???)
-
- F : Integer;
- L : Integer;
- -- First and last words of a subset
-
- Offset : Natural;
- -- GNAT.Heap_Sort assumes that the first array index is 1. Offset
- -- defines the translation to operate.
-
- function Lt (L, R : Natural) return Boolean;
- procedure Move (From : Natural; To : Natural);
- -- Subprograms needed by GNAT.Heap_Sort_G
-
- --------
- -- Lt --
- --------
-
- function Lt (L, R : Natural) return Boolean is
- C : constant Natural := Pos;
- Left : Natural;
- Right : Natural;
-
- begin
- if L = 0 then
- Left := NK;
- Right := Offset + R;
- elsif R = 0 then
- Left := Offset + L;
- Right := NK;
- else
- Left := Offset + L;
- Right := Offset + R;
- end if;
-
- return WT.Table (Left)(C) < WT.Table (Right)(C);
- end Lt;
-
- ----------
- -- Move --
- ----------
-
- procedure Move (From : Natural; To : Natural) is
- Target, Source : Natural;
-
- begin
- if From = 0 then
- Source := NK;
- Target := Offset + To;
- elsif To = 0 then
- Source := Offset + From;
- Target := NK;
- else
- Source := Offset + From;
- Target := Offset + To;
- end if;
-
- WT.Table (Target) := WT.Table (Source);
- WT.Table (Source) := null;
- end Move;
-
- package Sorting is new GNAT.Heap_Sort_G (Move, Lt);
-
- -- Start of processing for Build_Identical_Key_Sets
-
- begin
- Last := 0;
-
- -- For each subset in S, extract the new subsets we have by adding C
- -- 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;
- Last := Last + 1;
- Table (Last) := (F, L);
-
- else
- Offset := Reduced (S (J).First) - 1;
- Sorting.Sort (S (J).Last - S (J).First + 1);
-
- F := S (J).First;
- L := F;
- for N in S (J).First .. S (J).Last loop
-
- -- For the last item, close the last subset
-
- if N = S (J).Last then
- Last := Last + 1;
- Table (Last) := (F, N);
-
- -- Two contiguous words are identical when they have the
- -- same Cth character.
-
- elsif WT.Table (Reduced (N))(C) =
- WT.Table (Reduced (N + 1))(C)
- then
- L := N + 1;
-
- -- Find a new subset of identical keys. Store the current
- -- one and create a new subset.
-
- else
- Last := Last + 1;
- Table (Last) := (F, L);
- F := N + 1;
- L := F;
- end if;
- end loop;
- end if;
- end loop;
- end Build_Identical_Keys_Sets;
-
- --------------------------
- -- Count_Different_Keys --
- --------------------------
-
- function Count_Different_Keys
- (Table : Vertex_Table_Type;
- Last : Natural;
- Pos : Natural) return Natural
- is
- N : array (Character) of Natural;
- C : Character;
- T : Natural := 0;
-
- begin
- -- For each subset, count the number of words that are still
- -- different when we include Pos in the position selection. Only
- -- focus on this position as the other positions already produce
- -- identical keys.
-
- for S in 1 .. Last loop
-
- -- Count the occurrences of the different characters
-
- N := (others => 0);
- for K in Table (S).First .. Table (S).Last loop
- C := WT.Table (Reduced (K))(Pos);
- N (C) := N (C) + 1;
- end loop;
-
- -- Update the number of different keys. Each character used
- -- denotes a different key.
-
- for J in N'Range loop
- if N (J) > 0 then
- T := T + 1;
- end if;
- end loop;
- end loop;
-
- return T;
- end Count_Different_Keys;
-
- -- Start of processing for Select_Char_Position
-
- begin
- -- Initialize the reduced words set
-
- for K in 0 .. NK - 1 loop
- WT.Table (Reduced (K)) := New_Word (WT.Table (Initial (K)).all);
- end loop;
-
- declare
- Differences : Natural;
- Max_Differences : Natural := 0;
- Old_Differences : Natural;
- Max_Diff_Sel_Pos : Natural := 0; -- init to kill warning
- Max_Diff_Sel_Pos_Idx : Natural := 0; -- init to kill warning
- Same_Keys_Sets_Table : Vertex_Table_Type (1 .. NK);
- Same_Keys_Sets_Last : Natural := 1;
-
- begin
- for C in Sel_Position'Range loop
- Sel_Position (C) := C;
- end loop;
-
- Same_Keys_Sets_Table (1) := (0, NK - 1);
-
- loop
- -- Preserve maximum number of different keys and check later on
- -- that this value is strictly incrementing. Otherwise, it means
- -- that two keys are strictly identical.
-
- Old_Differences := Max_Differences;
-
- -- The first position should not exceed the minimum key length.
- -- Otherwise, we may end up with an empty word once reduced.
-
- Max_Sel_Pos :=
- (if Last_Sel_Pos = 0 then Min_Key_Len else Max_Key_Len);
-
- -- Find which position increases more the number of differences
-
- for J in Last_Sel_Pos + 1 .. Max_Sel_Pos loop
- Differences := Count_Different_Keys
- (Same_Keys_Sets_Table,
- Same_Keys_Sets_Last,
- Sel_Position (J));
-
- if Verbose then
- Put (Output,
- "Selecting position" & Sel_Position (J)'Img &
- " results in" & Differences'Img &
- " differences");
- New_Line (Output);
- end if;
-
- if Differences > Max_Differences then
- Max_Differences := Differences;
- Max_Diff_Sel_Pos := Sel_Position (J);
- Max_Diff_Sel_Pos_Idx := J;
- end if;
- end loop;
-
- if Old_Differences = Max_Differences then
- raise Program_Error with "some keys are identical";
- end if;
-
- -- Insert selected position and sort Sel_Position table
-
- Last_Sel_Pos := Last_Sel_Pos + 1;
- Sel_Position (Last_Sel_Pos + 1 .. Max_Diff_Sel_Pos_Idx) :=
- Sel_Position (Last_Sel_Pos .. Max_Diff_Sel_Pos_Idx - 1);
- Sel_Position (Last_Sel_Pos) := Max_Diff_Sel_Pos;
-
- 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;
- exit;
- end if;
- end loop;
-
- exit when Max_Differences = NK;
-
- Build_Identical_Keys_Sets
- (Same_Keys_Sets_Table,
- Same_Keys_Sets_Last,
- Max_Diff_Sel_Pos);
-
- if Verbose then
- Put (Output,
- "Selecting position" & Max_Diff_Sel_Pos'Img &
- " results in" & Max_Differences'Img &
- " differences");
- New_Line (Output);
- Put (Output, "--");
- New_Line (Output);
- for J in 1 .. Same_Keys_Sets_Last loop
- for K in
- Same_Keys_Sets_Table (J).First ..
- Same_Keys_Sets_Table (J).Last
- loop
- Put (Output,
- Trim_Trailing_Nuls (WT.Table (Reduced (K)).all));
- New_Line (Output);
- end loop;
- Put (Output, "--");
- New_Line (Output);
- end loop;
- end if;
- end loop;
- end;
-
- Char_Pos_Set_Len := Last_Sel_Pos;
- Char_Pos_Set := Allocate (Char_Pos_Set_Len);
-
- for C in 1 .. Last_Sel_Pos loop
- Set_Char_Pos (C - 1, Sel_Position (C));
- end loop;
- end Select_Char_Position;
-
- --------------------------
- -- Select_Character_Set --
- --------------------------
-
- procedure Select_Character_Set is
- Last : Natural := 0;
- Used : array (Character) of Boolean := (others => False);
- Char : Character;
-
- begin
- for J in 0 .. NK - 1 loop
- for K in 0 .. Char_Pos_Set_Len - 1 loop
- Char := WT.Table (Initial (J))(Get_Char_Pos (K));
- exit when Char = ASCII.NUL;
- Used (Char) := True;
- end loop;
- end loop;
-
- Used_Char_Set_Len := 256;
- Used_Char_Set := Allocate (Used_Char_Set_Len);
-
- for J in Used'Range loop
- if Used (J) then
- Set_Used_Char (J, Last);
- Last := Last + 1;
- else
- Set_Used_Char (J, 0);
- end if;
- end loop;
- end Select_Character_Set;
-
- ------------------
- -- Set_Char_Pos --
- ------------------
-
- procedure Set_Char_Pos (P : Natural; Item : Natural) is
- N : constant Natural := Char_Pos_Set + P;
- begin
- IT.Table (N) := Item;
- end Set_Char_Pos;
-
- ---------------
- -- Set_Edges --
- ---------------
-
- procedure Set_Edges (F : Natural; Item : Edge_Type) is
- N : constant Natural := Edges + (F * Edge_Size);
- begin
- IT.Table (N) := Item.X;
- IT.Table (N + 1) := Item.Y;
- IT.Table (N + 2) := Item.Key;
- end Set_Edges;
-
- ---------------
- -- Set_Graph --
- ---------------
-
- procedure Set_Graph (N : Natural; Item : Integer) is
- begin
- IT.Table (G + N) := Item;
- end Set_Graph;
-
- -------------
- -- Set_Key --
- -------------
-
- procedure Set_Key (N : Key_Id; Item : Key_Type) is
- begin
- IT.Table (Keys + N) := Item.Edge;
- end Set_Key;
-
- ---------------
- -- Set_Table --
- ---------------
-
- procedure Set_Table (T : Integer; X, Y : Natural; Item : Natural) is
- N : constant Natural := T + ((Y * T1_Len) + X);
- begin
- IT.Table (N) := Item;
- end Set_Table;
-
- -------------------
- -- Set_Used_Char --
- -------------------
-
- procedure Set_Used_Char (C : Character; Item : Natural) is
- N : constant Natural := Used_Char_Set + Character'Pos (C);
- begin
- IT.Table (N) := Item;
- end Set_Used_Char;
-
- ------------------
- -- Set_Vertices --
- ------------------
-
- procedure Set_Vertices (F : Natural; Item : Vertex_Type) is
- N : constant Natural := Vertices + (F * Vertex_Size);
- begin
- IT.Table (N) := Item.First;
- IT.Table (N + 1) := Item.Last;
- end Set_Vertices;
-
- ---------
- -- Sum --
- ---------
-
- function Sum
- (Word : Word_Type;
- Table : Table_Id;
- Opt : Optimization) return Natural
- is
- S : Natural := 0;
- R : Natural;
-
- begin
- case Opt is
- when CPU_Time =>
- 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;
-
- when Memory_Space =>
- 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;
-
- return S;
- end Sum;
-
- ------------------------
- -- Trim_Trailing_Nuls --
- ------------------------
-
- function Trim_Trailing_Nuls (Str : String) return String is
- begin
- for J in reverse Str'Range loop
- if Str (J) /= ASCII.NUL then
- return Str (Str'First .. J);
- end if;
- end loop;
-
- return Str;
- end Trim_Trailing_Nuls;
-
- ---------------
- -- Type_Size --
- ---------------
-
- function Type_Size (L : Natural) return Natural is
- begin
- if L <= 2 ** 8 then
- return 8;
- elsif L <= 2 ** 16 then
- return 16;
- else
- return 32;
- end if;
- end Type_Size;
-
- -----------
- -- Value --
- -----------
-
- function Value
- (Name : Table_Name;
- J : Natural;
- K : Natural := 0) return Natural
- is
- begin
- case Name is
- when Character_Position =>
- return Get_Char_Pos (J);
-
- when Used_Character_Set =>
- return Get_Used_Char (Character'Val (J));
-
- when Function_Table_1 =>
- return Get_Table (T1, J, K);
-
- when Function_Table_2 =>
- return Get_Table (T2, J, K);
-
- when Graph_Table =>
- return Get_Graph (J);
- end case;
- end Value;
-
end GNAT.Perfect_Hash_Generators;
diff --git a/gcc/ada/libgnat/g-pehage.ads b/gcc/ada/libgnat/g-pehage.ads
index 814f1cc..41913cb 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-2020, AdaCore --
+-- Copyright (C) 2002-2021, 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- --
@@ -64,8 +64,12 @@
-- < h (w2). These hashing functions are convenient for use with realtime
-- applications.
+with System.Perfect_Hash_Generators;
+
package GNAT.Perfect_Hash_Generators is
+ package SPHG renames System.Perfect_Hash_Generators;
+
Default_K_To_V : constant Float := 2.05;
-- Default ratio for the algorithm. When K is the number of keys, V =
-- (K_To_V) * K is the size of the main table of the hash function. To
@@ -83,12 +87,12 @@ package GNAT.Perfect_Hash_Generators is
-- try and may have to iterate a number of times. This constant bounds the
-- number of tries.
- type Optimization is (Memory_Space, CPU_Time);
+ type Optimization is new SPHG.Optimization;
-- Optimize either the memory space or the execution time. Note: in
-- practice, the optimization mode has little effect on speed. The tables
-- are somewhat smaller with Memory_Space.
- Verbose : Boolean := False;
+ Verbose : Boolean renames SPHG.Verbose;
-- Output the status of the algorithm. For instance, the tables, the random
-- graph (edges, vertices) and selected char positions are output between
-- two iterations.
@@ -106,10 +110,10 @@ package GNAT.Perfect_Hash_Generators is
-- the same words.
--
-- A classical way of doing is to Insert all the words and then to invoke
- -- Initialize and Compute. If Compute fails to find a perfect hash
- -- function, invoke Initialize another time with other configuration
- -- parameters (probably with a greater K_To_V ratio). Once successful,
- -- invoke Produce and Finalize.
+ -- Initialize and Compute. If this fails to find a perfect hash function,
+ -- invoke Initialize again with other configuration parameters (probably
+ -- with a greater K_To_V ratio). Once successful, invoke Produce and then
+ -- Finalize.
procedure Finalize;
-- Deallocate the internal structures and the words table
@@ -117,7 +121,7 @@ package GNAT.Perfect_Hash_Generators is
procedure Insert (Value : String);
-- Insert a new word into the table. ASCII.NUL characters are not allowed.
- Too_Many_Tries : exception;
+ Too_Many_Tries : exception renames SPHG.Too_Many_Tries;
-- Raised after Tries unsuccessful runs
procedure Compute (Position : String := Default_Position);
@@ -138,101 +142,4 @@ package GNAT.Perfect_Hash_Generators is
-- GNAT file name for a package named Pkg_Name. If Use_Stdout is True, the
-- output goes to standard output, and no files are written.
- ----------------------------------------------------------------
-
- -- The routines and structures defined below allow producing the hash
- -- function using a different way from the procedure above. The procedure
- -- Define returns the lengths of an internal table and its item type size.
- -- The function Value returns the value of each item in the table.
-
- -- The hash function has the following form:
-
- -- h (w) = (g (f1 (w)) + g (f2 (w))) mod m
-
- -- G is a function based on a graph table [0,n-1] -> [0,m-1]. m is the
- -- number of keys. n is an internally computed value and it can be obtained
- -- as the length of vector G.
-
- -- F1 and F2 are two functions based on two function tables T1 and T2.
- -- Their definition depends on the chosen optimization mode.
-
- -- Only some character positions are used in the words because they are
- -- significant. They are listed in a character position table (P in the
- -- pseudo-code below). For instance, in {"jan", "feb", "mar", "apr", "jun",
- -- "jul", "aug", "sep", "oct", "nov", "dec"}, only positions 2 and 3 are
- -- significant (the first character can be ignored). In this example, P =
- -- {2, 3}
-
- -- When Optimization is CPU_Time, the first dimension of T1 and T2
- -- corresponds to the character position in the word and the second to the
- -- character set. As all the character set is not used, we define a used
- -- character table which associates a distinct index to each used character
- -- (unused characters are mapped to zero). In this case, the second
- -- dimension of T1 and T2 is reduced to the used character set (C in the
- -- pseudo-code below). Therefore, the hash function has the following:
-
- -- function Hash (S : String) return Natural is
- -- F : constant Natural := S'First - 1;
- -- L : constant Natural := S'Length;
- -- F1, F2 : Natural := 0;
- -- J : <t>;
-
- -- begin
- -- for K in P'Range loop
- -- exit when L < P (K);
- -- J := C (S (P (K) + F));
- -- F1 := (F1 + Natural (T1 (K, J))) mod <n>;
- -- F2 := (F2 + Natural (T2 (K, J))) mod <n>;
- -- end loop;
-
- -- return (Natural (G (F1)) + Natural (G (F2))) mod <m>;
- -- end Hash;
-
- -- When Optimization is Memory_Space, the first dimension of T1 and T2
- -- corresponds to the character position in the word and the second
- -- dimension is ignored. T1 and T2 are no longer matrices but vectors.
- -- Therefore, the used character table is not available. The hash function
- -- has the following form:
-
- -- function Hash (S : String) return Natural is
- -- F : constant Natural := S'First - 1;
- -- L : constant Natural := S'Length;
- -- F1, F2 : Natural := 0;
- -- J : <t>;
-
- -- begin
- -- for K in P'Range loop
- -- exit when L < P (K);
- -- J := Character'Pos (S (P (K) + F));
- -- F1 := (F1 + Natural (T1 (K) * J)) mod <n>;
- -- F2 := (F2 + Natural (T2 (K) * J)) mod <n>;
- -- end loop;
-
- -- return (Natural (G (F1)) + Natural (G (F2))) mod <m>;
- -- end Hash;
-
- type Table_Name is
- (Character_Position,
- Used_Character_Set,
- Function_Table_1,
- Function_Table_2,
- Graph_Table);
-
- procedure Define
- (Name : Table_Name;
- Item_Size : out Natural;
- Length_1 : out Natural;
- Length_2 : out Natural);
- -- Return the definition of the table Name. This includes the length of
- -- dimensions 1 and 2 and the size of an unsigned integer item. When
- -- Length_2 is zero, the table has only one dimension. All the ranges
- -- start from zero.
-
- function Value
- (Name : Table_Name;
- J : Natural;
- K : Natural := 0) return Natural;
- -- Return the value of the component (I, J) of the table Name. When the
- -- table has only one dimension, J is ignored.
-
end GNAT.Perfect_Hash_Generators;
diff --git a/gcc/ada/libgnat/g-rannum.adb b/gcc/ada/libgnat/g-rannum.adb
index 9c6693b..2983201 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2007-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 f795ae0..462e3a2 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2007-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 3d8b8c7..3652af1 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-2020, AdaCore --
+-- Copyright (C) 1999-2021, 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 3a21edb..c94a3fe 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-2020, AdaCore --
+-- Copyright (C) 1998-2021, 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 fa67f0c..6bd636f 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2001-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 606fa91..0a8c9d0 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2001-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 b06214b..95ecb60 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-2020, AdaCore --
+-- Copyright (C) 1999-2021, 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 c45e722..f80c72d 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-2020, AdaCore --
+-- Copyright (C) 1996-2021, 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 897cac4..3b4a0d0 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2014-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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,7 @@ package body GNAT.Rewrite_Data is
subtype SEO is Stream_Element_Offset;
procedure Do_Output
- (B : in out Buffer;
+ (B : Buffer;
Data : Stream_Element_Array;
Output : not null access procedure (Data : Stream_Element_Array));
-- Do the actual output. This ensures that we properly send the data
@@ -81,7 +81,7 @@ package body GNAT.Rewrite_Data is
---------------
procedure Do_Output
- (B : in out Buffer;
+ (B : Buffer;
Data : Stream_Element_Array;
Output : not null access procedure (Data : Stream_Element_Array))
is
diff --git a/gcc/ada/libgnat/g-rewdat.ads b/gcc/ada/libgnat/g-rewdat.ads
index 108035f..8149565 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2014-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 bd97571..178b59b 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2009-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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,7 +38,7 @@ package body GNAT.Secure_Hashes is
"0123456789abcdef";
type Fill_Buffer_Access is
- access procedure
+ not null access procedure
(M : in out Message_State;
SEA : Stream_Element_Array;
First : Stream_Element_Offset;
diff --git a/gcc/ada/libgnat/g-sechas.ads b/gcc/ada/libgnat/g-sechas.ads
index 566a696..79f86bc 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2009-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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.adb b/gcc/ada/libgnat/g-sehamd.adb
index d82cc36..b59740a 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2002-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 5f9bfe3..148ecb1 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2002-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 470c9b5..920ba59 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2002-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 ed8aefb..602032f 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2002-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 6f4d5e0..20628fb 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-2020, AdaCore --
+-- Copyright (C) 2007-2021, 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 5d4a809..4c9b0b7 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-2020, AdaCore --
+-- Copyright (C) 2007-2021, 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 f7212e8..dbcb171 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-2020, AdaCore --
+-- Copyright (C) 2007-2021, 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 a0da5ff..d278bfa 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-2020, AdaCore --
+-- Copyright (C) 2007-2021, 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 1e74ff8..8b69d90 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-2020, AdaCore --
+-- Copyright (C) 2004-2021, 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 9d34553..2a7efc5 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-2020, AdaCore --
+-- Copyright (C) 2018-2021, 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 18568fa..4bd4e92 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-2020, AdaCore --
+-- Copyright (C) 2018-2021, 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 66e717f..8f4dbfc 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2009-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 584c560..5b8bf91 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2009-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 fd8b753..ea2337d 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2009-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 58d8b16..90af358 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2009-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 32ea088..89e3fd8 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2009-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 6d7c0ee..4f50899 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2009-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 1631562..a332e12 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2009-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 3f46df3..f23075b 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2009-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 061c407..c756b9d 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2009-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 010e5c4..1d67007 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2009-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 89e27f0..f5ebf5d 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2009-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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.ads b/gcc/ada/libgnat/g-shshco.ads
index 8c389dd..7df8682 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2009-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 06cf683..b352a37 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2000-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 a4e9fd1..75a2b27 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-2020, AdaCore --
+-- Copyright (C) 2001-2021, 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- --
@@ -96,6 +96,9 @@ package body GNAT.Sockets is
Options : constant array (Specific_Option_Name) of C.int :=
(Keep_Alive => SOSC.SO_KEEPALIVE,
+ Keep_Alive_Count => SOSC.TCP_KEEPCNT,
+ Keep_Alive_Idle => SOSC.TCP_KEEPIDLE,
+ Keep_Alive_Interval => SOSC.TCP_KEEPINTVL,
Reuse_Address => SOSC.SO_REUSEADDR,
Broadcast => SOSC.SO_BROADCAST,
Send_Buffer => SOSC.SO_SNDBUF,
@@ -1442,6 +1445,9 @@ package body GNAT.Sockets is
| Error
| Generic_Option
| Keep_Alive
+ | Keep_Alive_Count
+ | Keep_Alive_Idle
+ | Keep_Alive_Interval
| Multicast_If_V4
| Multicast_If_V6
| Multicast_Loop_V4
@@ -1511,6 +1517,15 @@ package body GNAT.Sockets is
=>
Opt.Enabled := (V4 /= 0);
+ when Keep_Alive_Count =>
+ Opt.Count := Natural (V4);
+
+ when Keep_Alive_Idle =>
+ Opt.Idle_Seconds := Natural (V4);
+
+ when Keep_Alive_Interval =>
+ Opt.Interval_Seconds := Natural (V4);
+
when Busy_Polling =>
Opt.Microseconds := Natural (V4);
@@ -1555,14 +1570,18 @@ package body GNAT.Sockets is
| Send_Timeout
=>
if Is_Windows then
-
- -- Timeout is in milliseconds, actual value is 500 ms +
- -- returned value (unless it is 0).
-
if U4 = 0 then
Opt.Timeout := 0.0;
+
else
- Opt.Timeout := Duration (U4) / 1000 + 0.500;
+ if Minus_500ms_Windows_Timeout then
+ -- Timeout is in milliseconds, actual value is 500 ms +
+ -- returned value (unless it is 0).
+
+ U4 := U4 + 500;
+ end if;
+
+ Opt.Timeout := Duration (U4) / 1000;
end if;
else
@@ -2620,6 +2639,21 @@ package body GNAT.Sockets is
Len := V4'Size / 8;
Add := V4'Address;
+ when Keep_Alive_Count =>
+ V4 := C.int (Option.Count);
+ Len := V4'Size / 8;
+ Add := V4'Address;
+
+ when Keep_Alive_Idle =>
+ V4 := C.int (Option.Idle_Seconds);
+ Len := V4'Size / 8;
+ Add := V4'Address;
+
+ when Keep_Alive_Interval =>
+ V4 := C.int (Option.Interval_Seconds);
+ Len := V4'Size / 8;
+ Add := V4'Address;
+
when Busy_Polling =>
V4 := C.int (Option.Microseconds);
Len := V4'Size / 8;
@@ -2694,7 +2728,7 @@ package body GNAT.Sockets is
Len := U4'Size / 8;
Add := U4'Address;
- U4 := C.unsigned (Option.Timeout / 0.001);
+ U4 := C.unsigned (Option.Timeout * 1000);
if Option.Timeout > 0.0 and then U4 = 0 then
-- Avoid round to zero. Zero timeout mean unlimited
diff --git a/gcc/ada/libgnat/g-socket.ads b/gcc/ada/libgnat/g-socket.ads
index bf78777..4372f3e 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-2020, AdaCore --
+-- Copyright (C) 2001-2021, 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- --
@@ -845,11 +845,20 @@ package GNAT.Sockets is
-- IP_Protocol_For_TCP_Level --
-------------------------------
- No_Delay, -- TCP_NODELAY
+ No_Delay, -- TCP_NODELAY
-- Disable the Nagle algorithm. This means that output buffer content
-- is always sent as soon as possible, even if there is only a small
-- amount of data.
+ Keep_Alive_Count, -- TCP_KEEPCNT
+ -- Maximum number of keepalive probes
+
+ Keep_Alive_Idle, -- TCP_KEEPIDLE
+ -- Idle time before TCP starts sending keepalive probes
+
+ Keep_Alive_Interval, -- TCP_KEEPINTVL
+ -- Time between individual keepalive probes
+
------------------------------
-- IP_Protocol_For_IP_Level --
------------------------------
@@ -923,26 +932,35 @@ package GNAT.Sockets is
Enabled : Boolean;
case Name is
- when Linger =>
+ when Linger =>
Seconds : Natural;
- when others =>
+ when others =>
null;
end case;
- when Busy_Polling =>
+ when Keep_Alive_Count =>
+ Count : Natural;
+
+ when Keep_Alive_Idle =>
+ Idle_Seconds : Natural;
+
+ when Keep_Alive_Interval =>
+ Interval_Seconds : Natural;
+
+ when Busy_Polling =>
Microseconds : Natural;
- when Send_Buffer |
- Receive_Buffer =>
+ when Send_Buffer |
+ Receive_Buffer =>
Size : Natural;
- when Error =>
+ when Error =>
Error : Error_Type;
- when Add_Membership_V4 |
- Add_Membership_V6 |
- Drop_Membership_V4 |
- Drop_Membership_V6 =>
+ when Add_Membership_V4 |
+ Add_Membership_V6 |
+ Drop_Membership_V4 |
+ Drop_Membership_V6 =>
Multicast_Address : Inet_Addr_Type;
case Name is
when Add_Membership_V4 |
@@ -958,13 +976,13 @@ package GNAT.Sockets is
when Multicast_If_V6 =>
Outgoing_If_Index : Natural;
- when Multicast_TTL =>
+ when Multicast_TTL =>
Time_To_Live : Natural;
- when Multicast_Hops =>
+ when Multicast_Hops =>
Hop_Limit : Integer range -1 .. 255;
- when Send_Timeout |
+ when Send_Timeout |
Receive_Timeout =>
Timeout : Timeval_Duration;
diff --git a/gcc/ada/libgnat/g-socket__dummy.adb b/gcc/ada/libgnat/g-socket__dummy.adb
index a343eab..a15ff5f 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-2020, AdaCore --
+-- Copyright (C) 2001-2021, 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 2cd7460..617c14f 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-2020, AdaCore --
+-- Copyright (C) 2001-2021, 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-socpol.adb b/gcc/ada/libgnat/g-socpol.adb
index cd82bb8..3f153af 100644
--- a/gcc/ada/libgnat/g-socpol.adb
+++ b/gcc/ada/libgnat/g-socpol.adb
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2020, AdaCore --
+-- Copyright (C) 2020-2021, 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-socpol.ads b/gcc/ada/libgnat/g-socpol.ads
index c03c578..71ce1bb 100644
--- a/gcc/ada/libgnat/g-socpol.ads
+++ b/gcc/ada/libgnat/g-socpol.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2020, AdaCore --
+-- Copyright (C) 2020-2021, 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-socpol__dummy.adb b/gcc/ada/libgnat/g-socpol__dummy.adb
index 01c7cc5..bc78268 100644
--- a/gcc/ada/libgnat/g-socpol__dummy.adb
+++ b/gcc/ada/libgnat/g-socpol__dummy.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2020, AdaCore --
+-- Copyright (C) 2020-2021, 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-socpol__dummy.ads b/gcc/ada/libgnat/g-socpol__dummy.ads
index 507471e..2d7ae3c 100644
--- a/gcc/ada/libgnat/g-socpol__dummy.ads
+++ b/gcc/ada/libgnat/g-socpol__dummy.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2020, AdaCore --
+-- Copyright (C) 2020-2021, 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 5d86993..7f7568e 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-2020, AdaCore --
+-- Copyright (C) 2001-2021, 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.ads b/gcc/ada/libgnat/g-socthi.ads
index c6a07ba..f1b0e2e 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-2020, AdaCore --
+-- Copyright (C) 2001-2021, 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.adb b/gcc/ada/libgnat/g-socthi__dummy.adb
index 53acef5..c054207 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-2020, AdaCore --
+-- Copyright (C) 2001-2021, 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 3ddcdb4..687ad34 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-2020, AdaCore --
+-- Copyright (C) 2001-2021, 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 dd8a68c..aa9305d 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-2020, AdaCore --
+-- Copyright (C) 2001-2021, 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 ff6feaa..6fb921a 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-2020, AdaCore --
+-- Copyright (C) 2001-2021, 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 548b9d3..f2a7185 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-2020, AdaCore --
+-- Copyright (C) 2002-2021, 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.ads b/gcc/ada/libgnat/g-socthi__vxworks.ads
index 704ec0a..5f85fd1 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-2020, AdaCore --
+-- Copyright (C) 2002-2021, 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.ads b/gcc/ada/libgnat/g-soliop.ads
index 295d812..0c07900 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-2020, AdaCore --
+-- Copyright (C) 2001-2021, 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 227c2e4..4310ead 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-2020, AdaCore --
+-- Copyright (C) 2001-2021, 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 cbb3e36..422dbba 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-2020, AdaCore --
+-- Copyright (C) 2001-2021, 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 c45bd04..916bc43 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-2020, AdaCore --
+-- Copyright (C) 2001-2021, 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 388b87c..aaef320 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-2020, AdaCore --
+-- Copyright (C) 2001-2021, 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-sopowa.adb b/gcc/ada/libgnat/g-sopowa.adb
index fc6e6d9..dae6f7d 100644
--- a/gcc/ada/libgnat/g-sopowa.adb
+++ b/gcc/ada/libgnat/g-sopowa.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2020, AdaCore --
+-- Copyright (C) 2020-2021, 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-sopowa__mingw.adb b/gcc/ada/libgnat/g-sopowa__mingw.adb
index 3d66437..7fb9f53 100644
--- a/gcc/ada/libgnat/g-sopowa__mingw.adb
+++ b/gcc/ada/libgnat/g-sopowa__mingw.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2020, AdaCore --
+-- Copyright (C) 2020-2021, 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-sopowa__posix.adb b/gcc/ada/libgnat/g-sopowa__posix.adb
index 02ccb77..3bb24f5 100644
--- a/gcc/ada/libgnat/g-sopowa__posix.adb
+++ b/gcc/ada/libgnat/g-sopowa__posix.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2020, AdaCore --
+-- Copyright (C) 2020-2021, 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 1b8dd49..aa27101 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-2020, AdaCore --
+-- Copyright (C) 2008-2021, 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 e30af18..b48657b 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-2020, AdaCore --
+-- Copyright (C) 2008-2021, 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- --
@@ -34,6 +34,7 @@
with Ada.Unchecked_Conversion;
with Interfaces.C.Strings;
+with System.Parameters;
package GNAT.Sockets.Thin_Common is
@@ -44,9 +45,9 @@ package GNAT.Sockets.Thin_Common is
Failure : constant C.int := -1;
type time_t is
- range -2 ** (8 * SOSC.SIZEOF_tv_sec - 1)
- .. 2 ** (8 * SOSC.SIZEOF_tv_sec - 1) - 1;
- for time_t'Size use 8 * SOSC.SIZEOF_tv_sec;
+ range -2 ** (System.Parameters.time_t_bits - 1)
+ .. 2 ** (System.Parameters.time_t_bits - 1) - 1;
+ for time_t'Size use System.Parameters.time_t_bits;
pragma Convention (C, time_t);
type suseconds_t is
diff --git a/gcc/ada/libgnat/g-sothco__dummy.adb b/gcc/ada/libgnat/g-sothco__dummy.adb
index 8c90ab0..87b710e 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2008-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 d93916a..6aadd8a 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-2020, AdaCore --
+-- Copyright (C) 2008-2021, 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 ce55464..bf362c4 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2000-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 62f1666..f790171 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-2020, AdaCore --
+-- Copyright (C) 1998-2021, 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 a0ce625..88bf264 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-2020, AdaCore --
+-- Copyright (C) 1998-2021, 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 545ca42..cccb3d8 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-2020, AdaCore --
+-- Copyright (C) 1998-2021, 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 a906e43..43a434e 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-2020, AdaCore --
+-- Copyright (C) 1998-2021, 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 e9f4bf5..97cfdf9 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-2020, AdaCore --
+-- Copyright (C) 1998-2021, 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 d711b3b6..13d1e93 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-2020, AdaCore --
+-- Copyright (C) 1997-2021, 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 07ecd52..dee969b 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-2020, AdaCore --
+-- Copyright (C) 1998-2021, 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 29a0606..447daeb 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-2020, AdaCore --
+-- Copyright (C) 1997-2021, 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-spogwa.adb b/gcc/ada/libgnat/g-spogwa.adb
index 6e0af44..af7fcfc 100644
--- a/gcc/ada/libgnat/g-spogwa.adb
+++ b/gcc/ada/libgnat/g-spogwa.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2020, AdaCore --
+-- Copyright (C) 2020-2021, 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-spogwa.ads b/gcc/ada/libgnat/g-spogwa.ads
index bde6a69..ad9cecd 100644
--- a/gcc/ada/libgnat/g-spogwa.ads
+++ b/gcc/ada/libgnat/g-spogwa.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2020, AdaCore --
+-- Copyright (C) 2020-2021, 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-sptabo.ads b/gcc/ada/libgnat/g-sptabo.ads
index 4aa1a76..4f479f7 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-2020, AdaCore --
+-- Copyright (C) 1997-2021, 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 065a33d..be4ebc3 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-2020, AdaCore --
+-- Copyright (C) 1997-2021, 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 2771cf5..9923025 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-2020, AdaCore --
+-- Copyright (C) 1997-2021, 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 fc220bd..c56d071 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2009-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 d7b134d..c09f040 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2009-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 f6345d4..bf80f9b 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-2020, AdaCore --
+-- Copyright (C) 2001-2021, 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 679adf0..3782972 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-2020, AdaCore --
+-- Copyright (C) 2007-2021, 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 f6949b5..19330ab 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2015-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 7d820c6..f8cd5ee 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1995-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 8d35847..a8f2574 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1995-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 0995e2b..14c143e 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2002-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 ad78669..5d8f91e 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-2020, AdaCore --
+-- Copyright (C) 2007-2021, 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 6d018e2..20a97fa 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-2020, AdaCore --
+-- Copyright (C) 2001-2021, 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 8872a4c..8991e68 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-2020, AdaCore --
+-- Copyright (C) 1998-2021, 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 752f1dc..7d3ef58 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-2020, AdaCore --
+-- Copyright (C) 1998-2021, 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- --
@@ -41,6 +41,8 @@
-- GNAT.Table
-- Table (the compiler unit)
+pragma Compiler_Unit_Warning;
+
with GNAT.Dynamic_Tables;
generic
diff --git a/gcc/ada/libgnat/g-tasloc.adb b/gcc/ada/libgnat/g-tasloc.adb
index 64c4940..2461035 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-2020, AdaCore --
+-- Copyright (C) 1997-2021, 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 b8ccb83..8296994 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-2020, AdaCore --
+-- Copyright (C) 1998-2021, 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 6bc12ab..4eeed30 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2008-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 df87840..76c1a79 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2008-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 c826dd5..d832570 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-2020, AdaCore --
+-- Copyright (C) 1999-2021, 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 0bd1ddf..15db799 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-2020, AdaCore --
+-- Copyright (C) 1999-2021, 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 064724c..07509ee 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-2020, AdaCore --
+-- Copyright (C) 1999-2021, 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 03055d4..c861968 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-2020, AdaCore --
+-- Copyright (C) 1999-2021, 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 ff3bb46..f54cc46 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-2020, AdaCore --
+-- Copyright (C) 2002-2021, 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 502850b..90e3237 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-2020, AdaCore --
+-- Copyright (C) 2002-2021, 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 a225afb..1a27143 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-2020, AdaCore --
+-- Copyright (C) 1998-2021, 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 8960231..56356f1 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-2020, AdaCore --
+-- Copyright (C) 1998-2021, 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 82958f8..432d77d 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2005-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 2d6dc72..3cd2729 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2005-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 403d02a..3f776b2 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-2020, AdaCore --
+-- Copyright (C) 1998-2021, 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 cfff62e..de4697b 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-2020, AdaCore --
+-- Copyright (C) 1998-2021, 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 da64a6d..b6ba727 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2002-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 38684f3..ca7b84a 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-2020, AdaCore --
+-- Copyright (C) 1998-2021, 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 47f5772..43ae4ed 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-2020, AdaCore --
+-- Copyright (C) 1998-2021, 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 9a8b5f9..377d1dd 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2002-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 c3217a6..612a6c8 100644
--- a/gcc/ada/libgnat/gnat.ads
+++ b/gcc/ada/libgnat/gnat.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2020, AdaCore --
+-- Copyright (C) 1992-2021, 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 028e5cb..5be50ff 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 279c75a..428ea49 100644
--- a/gcc/ada/libgnat/i-c.ads
+++ b/gcc/ada/libgnat/i-c.ads
@@ -61,6 +61,11 @@ package Interfaces.C is
type size_t is mod 2 ** System.Parameters.ptr_bits;
+ -- Boolean type
+
+ type C_bool is new Boolean;
+ pragma Convention (C, C_bool);
+
-- Floating-Point
type C_float is new Float;
diff --git a/gcc/ada/libgnat/i-cexten.ads b/gcc/ada/libgnat/i-cexten.ads
index 2772860..70d2621 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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,7 @@ package Interfaces.C.Extensions is
-- C bool
- type bool is new Boolean;
- pragma Convention (C, bool);
+ subtype bool is Interfaces.C.C_bool;
-- 64-bit integer types
diff --git a/gcc/ada/libgnat/i-cexten__128.ads b/gcc/ada/libgnat/i-cexten__128.ads
index 0c049f3..c07c5ab 100644
--- a/gcc/ada/libgnat/i-cexten__128.ads
+++ b/gcc/ada/libgnat/i-cexten__128.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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,7 @@ package Interfaces.C.Extensions is
-- C bool
- type bool is new Boolean;
- pragma Convention (C, bool);
+ subtype bool is Interfaces.C.C_bool;
-- 64-bit integer types
diff --git a/gcc/ada/libgnat/i-cobol.adb b/gcc/ada/libgnat/i-cobol.adb
index d69ef9d..b4b62ee 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -692,7 +692,7 @@ package body Interfaces.COBOL is
-- For signed, accept all standard and non-standard signs
else
- return Item (Item'Last) in 16#A# .. 16#F#;
+ return Item (Item'Last) >= 16#A#;
end if;
end case;
end Valid_Packed;
diff --git a/gcc/ada/libgnat/i-cobol.ads b/gcc/ada/libgnat/i-cobol.ads
index 21eecf8..cf96e25 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1993-2021, 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 6e5a2d2..4c39274 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 a3caca8..08b89ba 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1993-2021, 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 4cd4bed..40113f2 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1996-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 4277042..48f2125 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1995-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 17f4585..eba95d4 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 fae8e97..2b27f9f 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1993-2021, 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 b529717..eba61c2 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 e6eb790..8b8acc9 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 389dc3a..d68767f 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 4ae2245..f1e449f 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2002-2021, 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 fc6c10f..e1743ad 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2002-2021, 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 4f25bbd..c5686bb 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-2020, AdaCore --
+-- Copyright (C) 1999-2021, 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 641f9fe..ed9bb42 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-2020, AdaCore --
+-- Copyright (C) 1999-2021, 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 9e7dfba..186cb84 100644
--- a/gcc/ada/libgnat/interfac.ads
+++ b/gcc/ada/libgnat/interfac.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2002-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2002-2021, 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/interfac__2020.ads b/gcc/ada/libgnat/interfac__2020.ads
index 2865fc2..a353604 100644
--- a/gcc/ada/libgnat/interfac__2020.ads
+++ b/gcc/ada/libgnat/interfac__2020.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2002-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2002-2021, 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/memtrack.adb b/gcc/ada/libgnat/memtrack.adb
index a5f508d..e622fec 100644
--- a/gcc/ada/libgnat/memtrack.adb
+++ b/gcc/ada/libgnat/memtrack.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2001-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2001-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 a231be2..af8d67f 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 281655d..4eae027 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 5c3fd4a..0e02178 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 881882a..d1c3cb5 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-aoinar.adb b/gcc/ada/libgnat/s-aoinar.adb
index b05134f..df12b16 100644
--- a/gcc/ada/libgnat/s-aoinar.adb
+++ b/gcc/ada/libgnat/s-aoinar.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2019-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2019-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-aoinar.ads b/gcc/ada/libgnat/s-aoinar.ads
index 558754f..8d80bb1 100644
--- a/gcc/ada/libgnat/s-aoinar.ads
+++ b/gcc/ada/libgnat/s-aoinar.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2019-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2019-2021, 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-aomoar.adb b/gcc/ada/libgnat/s-aomoar.adb
index 9f350c1..c955623 100644
--- a/gcc/ada/libgnat/s-aomoar.adb
+++ b/gcc/ada/libgnat/s-aomoar.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2019-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2019-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-aomoar.ads b/gcc/ada/libgnat/s-aomoar.ads
index 4062d1a..7e19d7f 100644
--- a/gcc/ada/libgnat/s-aomoar.ads
+++ b/gcc/ada/libgnat/s-aomoar.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2019-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2019-2021, 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-aotase.adb b/gcc/ada/libgnat/s-aotase.adb
index 84a1a6e..5317889 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2019-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 f979788..77f343e 100644
--- a/gcc/ada/libgnat/s-aotase.ads
+++ b/gcc/ada/libgnat/s-aotase.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2019-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2019-2021, 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-aridou.adb b/gcc/ada/libgnat/s-aridou.adb
index 05a8c9f..b47c319 100644
--- a/gcc/ada/libgnat/s-aridou.adb
+++ b/gcc/ada/libgnat/s-aridou.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-aridou.ads b/gcc/ada/libgnat/s-aridou.ads
index f9c03e5..0df27ca 100644
--- a/gcc/ada/libgnat/s-aridou.ads
+++ b/gcc/ada/libgnat/s-aridou.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-arit128.adb b/gcc/ada/libgnat/s-arit128.adb
index 82c8fc3..951e357 100644
--- a/gcc/ada/libgnat/s-arit128.adb
+++ b/gcc/ada/libgnat/s-arit128.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2020-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-arit128.ads b/gcc/ada/libgnat/s-arit128.ads
index 55154da..6213cfb 100644
--- a/gcc/ada/libgnat/s-arit128.ads
+++ b/gcc/ada/libgnat/s-arit128.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2020-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-arit32.adb b/gcc/ada/libgnat/s-arit32.adb
index 742f2e1..f9cd7fe 100644
--- a/gcc/ada/libgnat/s-arit32.adb
+++ b/gcc/ada/libgnat/s-arit32.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2020-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-arit32.ads b/gcc/ada/libgnat/s-arit32.ads
index 5656855..5dc197d 100644
--- a/gcc/ada/libgnat/s-arit32.ads
+++ b/gcc/ada/libgnat/s-arit32.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2020-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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.adb b/gcc/ada/libgnat/s-arit64.adb
index a4d60f2..2f24a70 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 90d5c25..c9141f5 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 55020b9..4adcc33 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 7dcd93a..aa82549 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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,11 @@
pragma Compiler_Unit_Warning;
+with Ada.Assertions;
+
package System.Assertions is
- Assert_Failure : exception;
+ Assert_Failure : exception renames Ada.Assertions.Assertion_Error;
-- Exception raised when assertion fails
procedure Raise_Assert_Failure (Msg : String);
diff --git a/gcc/ada/libgnat/s-atacco.adb b/gcc/ada/libgnat/s-atacco.adb
index 11857b9..c13291e 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 e9076cc..16d86fb 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, 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 5d7f98e..b7ce56d 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2011-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 b64f947..9488b6d 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2011-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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,6 @@ private
type Atomic_Counter is record
Value : aliased Atomic_Unsigned := 1;
- pragma Atomic (Value);
end record;
end System.Atomic_Counters;
diff --git a/gcc/ada/libgnat/s-atocou__builtin.adb b/gcc/ada/libgnat/s-atocou__builtin.adb
index 2f2a5f6..d87f9ad 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2011-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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,24 +51,19 @@ package body System.Atomic_Counters is
procedure Decrement (Item : aliased in out Atomic_Unsigned) is
begin
- if Sync_Sub_And_Fetch (Item'Unrestricted_Access, 1) = 0 then
+ if Sync_Sub_And_Fetch (Item'Unchecked_Access, 1) = 0 then
null;
end if;
end Decrement;
function Decrement (Item : aliased in out Atomic_Unsigned) return Boolean is
begin
- return Sync_Sub_And_Fetch (Item'Unrestricted_Access, 1) = 0;
+ return Sync_Sub_And_Fetch (Item'Unchecked_Access, 1) = 0;
end Decrement;
function Decrement (Item : in out Atomic_Counter) return Boolean is
begin
- -- Note: the use of Unrestricted_Access here is required because we
- -- are obtaining an access-to-volatile pointer to a non-volatile object.
- -- This is not allowed for [Unchecked_]Access, but is safe in this case
- -- because we know that no aliases are being created.
-
- return Sync_Sub_And_Fetch (Item.Value'Unrestricted_Access, 1) = 0;
+ return Sync_Sub_And_Fetch (Item.Value'Unchecked_Access, 1) = 0;
end Decrement;
---------------
@@ -77,17 +72,12 @@ package body System.Atomic_Counters is
procedure Increment (Item : aliased in out Atomic_Unsigned) is
begin
- Sync_Add_And_Fetch (Item'Unrestricted_Access, 1);
+ Sync_Add_And_Fetch (Item'Unchecked_Access, 1);
end Increment;
procedure Increment (Item : in out Atomic_Counter) is
begin
- -- Note: the use of Unrestricted_Access here is required because we are
- -- obtaining an access-to-volatile pointer to a non-volatile object.
- -- This is not allowed for [Unchecked_]Access, but is safe in this case
- -- because we know that no aliases are being created.
-
- Sync_Add_And_Fetch (Item.Value'Unrestricted_Access, 1);
+ Sync_Add_And_Fetch (Item.Value'Unchecked_Access, 1);
end Increment;
----------------
diff --git a/gcc/ada/libgnat/s-atocou__x86.adb b/gcc/ada/libgnat/s-atocou__x86.adb
index 217cdec..8704d9df3e 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2011-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 a0f0eb8..c831e8e 100644
--- a/gcc/ada/libgnat/s-atoope.ads
+++ b/gcc/ada/libgnat/s-atoope.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2019-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2019-2021, 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-atopex.adb b/gcc/ada/libgnat/s-atopex.adb
index 4fb2824..501254e 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2019-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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.ads b/gcc/ada/libgnat/s-atopex.ads
index 996883c..f7558aa 100644
--- a/gcc/ada/libgnat/s-atopex.ads
+++ b/gcc/ada/libgnat/s-atopex.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2019-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2019-2021, 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-atopri.adb b/gcc/ada/libgnat/s-atopri.adb
index fa40d20..ba284f0 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2012-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 603793f..2a5ffe5 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2012-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 19741ea..0cb712a 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 66a9c9e..7ef1246 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1996-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-bignum.adb b/gcc/ada/libgnat/s-bignum.adb
index 5e85c4a..41e7617 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2012-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-bignum.ads b/gcc/ada/libgnat/s-bignum.ads
index 728e5438..ad5fedb 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2012-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-bitfie.ads b/gcc/ada/libgnat/s-bitfie.ads
index 21b7294..f081d55 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2019-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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,9 @@ package System.Bitfields is
pragma Provide_Shift_Operators (Val_2);
type Val is mod 2**Val_Bits with Alignment => Val_Bytes;
- -- ??? It turns out that enabling checks on the instantiation of
- -- System.Bitfield_Utils.G makes a latent visibility bug appear on strict
- -- alignment platforms related to alignment checks. Work around it by
- -- suppressing these checks explicitly.
+ -- Enabling checks on the instantiation of System.Bitfield_Utils.G makes a
+ -- latent visibility bug appear on strict alignment platforms related to
+ -- alignment checks. Work around it by suppressing these checks explicitly.
pragma Suppress (Alignment_Check);
package Utils is new System.Bitfield_Utils.G (Val, Val_2);
@@ -63,4 +62,12 @@ package System.Bitfields is
Size : Utils.Bit_Size)
renames Utils.Copy_Bitfield;
+ function Fast_Copy_Bitfield
+ (Src : Val_2;
+ Src_Offset : Utils.Bit_Offset;
+ Dest : Val_2;
+ Dest_Offset : Utils.Bit_Offset;
+ Size : Utils.Small_Size)
+ return Val_2 renames Utils.Fast_Copy_Bitfield;
+
end System.Bitfields;
diff --git a/gcc/ada/libgnat/s-bitops.adb b/gcc/ada/libgnat/s-bitops.adb
index 19bf14f..45290d3 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1996-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 8caf77c..92fe0df 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 ef839a8..d571f54 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2019-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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,14 +31,6 @@
package body System.Bitfield_Utils is
- -- ???
- --
- -- This code does not yet work for overlapping bit fields. We need to copy
- -- backwards in some cases (i.e. from higher to lower bit addresses).
- -- Alternatively, we could avoid calling this if Forwards_OK is False.
- --
- -- ???
-
package body G is
Val_Bytes : constant Address := Address (Val'Size / Storage_Unit);
@@ -77,7 +69,7 @@ package body System.Bitfield_Utils is
function Get_Bitfield
(Src : Val_2; Src_Offset : Bit_Offset; Size : Small_Size)
- return Val;
+ return Val with Inline;
-- Returns the bit field in Src starting at Src_Offset, of the given
-- Size. If Size < Small_Size'Last, then high order bits are zero.
@@ -86,7 +78,7 @@ package body System.Bitfield_Utils is
Dest : Val_2;
Dest_Offset : Bit_Offset;
Size : Small_Size)
- return Val_2;
+ return Val_2 with Inline;
-- The bit field in Dest starting at Dest_Offset, of the given Size, is
-- set to Src_Value. Src_Value must have high order bits (Size and
-- above) zero. The result is returned as the function result.
@@ -402,11 +394,22 @@ package body System.Bitfield_Utils is
pragma Assert (Al_Src_Address mod Val'Alignment = 0);
pragma Assert (Al_Dest_Address mod Val'Alignment = 0);
begin
+ -- Optimized small case
+
if Size in Small_Size then
Copy_Small_Bitfield
(Al_Src_Address, Al_Src_Offset,
Al_Dest_Address, Al_Dest_Offset,
Size);
+
+ -- Do nothing for zero size. This is necessary to avoid doing invalid
+ -- reads, which are detected by valgrind.
+
+ elsif Size = 0 then
+ null;
+
+ -- Large case
+
else
Copy_Large_Bitfield
(Al_Src_Address, Al_Src_Offset,
@@ -415,6 +418,22 @@ package body System.Bitfield_Utils is
end if;
end Copy_Bitfield;
+ function Fast_Copy_Bitfield
+ (Src : Val_2;
+ Src_Offset : Bit_Offset;
+ Dest : Val_2;
+ Dest_Offset : Bit_Offset;
+ Size : Small_Size)
+ return Val_2 is
+ Result : constant Val_2 := Set_Bitfield
+ (Get_Bitfield (Src, Src_Offset, Size), Dest, Dest_Offset, Size);
+ begin
+ -- No need to explicitly do nothing for zero size case, because Size
+ -- cannot be zero.
+
+ return Result;
+ end Fast_Copy_Bitfield;
+
end G;
end System.Bitfield_Utils;
diff --git a/gcc/ada/libgnat/s-bituti.ads b/gcc/ada/libgnat/s-bituti.ads
index 305133b..8afee24 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2019-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -54,7 +54,7 @@ package System.Bitfield_Utils is
-- generic formal, or on a type derived from a generic formal, so they have
-- to be passed in.
--
- -- Endian indicates whether we're on little-endian or big-endian machine.
+ -- Endian indicates whether we're on a little- or big-endian machine.
pragma Elaborate_Body;
@@ -98,9 +98,9 @@ package System.Bitfield_Utils is
pragma Assert (Val_Array'Component_Size = Val'Size);
subtype Bit_Size is Natural; -- Size in bits of a bit field
- subtype Small_Size is Bit_Size range 0 .. Val'Size;
+ subtype Small_Size is Bit_Size range 1 .. Val'Size;
-- Size of a small one
- subtype Bit_Offset is Small_Size range 0 .. Val'Size - 1;
+ subtype Bit_Offset is Small_Size'Base range 0 .. Val'Size - 1;
-- Starting offset
subtype Bit_Offset_In_Byte is Bit_Offset range 0 .. Storage_Unit - 1;
@@ -127,6 +127,20 @@ package System.Bitfield_Utils is
-- D (D_First)'Address, D (D_First)'Bit,
-- Size);
+ function Fast_Copy_Bitfield
+ (Src : Val_2;
+ Src_Offset : Bit_Offset;
+ Dest : Val_2;
+ Dest_Offset : Bit_Offset;
+ Size : Small_Size)
+ return Val_2 with Inline;
+ -- Faster version of Copy_Bitfield, with a different calling convention.
+ -- In particular, we pass by copy rather than passing Addresses. The bit
+ -- field must fit in Val_Bits. Src and Dest must be properly aligned.
+ -- The result is supposed to be assigned back into Dest, as in:
+ --
+ -- Dest := Fast_Copy_Bitfield (Src, ..., Dest, ..., ...);
+
end G;
end System.Bitfield_Utils;
diff --git a/gcc/ada/libgnat/s-boarop.ads b/gcc/ada/libgnat/s-boarop.ads
index 3f3656d..1efac49 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2002-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 d153f10..0790846 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-2020, AdaCore --
+-- Copyright (C) 2016-2021, 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 e49c5aa..9f7526e 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-2020, AdaCore --
+-- Copyright (C) 2016-2021, 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 1eac50d..7cc1523 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-2020, AdaCore --
+-- Copyright (C) 2006-2021, 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 2da7f5a..a44924a 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2002-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 a515aad..a9ef1c06 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2002-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 0ed3d26..2c192db 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2002-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 f74c1e3..eeadf61 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2002-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-casi128.adb b/gcc/ada/libgnat/s-casi128.adb
index 96a8f3d..09d002f 100644
--- a/gcc/ada/libgnat/s-casi128.adb
+++ b/gcc/ada/libgnat/s-casi128.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2002-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2002-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-casi128.ads b/gcc/ada/libgnat/s-casi128.ads
index 0893bad..d3f1347 100644
--- a/gcc/ada/libgnat/s-casi128.ads
+++ b/gcc/ada/libgnat/s-casi128.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2002-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2002-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 17f8429..1889579 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2002-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 cdb9b51..21c7a0e 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2002-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 9d54fe3..0515a53 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2002-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 90ffaf0..c591cff 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2002-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 464f99e..5b4a1e3 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2002-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 7296dd8..4563124 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2002-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 a8982f2..265b7d3 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-2020, AdaCore --
+-- Copyright (C) 1995-2021, 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 4204b5e..5b96edb 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1995-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-caun128.adb b/gcc/ada/libgnat/s-caun128.adb
index bb69793..3cd4e85 100644
--- a/gcc/ada/libgnat/s-caun128.adb
+++ b/gcc/ada/libgnat/s-caun128.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2002-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2002-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-caun128.ads b/gcc/ada/libgnat/s-caun128.ads
index c96983d..30d11ab 100644
--- a/gcc/ada/libgnat/s-caun128.ads
+++ b/gcc/ada/libgnat/s-caun128.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2002-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2002-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 ef016b5..9168ef3 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2002-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 beb6322..6175daa 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2002-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 6979dfc..7d7e7a8 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2002-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 8f07450b..ab7b4f3 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2002-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 32e3749..8971a80 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2002-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 e732fc7..d061d7d 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2002-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 47ea922..3936715 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 0e924be..591b4a0 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-2020, AdaCore --
+-- Copyright (C) 2001-2021, 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 b338343..7c15d62 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-2020, AdaCore --
+-- Copyright (C) 2001-2021, 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 3b6639c..81d6f61 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2008-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 d120d47..dc588eb 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2008-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 1115434..37a8681 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2008-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 6935974..155bebf 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2008-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 b170b1f..da50627 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2008-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 64157df..1d8e15c 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2008-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 0b14a5c..0de4aa5 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2008-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 ec6c326..6193adb 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2008-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 43a15b9..d51201f 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2008-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 20a9075..ee38e69 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2008-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 9691ec0..787b4f2 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2008-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 2a382c2..74d05dc 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2008-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 44968ac..8e64e46 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2008-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 1bee3cf..d739b30 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2008-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 b5c4ade..83456e9 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2008-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 fc900c6..61d6d6b 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2008-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 49df8c2..9f34ed5 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2001-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 3591120..b595fc4 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2001-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 a3299ef..d26dbf3 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2003-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 cad07fe..f9df157 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2018-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 f9e24bb..daf5189 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2018-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 3141ddb..91b8f3e 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2011-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 222679ef..1343e95 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2011-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 67bce0f..3abe428 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2011-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 6ba1e01..02db92d 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2018-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 5013083..be97085 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2011-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 a067ccc..559504e 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2011-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 ddcd716..a79e723 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2011-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 df3d28f..37e101b 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2018-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 9780a85..0bcc0da 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2012-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 4293103..186319e 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2011-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 24eb0b9..91176649 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2011-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 0ebc2bc..8e3740c 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 aa93797..01ffbca 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 fccfd8b..d0b0bb2 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2018-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 ee743d5..6fe46a5 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2018-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 04d6ca4..458ae52 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2011-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-dorepr.adb b/gcc/ada/libgnat/s-dorepr.adb
new file mode 100644
index 0000000..9f6df92
--- /dev/null
+++ b/gcc/ada/libgnat/s-dorepr.adb
@@ -0,0 +1,172 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S Y S T E M . D O U B L E _ R E A L . P R O D U C T --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 2021, Free Software Foundation, Inc. --
+-- --
+-- GNAT is 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 the default version of the separate package body
+
+with Interfaces; use Interfaces;
+
+separate (System.Double_Real)
+
+package body Product is
+
+ procedure Split (N : Num; Hi : out Num; Lo : out Num);
+ -- Compute high part and low part of N
+
+ -----------
+ -- Split --
+ -----------
+
+ -- We use a bit manipulation algorithm instead of Veltkamp's splitting
+ -- because it is faster and has the property that the magnitude of the
+ -- high part is never larger than that of the input number, which will
+ -- avoid spurious overflows in the Two_Prod algorithm.
+
+ -- See the recent paper by Claude-Pierre Jeannerod, Jean-Michel Muller
+ -- and Paul Zimmermann: On various ways to split a floating-point number
+ -- ARITH 2018 - 25th IEEE Symposium on Computer Arithmetic, Jun 2018,
+ -- Amherst (MA), United States, pages 53-60.
+
+ procedure Split (N : Num; Hi : out Num; Lo : out Num) is
+ X : Num;
+
+ begin
+ -- Spill the input into the appropriate (maybe larger) bit container,
+ -- mask out the low bits and reload the modified value.
+
+ case Num'Machine_Mantissa is
+ when 24 =>
+ declare
+ Rep32 : aliased Interfaces.Unsigned_32;
+ Temp : Num := N with Address => Rep32'Address;
+ pragma Annotate (CodePeer, Modified, Rep32);
+
+ begin
+ -- Mask out the low 12 bits
+
+ Rep32 := Rep32 and 16#FFFFF000#;
+
+ X := Temp;
+ end;
+
+ when 53 =>
+ declare
+ Rep64 : aliased Interfaces.Unsigned_64;
+ Temp : Num := N with Address => Rep64'Address;
+ pragma Annotate (CodePeer, Modified, Rep64);
+
+ begin
+ -- Mask out the low 27 bits
+
+ Rep64 := Rep64 and 16#FFFFFFFFF8000000#;
+
+ X := Temp;
+ end;
+
+ when 64 =>
+ declare
+ Rep80 : aliased array (1 .. 2) of Interfaces.Unsigned_64;
+ Temp : Num := N with Address => Rep80'Address;
+ pragma Annotate (CodePeer, Modified, Rep80);
+
+ begin
+ -- Mask out the low 32 bits
+
+ if System.Default_Bit_Order = High_Order_First then
+ Rep80 (1) := Rep80 (1) and 16#FFFFFFFFFFFF0000#;
+ Rep80 (2) := Rep80 (2) and 16#0000FFFFFFFFFFFF#;
+ else
+ Rep80 (1) := Rep80 (1) and 16#FFFFFFFF00000000#;
+ end if;
+
+ X := Temp;
+ end;
+
+ when others =>
+ raise Program_Error;
+ end case;
+
+ -- Deal with denormalized numbers
+
+ if X = 0.0 then
+ Hi := N;
+ Lo := 0.0;
+ else
+ Hi := X;
+ Lo := N - X;
+ end if;
+ end Split;
+
+ --------------
+ -- Two_Prod --
+ --------------
+
+ function Two_Prod (A, B : Num) return Double_T is
+ P : constant Num := A * B;
+
+ Ahi, Alo, Bhi, Blo, E : Num;
+
+ begin
+ if Is_Infinity (P) or else Is_Zero (P) then
+ return (P, 0.0);
+
+ else
+ Split (A, Ahi, Alo);
+ Split (B, Bhi, Blo);
+
+ E := ((Ahi * Bhi - P) + Ahi * Blo + Alo * Bhi) + Alo * Blo;
+
+ return (P, E);
+ end if;
+ end Two_Prod;
+
+ -------------
+ -- Two_Sqr --
+ -------------
+
+ function Two_Sqr (A : Num) return Double_T is
+ Q : constant Num := A * A;
+
+ Hi, Lo, E : Num;
+
+ begin
+ if Is_Infinity (Q) or else Is_Zero (Q) then
+ return (Q, 0.0);
+
+ else
+ Split (A, Hi, Lo);
+
+ E := ((Hi * Hi - Q) + 2.0 * Hi * Lo) + Lo * Lo;
+
+ return (Q, E);
+ end if;
+ end Two_Sqr;
+
+end Product;
diff --git a/gcc/ada/libgnat/s-dorepr__fma.adb b/gcc/ada/libgnat/s-dorepr__fma.adb
new file mode 100644
index 0000000..56d4dbb
--- /dev/null
+++ b/gcc/ada/libgnat/s-dorepr__fma.adb
@@ -0,0 +1,97 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S Y S T E M . D O U B L E _ R E A L . P R O D U C T --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 2021, Free Software Foundation, Inc. --
+-- --
+-- GNAT is 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 the version of the separate package body for targets with an FMA
+
+separate (System.Double_Real)
+
+package body Product is
+
+ function Fused_Multiply_Add (A, B, C : Num) return Num;
+ -- Return the result of A * B + C without intermediate rounding
+
+ ------------------------
+ -- Fused_Multiply_Add --
+ ------------------------
+
+ function Fused_Multiply_Add (A, B, C : Num) return Num is
+ begin
+ case Num'Size is
+ when 32 =>
+ declare
+ function Do_FMA (A, B, C : Num) return Num;
+ pragma Import (Intrinsic, Do_FMA, "__builtin_fmaf");
+
+ begin
+ return Do_FMA (A, B, C);
+ end;
+
+ when 64 =>
+ declare
+ function Do_FMA (A, B, C : Num) return Num;
+ pragma Import (Intrinsic, Do_FMA, "__builtin_fma");
+
+ begin
+ return Do_FMA (A, B, C);
+ end;
+
+ when others =>
+ raise Program_Error;
+ end case;
+ end Fused_Multiply_Add;
+
+ --------------
+ -- Two_Prod --
+ --------------
+
+ function Two_Prod (A, B : Num) return Double_T is
+ P : constant Num := A * B;
+
+ E : Num;
+
+ begin
+ if Is_Infinity (P) or else Is_Zero (P) then
+ return (P, 0.0);
+
+ else
+ E := Fused_Multiply_Add (A, B, -P);
+
+ return (P, E);
+ end if;
+ end Two_Prod;
+
+ -------------
+ -- Two_Sqr --
+ -------------
+
+ function Two_Sqr (A : Num) return Double_T is (Two_Prod (A, A));
+
+end Product;
diff --git a/gcc/ada/libgnat/s-dourea.adb b/gcc/ada/libgnat/s-dourea.adb
new file mode 100644
index 0000000..53bed1d
--- /dev/null
+++ b/gcc/ada/libgnat/s-dourea.adb
@@ -0,0 +1,258 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S Y S T E M . D O U B L E _ R E A L --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 2021, Free Software Foundation, Inc. --
+-- --
+-- GNAT is 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 System.Double_Real is
+
+ function Is_NaN (N : Num) return Boolean is (N /= N);
+ -- Return True if N is a NaN
+
+ function Is_Infinity (N : Num) return Boolean is (Is_NaN (N - N));
+ -- Return True if N is an infinity. Used to avoid propagating meaningless
+ -- errors when the result of a product is an infinity.
+
+ function Is_Zero (N : Num) return Boolean is (N = -N);
+ -- Return True if N is a Zero. Used to preserve the sign when the result of
+ -- a product is a zero.
+
+ package Product is
+ function Two_Prod (A, B : Num) return Double_T;
+ function Two_Sqr (A : Num) return Double_T;
+ end Product;
+ -- The low-level implementation of multiplicative operations
+
+ package body Product is separate;
+ -- This is a separate body because the implementation depends on whether a
+ -- Fused Multiply-Add instruction is available on the target.
+
+ -------------------
+ -- Quick_Two_Sum --
+ -------------------
+
+ function Quick_Two_Sum (A, B : Num) return Double_T is
+ S : constant Num := A + B;
+ V : constant Num := S - A;
+ E : constant Num := B - V;
+
+ begin
+ return (S, E);
+ end Quick_Two_Sum;
+
+ -------------
+ -- Two_Sum --
+ -------------
+
+ function Two_Sum (A, B : Num) return Double_T is
+ S : constant Num := A + B;
+ V : constant Num := S - A;
+ E : constant Num := (A - (S - V)) + (B - V);
+
+ begin
+ return (S, E);
+ end Two_Sum;
+
+ --------------
+ -- Two_Diff --
+ --------------
+
+ function Two_Diff (A, B : Num) return Double_T is
+ S : constant Num := A - B;
+ V : constant Num := S - A;
+ E : constant Num := (A - (S - V)) - (B + V);
+
+ begin
+ return (S, E);
+ end Two_Diff;
+
+ --------------
+ -- Two_Prod --
+ --------------
+
+ function Two_Prod (A, B : Num) return Double_T renames Product.Two_Prod;
+
+ -------------
+ -- Two_Sqr --
+ -------------
+
+ function Two_Sqr (A : Num) return Double_T renames Product.Two_Sqr;
+
+ ---------
+ -- "+" --
+ ---------
+
+ function "+" (A : Double_T; B : Num) return Double_T is
+ S : constant Double_T := Two_Sum (A.Hi, B);
+
+ begin
+ return Quick_Two_Sum (S.Hi, S.Lo + A.Lo);
+ end "+";
+
+ function "+" (A, B : Double_T) return Double_T is
+ S1 : constant Double_T := Two_Sum (A.Hi, B.Hi);
+ S2 : constant Double_T := Two_Sum (A.Lo, B.Lo);
+ S3 : constant Double_T := Quick_Two_Sum (S1.Hi, S1.Lo + S2.Hi);
+
+ begin
+ return Quick_Two_Sum (S3.Hi, S3.Lo + S2.Lo);
+ end "+";
+
+ ---------
+ -- "-" --
+ ---------
+
+ function "-" (A : Double_T; B : Num) return Double_T is
+ D : constant Double_T := Two_Diff (A.Hi, B);
+
+ begin
+ return Quick_Two_Sum (D.Hi, D.Lo + A.Lo);
+ end "-";
+
+ function "-" (A, B : Double_T) return Double_T is
+ D1 : constant Double_T := Two_Diff (A.Hi, B.Hi);
+ D2 : constant Double_T := Two_Diff (A.Lo, B.Lo);
+ D3 : constant Double_T := Quick_Two_Sum (D1.Hi, D1.Lo + D2.Hi);
+
+ begin
+ return Quick_Two_Sum (D3.Hi, D3.Lo + D2.Lo);
+ end "-";
+
+ ---------
+ -- "*" --
+ ---------
+
+ function "*" (A : Double_T; B : Num) return Double_T is
+ P : constant Double_T := Two_Prod (A.Hi, B);
+
+ begin
+ if Is_Infinity (P.Hi) or else Is_Zero (P.Hi) then
+ return (P.Hi, 0.0);
+ else
+ return Quick_Two_Sum (P.Hi, P.Lo + A.Lo * B);
+ end if;
+ end "*";
+
+ function "*" (A, B : Double_T) return Double_T is
+ P : constant Double_T := Two_Prod (A.Hi, B.Hi);
+
+ begin
+ if Is_Infinity (P.Hi) or else Is_Zero (P.Hi) then
+ return (P.Hi, 0.0);
+ else
+ return Quick_Two_Sum (P.Hi, P.Lo + A.Hi * B.Lo + A.Lo * B.Hi);
+ end if;
+ end "*";
+
+ ---------
+ -- "/" --
+ ---------
+
+ function "/" (A : Double_T; B : Num) return Double_T is
+ Q1, Q2 : Num;
+ P, R : Double_T;
+
+ begin
+ Q1 := A.Hi / B;
+
+ -- Compute R = A - B * Q1
+
+ P := Two_Prod (B, Q1);
+ R := Two_Diff (A.Hi, P.Hi);
+ R.Lo := (R.Lo + A.Lo) - P.Lo;
+
+ Q2 := (R.Hi + R.Lo) / B;
+
+ return Quick_Two_Sum (Q1, Q2);
+ end "/";
+
+ function "/" (A, B : Double_T) return Double_T is
+ Q1, Q2, Q3 : Num;
+ R, S : Double_T;
+
+ begin
+ Q1 := A.Hi / B.Hi;
+ R := A - B * Q1;
+
+ Q2 := R.Hi / B.Hi;
+ R := R - B * Q2;
+
+ Q3 := R.Hi / B.Hi;
+
+ S := Quick_Two_Sum (Q1, Q2);
+ return Quick_Two_Sum (S.Hi, S.Lo + Q3);
+ end "/";
+
+ ---------
+ -- Sqr --
+ ---------
+
+ function Sqr (A : Double_T) return Double_T is
+ Q : constant Double_T := Two_Sqr (A.Hi);
+
+ begin
+ if Is_Infinity (Q.Hi) or else Is_Zero (Q.Hi) then
+ return (Q.Hi, 0.0);
+ else
+ return Quick_Two_Sum (Q.Hi, Q.Lo + 2.0 * A.Hi * A.Lo + A.Lo * A.Lo);
+ end if;
+ end Sqr;
+
+ -------------------
+ -- From_Unsigned --
+ -------------------
+
+ function From_Unsigned (U : Uns) return Double_T is
+ begin
+ return To_Double (Num (U));
+ end From_Unsigned;
+
+ -----------------
+ -- To_Unsigned --
+ -----------------
+
+ function To_Unsigned (D : Double_T) return Uns is
+ Hi : constant Num := Num'Truncation (D.Hi);
+
+ begin
+ -- If the high part is already an integer, add Floor of the low part,
+ -- which means subtract Ceiling of its opposite if it is negative.
+
+ if Hi = D.Hi then
+ if D.Lo < 0.0 then
+ return Uns (Hi) - Uns (Num'Ceiling (-D.Lo));
+ else
+ return Uns (Hi) + Uns (Num'Floor (D.Lo));
+ end if;
+
+ else
+ return Uns (Hi);
+ end if;
+ end To_Unsigned;
+
+end System.Double_Real;
diff --git a/gcc/ada/libgnat/s-dourea.ads b/gcc/ada/libgnat/s-dourea.ads
new file mode 100644
index 0000000..0c97f34
--- /dev/null
+++ b/gcc/ada/libgnat/s-dourea.ads
@@ -0,0 +1,123 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S Y S T E M . D O U B L E _ R E A L --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 2021, Free Software Foundation, Inc. --
+-- --
+-- GNAT is 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 routines for supporting floating-point computations
+-- in double precision, i.e. using a second number to estimate the error due
+-- to rounding and more generally performing computations with twice as many
+-- bits of mantissa. It is based on the Double-Double library available at
+-- https://www.davidhbailey.com/dhbsoftware written by David H.Bailey et al.
+
+generic
+
+ type Num is digits <>;
+
+package System.Double_Real is
+ pragma Pure;
+
+ type Double_T is record
+ Hi, Lo : Num;
+ end record;
+
+ function To_Double (N : Num) return Double_T is ((Hi => N, Lo => 0.0));
+ -- Convert a single to a double real
+
+ function To_Single (D : Double_T) return Num is (D.Hi);
+ -- Convert a double to a single real
+
+ function Quick_Two_Sum (A, B : Num) return Double_T
+ with Pre => A = 0.0 or else abs (A) >= abs (B);
+ -- Compute A + B and its rounding error exactly, but assume |A| >= |B|
+
+ function Two_Sum (A, B : Num) return Double_T;
+ -- Compute A + B and its rounding error exactly
+
+ function Two_Diff (A, B : Num) return Double_T;
+ -- Compute A - B and its rounding error exactly
+
+ function Two_Prod (A, B : Num) return Double_T;
+ -- Compute A * B and its rounding error exactly
+
+ function Two_Sqr (A : Num) return Double_T;
+ -- Compute A * A and its rounding error exactly
+
+ function "+" (A : Double_T; B : Num) return Double_T;
+ function "-" (A : Double_T; B : Num) return Double_T;
+ function "*" (A : Double_T; B : Num) return Double_T;
+ function "/" (A : Double_T; B : Num) return Double_T
+ with Pre => B /= 0.0;
+ -- Mixed precision arithmetic operations
+
+ function "+" (A, B : Double_T) return Double_T;
+ function "-" (A, B : Double_T) return Double_T;
+ function "*" (A, B : Double_T) return Double_T;
+ function "/" (A, B : Double_T) return Double_T
+ with Pre => B.Hi /= 0.0;
+ -- Double precision arithmetic operations
+
+ function Sqr (A : Double_T) return Double_T;
+ -- Faster version of A * A
+
+ function "=" (A : Double_T; B : Num) return Boolean is
+ (A.Hi = B and then A.Lo = 0.0);
+ function "<" (A : Double_T; B : Num) return Boolean is
+ (A.Hi < B or else (A.Hi = B and then A.Lo < 0.0));
+ function "<=" (A : Double_T; B : Num) return Boolean is
+ (A.Hi < B or else (A.Hi = B and then A.Lo <= 0.0));
+ function ">" (A : Double_T; B : Num) return Boolean is
+ (A.Hi > B or else (A.Hi = B and then A.Lo > 0.0));
+ function ">=" (A : Double_T; B : Num) return Boolean is
+ (A.Hi > B or else (A.Hi = B and then A.Lo >= 0.0));
+ -- Mixed precision comparisons
+
+ function "=" (A, B : Double_T) return Boolean is
+ (A.Hi = B.Hi and then A.Lo = B.Lo);
+ function "<" (A, B : Double_T) return Boolean is
+ (A.Hi < B.Hi or else (A.Hi = B.Hi and then A.Lo < B.Lo));
+ function "<=" (A, B : Double_T) return Boolean is
+ (A.Hi < B.Hi or else (A.Hi = B.Hi and then A.Lo <= B.Lo));
+ function ">" (A, B : Double_T) return Boolean is
+ (A.Hi > B.Hi or else (A.Hi = B.Hi and then A.Lo > B.Lo));
+ function ">=" (A, B : Double_T) return Boolean is
+ (A.Hi > B.Hi or else (A.Hi = B.Hi and then A.Lo >= B.Lo));
+ -- Double precision comparisons
+
+ generic
+ type Uns is mod <>;
+ function From_Unsigned (U : Uns) return Double_T;
+ -- Convert Uns to Double_T
+
+ generic
+ type Uns is mod <>;
+ function To_Unsigned (D : Double_T) return Uns
+ with Pre => D >= 0.0;
+ -- Convert Double_T to Uns with truncation
+
+end System.Double_Real;
diff --git a/gcc/ada/libgnat/s-dsaser.ads b/gcc/ada/libgnat/s-dsaser.ads
index 4f38d8b..da0d17b 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2006-2021, 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 d8b15c5d..4a9d538 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2009-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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,20 @@
------------------------------------------------------------------------------
with Ada.Characters.Handling;
+with Ada.Containers.Generic_Array_Sort;
with Ada.Exceptions.Traceback; use Ada.Exceptions.Traceback;
with Ada.Unchecked_Deallocation;
-with Ada.Containers.Generic_Array_Sort;
with Interfaces; use Interfaces;
with System; use System;
-with System.Storage_Elements; use System.Storage_Elements;
with System.Address_Image;
+with System.Bounded_Strings; use System.Bounded_Strings;
with System.IO; use System.IO;
+with System.Mmap; use System.Mmap;
with System.Object_Reader; use System.Object_Reader;
with System.Traceback_Entries; use System.Traceback_Entries;
-with System.Mmap; use System.Mmap;
-with System.Bounded_Strings; use System.Bounded_Strings;
+with System.Storage_Elements; use System.Storage_Elements;
package body System.Dwarf_Lines is
@@ -60,13 +60,19 @@ package body System.Dwarf_Lines is
(S : in out Mapped_Stream;
Len : out Offset;
Is64 : out Boolean);
- -- Read initial length as specified by Dwarf-4 7.2.2
+ -- Read initial length as specified by 7.2.2
procedure Read_Section_Offset
(S : in out Mapped_Stream;
Len : out Offset;
Is64 : Boolean);
- -- Read a section offset, as specified by Dwarf-4 7.4
+ -- Read a section offset, as specified by 7.4
+
+ procedure Read_Entry_Format_Array
+ (S : in out Mapped_Stream;
+ A : out Entry_Format_Array;
+ Len : uint8);
+ -- Read an entry format array, as specified by 6.2.4.1
procedure Read_Aranges_Entry
(C : in out Dwarf_Context;
@@ -111,26 +117,26 @@ package body System.Dwarf_Lines is
-- a compilation unit.
procedure Initialize_Pass (C : in out Dwarf_Context);
- -- Seek to the first byte of the first prologue and prepare to make a pass
+ -- Seek to the first byte of the first header and prepare to make a pass
-- over the line number entries.
procedure Initialize_State_Machine (C : in out Dwarf_Context);
-- Set all state machine registers to their specified initial values
- procedure Parse_Prologue (C : in out Dwarf_Context);
- -- Decode a DWARF statement program prologue
+ procedure Parse_Header (C : in out Dwarf_Context);
+ -- Decode a DWARF statement program header
- procedure Read_And_Execute_Isn
+ procedure Read_And_Execute_Insn
(C : in out Dwarf_Context;
Done : out Boolean);
-- Read an execute a statement program instruction
function To_File_Name
(C : in out Dwarf_Context;
- Code : uint32) return String;
- -- Extract a file name from the prologue
+ File : uint32) return String;
+ -- Extract a file name from the header
- type Callback is access procedure (C : in out Dwarf_Context);
+ type Callback is not null access procedure (C : in out Dwarf_Context);
procedure For_Each_Row (C : in out Dwarf_Context; F : Callback);
-- Traverse each .debug_line entry with a callback
@@ -158,8 +164,25 @@ package body System.Dwarf_Lines is
-- DWARF constants --
-----------------------
+ -- 3.1.1 Full and Partial Compilation Unit Entries
+
+ DW_TAG_Compile_Unit : constant := 16#11#;
+
+ DW_AT_Stmt_List : constant := 16#10#;
+
+ -- 6.2.4.1 Standard Content Descriptions (DWARF 5)
+
+ DW_LNCT_path : constant := 1;
+ DW_LNCT_directory_index : constant := 2;
+ -- DW_LNCT_timestamp : constant := 3;
+ -- DW_LNCT_size : constant := 4;
+ DW_LNCT_MD5 : constant := 5;
+ DW_LNCT_lo_user : constant := 16#2000#;
+ DW_LNCT_hi_user : constant := 16#3fff#;
+
-- 6.2.5.2 Standard Opcodes
+ DW_LNS_extended_op : constant := 0;
DW_LNS_copy : constant := 1;
DW_LNS_advance_pc : constant := 2;
DW_LNS_advance_line : constant := 3;
@@ -175,45 +198,56 @@ package body System.Dwarf_Lines is
-- 6.2.5.3 Extended Opcodes
- DW_LNE_end_sequence : constant := 1;
- DW_LNE_set_address : constant := 2;
- DW_LNE_define_file : constant := 3;
-
- -- From the DWARF version 4 public review draft
-
+ DW_LNE_end_sequence : constant := 1;
+ DW_LNE_set_address : constant := 2;
+ DW_LNE_define_file : constant := 3;
DW_LNE_set_discriminator : constant := 4;
- -- Attribute encodings
-
- DW_TAG_Compile_Unit : constant := 16#11#;
-
- DW_AT_Stmt_List : constant := 16#10#;
-
- DW_FORM_addr : constant := 16#01#;
- DW_FORM_block2 : constant := 16#03#;
- DW_FORM_block4 : constant := 16#04#;
- DW_FORM_data2 : constant := 16#05#;
- DW_FORM_data4 : constant := 16#06#;
- DW_FORM_data8 : constant := 16#07#;
- DW_FORM_string : constant := 16#08#;
- DW_FORM_block : constant := 16#09#;
- DW_FORM_block1 : constant := 16#0a#;
- DW_FORM_data1 : constant := 16#0b#;
- DW_FORM_flag : constant := 16#0c#;
- DW_FORM_sdata : constant := 16#0d#;
- DW_FORM_strp : constant := 16#0e#;
- DW_FORM_udata : constant := 16#0f#;
- DW_FORM_ref_addr : constant := 16#10#;
- DW_FORM_ref1 : constant := 16#11#;
- DW_FORM_ref2 : constant := 16#12#;
- DW_FORM_ref4 : constant := 16#13#;
- DW_FORM_ref8 : constant := 16#14#;
- DW_FORM_ref_udata : constant := 16#15#;
- DW_FORM_indirect : constant := 16#16#;
- DW_FORM_sec_offset : constant := 16#17#;
- DW_FORM_exprloc : constant := 16#18#;
- DW_FORM_flag_present : constant := 16#19#;
- DW_FORM_ref_sig8 : constant := 16#20#;
+ -- 7.5.5 Classes and Forms
+
+ DW_FORM_addr : constant := 16#01#;
+ DW_FORM_block2 : constant := 16#03#;
+ DW_FORM_block4 : constant := 16#04#;
+ DW_FORM_data2 : constant := 16#05#;
+ DW_FORM_data4 : constant := 16#06#;
+ DW_FORM_data8 : constant := 16#07#;
+ DW_FORM_string : constant := 16#08#;
+ DW_FORM_block : constant := 16#09#;
+ DW_FORM_block1 : constant := 16#0a#;
+ DW_FORM_data1 : constant := 16#0b#;
+ DW_FORM_flag : constant := 16#0c#;
+ DW_FORM_sdata : constant := 16#0d#;
+ DW_FORM_strp : constant := 16#0e#;
+ DW_FORM_udata : constant := 16#0f#;
+ DW_FORM_ref_addr : constant := 16#10#;
+ DW_FORM_ref1 : constant := 16#11#;
+ DW_FORM_ref2 : constant := 16#12#;
+ DW_FORM_ref4 : constant := 16#13#;
+ DW_FORM_ref8 : constant := 16#14#;
+ DW_FORM_ref_udata : constant := 16#15#;
+ DW_FORM_indirect : constant := 16#16#;
+ DW_FORM_sec_offset : constant := 16#17#;
+ DW_FORM_exprloc : constant := 16#18#;
+ DW_FORM_flag_present : constant := 16#19#;
+ DW_FORM_strx : constant := 16#1a#;
+ DW_FORM_addrx : constant := 16#1b#;
+ DW_FORM_ref_sup4 : constant := 16#1c#;
+ DW_FORM_strp_sup : constant := 16#1d#;
+ DW_FORM_data16 : constant := 16#1e#;
+ DW_FORM_line_strp : constant := 16#1f#;
+ DW_FORM_ref_sig8 : constant := 16#20#;
+ DW_FORM_implicit_const : constant := 16#21#;
+ DW_FORM_loclistx : constant := 16#22#;
+ DW_FORM_rnglistx : constant := 16#23#;
+ DW_FORM_ref_sup8 : constant := 16#24#;
+ DW_FORM_strx1 : constant := 16#25#;
+ DW_FORM_strx2 : constant := 16#26#;
+ DW_FORM_strx3 : constant := 16#27#;
+ DW_FORM_strx4 : constant := 16#28#;
+ DW_FORM_addrx1 : constant := 16#29#;
+ DW_FORM_addrx2 : constant := 16#2a#;
+ DW_FORM_addrx3 : constant := 16#2b#;
+ DW_FORM_addrx4 : constant := 16#2c#;
---------
-- "<" --
@@ -235,6 +269,7 @@ package body System.Dwarf_Lines is
procedure Unchecked_Deallocation is new Ada.Unchecked_Deallocation
(Search_Array,
Search_Array_Access);
+
begin
if C.Has_Debug then
Close (C.Lines);
@@ -265,6 +300,7 @@ package body System.Dwarf_Lines is
procedure Dump_Row (C : in out Dwarf_Context) is
PC : constant Integer_Address := Integer_Address (C.Registers.Address);
Off : Offset;
+
begin
Tell (C.Lines, Off);
@@ -286,11 +322,13 @@ package body System.Dwarf_Lines is
Cache : constant Search_Array_Access := C.Cache;
S : Object_Symbol;
Name : String_Ptr_Len;
+
begin
if Cache = null then
Put_Line ("No cache");
return;
end if;
+
for I in Cache'Range loop
declare
E : Search_Entry renames Cache (I);
@@ -322,7 +360,7 @@ package body System.Dwarf_Lines is
Initialize_Pass (C);
loop
- Read_And_Execute_Isn (C, Done);
+ Read_And_Execute_Insn (C, Done);
if C.Registers.Is_Row then
F.all (C);
@@ -339,8 +377,7 @@ package body System.Dwarf_Lines is
procedure Initialize_Pass (C : in out Dwarf_Context) is
begin
Seek (C.Lines, 0);
- C.Next_Prologue := 0;
-
+ C.Next_Header := 0;
Initialize_State_Machine (C);
end Initialize_Pass;
@@ -350,17 +387,16 @@ package body System.Dwarf_Lines is
procedure Initialize_State_Machine (C : in out Dwarf_Context) is
begin
+ -- Table 6.4: Line number program initial state
+
C.Registers :=
(Address => 0,
File => 1,
Line => 1,
Column => 0,
- Is_Stmt => C.Prologue.Default_Is_Stmt = 0,
+ Is_Stmt => C.Header.Default_Is_Stmt /= 0,
Basic_Block => False,
End_Sequence => False,
- Prologue_End => False,
- Epilogue_Begin => False,
- ISA => 0,
Is_Row => False);
end Initialize_State_Machine;
@@ -378,8 +414,7 @@ package body System.Dwarf_Lines is
-- Low_Address --
-----------------
- function Low_Address (C : Dwarf_Context)
- return System.Address is
+ function Low_Address (C : Dwarf_Context) return System.Address is
begin
return C.Load_Address + C.Low;
end Low_Address;
@@ -393,19 +428,24 @@ package body System.Dwarf_Lines is
C : out Dwarf_Context;
Success : out Boolean)
is
- Line_Sec, Info_Sec, Abbrev_Sec, Aranges_Sec : Object_Section;
- Hi, Lo : uint64;
+ Abbrev, Aranges, Lines, Info, Line_Str : Object_Section;
+ Hi, Lo : uint64;
+
begin
-- Not a success by default
Success := False;
- -- Open file
+ -- Open file with In_Exception set so we can control the failure mode
- C.Obj := Open (File_Name, C.In_Exception);
+ C.Obj := Open (File_Name, In_Exception => True);
if C.Obj = null then
- return;
+ if C.In_Exception then
+ return;
+ else
+ raise Dwarf_Error with "could not open file";
+ end if;
end if;
Success := True;
@@ -420,21 +460,23 @@ package body System.Dwarf_Lines is
-- Create a stream for debug sections
if Format (C.Obj.all) = XCOFF32 then
- Line_Sec := Get_Section (C.Obj.all, ".dwline");
- Abbrev_Sec := Get_Section (C.Obj.all, ".dwabrev");
- Info_Sec := Get_Section (C.Obj.all, ".dwinfo");
- Aranges_Sec := Get_Section (C.Obj.all, ".dwarnge");
+ Abbrev := Get_Section (C.Obj.all, ".dwabrev");
+ Aranges := Get_Section (C.Obj.all, ".dwarnge");
+ Info := Get_Section (C.Obj.all, ".dwinfo");
+ Lines := Get_Section (C.Obj.all, ".dwline");
+ Line_Str := Get_Section (C.Obj.all, ".dwlistr");
else
- Line_Sec := Get_Section (C.Obj.all, ".debug_line");
- Abbrev_Sec := Get_Section (C.Obj.all, ".debug_abbrev");
- Info_Sec := Get_Section (C.Obj.all, ".debug_info");
- Aranges_Sec := Get_Section (C.Obj.all, ".debug_aranges");
+ Abbrev := Get_Section (C.Obj.all, ".debug_abbrev");
+ Aranges := Get_Section (C.Obj.all, ".debug_aranges");
+ Info := Get_Section (C.Obj.all, ".debug_info");
+ Lines := Get_Section (C.Obj.all, ".debug_line");
+ Line_Str := Get_Section (C.Obj.all, ".debug_line_str");
end if;
- if Line_Sec = Null_Section
- or else Abbrev_Sec = Null_Section
- or else Info_Sec = Null_Section
- or else Aranges_Sec = Null_Section
+ if Abbrev = Null_Section
+ or else Aranges = Null_Section
+ or else Info = Null_Section
+ or else Lines = Null_Section
then
pragma Annotate
(CodePeer, False_Positive,
@@ -444,21 +486,29 @@ package body System.Dwarf_Lines is
return;
end if;
- C.Lines := Create_Stream (C.Obj.all, Line_Sec);
- C.Abbrev := Create_Stream (C.Obj.all, Abbrev_Sec);
- C.Info := Create_Stream (C.Obj.all, Info_Sec);
- C.Aranges := Create_Stream (C.Obj.all, Aranges_Sec);
+ C.Abbrev := Create_Stream (C.Obj.all, Abbrev);
+ C.Aranges := Create_Stream (C.Obj.all, Aranges);
+ C.Info := Create_Stream (C.Obj.all, Info);
+ C.Lines := Create_Stream (C.Obj.all, Lines);
+
+ -- The .debug_line_str section may be available in DWARF 5
+
+ if Line_Str /= Null_Section then
+ C.Line_Str := Create_Stream (C.Obj.all, Line_Str);
+ end if;
-- All operations are successful, context is valid
C.Has_Debug := True;
end Open;
- --------------------
- -- Parse_Prologue --
- --------------------
+ ------------------
+ -- Parse_Header --
+ ------------------
+
+ procedure Parse_Header (C : in out Dwarf_Context) is
+ Header : Line_Info_Header renames C.Header;
- procedure Parse_Prologue (C : in out Dwarf_Context) is
Char : uint8;
Prev : uint8;
-- The most recently read character and the one preceding it
@@ -469,94 +519,147 @@ package body System.Dwarf_Lines is
Buf : Buffer;
Off : Offset;
- First_Byte_Of_Prologue : Offset;
- Last_Byte_Of_Prologue : Offset;
-
- Max_Op_Per_Insn : uint8;
- pragma Unreferenced (Max_Op_Per_Insn);
+ First_Byte_Of_Header : Offset;
+ Last_Byte_Of_Header : Offset;
- Prologue : Line_Info_Prologue renames C.Prologue;
+ Standard_Opcode_Lengths : Opcode_Length_Array;
+ pragma Unreferenced (Standard_Opcode_Lengths);
begin
- Tell (C.Lines, First_Byte_Of_Prologue);
- Prologue.Unit_Length := Read (C.Lines);
+ Tell (C.Lines, First_Byte_Of_Header);
+
+ Read_Initial_Length (C.Lines, Header.Unit_Length, Header.Is64);
+
Tell (C.Lines, Off);
- C.Next_Prologue := Off + Offset (Prologue.Unit_Length);
+ C.Next_Header := Off + Header.Unit_Length;
+
+ Header.Version := Read (C.Lines);
+
+ if Header.Version >= 5 then
+ Header.Address_Size := Read (C.Lines);
+ Header.Segment_Selector_Size := Read (C.Lines);
+ else
+ Header.Address_Size := 0;
+ Header.Segment_Selector_Size := 0;
+ end if;
- Prologue.Version := Read (C.Lines);
- Prologue.Prologue_Length := Read (C.Lines);
- Tell (C.Lines, Last_Byte_Of_Prologue);
- Last_Byte_Of_Prologue :=
- Last_Byte_Of_Prologue + Offset (Prologue.Prologue_Length) - 1;
+ Header.Header_Length := Read (C.Lines);
+ Tell (C.Lines, Last_Byte_Of_Header);
+ Last_Byte_Of_Header :=
+ Last_Byte_Of_Header + Offset (Header.Header_Length) - 1;
- Prologue.Min_Isn_Length := Read (C.Lines);
+ Header.Minimum_Insn_Length := Read (C.Lines);
- if Prologue.Version >= 4 then
- Max_Op_Per_Insn := Read (C.Lines);
+ if Header.Version >= 4 then
+ Header.Maximum_Op_Per_Insn := Read (C.Lines);
+ else
+ Header.Maximum_Op_Per_Insn := 0;
end if;
- Prologue.Default_Is_Stmt := Read (C.Lines);
- Prologue.Line_Base := Read (C.Lines);
- Prologue.Line_Range := Read (C.Lines);
- Prologue.Opcode_Base := Read (C.Lines);
+ Header.Default_Is_Stmt := Read (C.Lines);
+ Header.Line_Base := Read (C.Lines);
+ Header.Line_Range := Read (C.Lines);
+ Header.Opcode_Base := Read (C.Lines);
- -- Opcode_Lengths is an array of Opcode_Base bytes specifying the number
- -- of LEB128 operands for each of the standard opcodes.
+ -- Standard_Opcode_Lengths is an array of Opcode_Base bytes specifying
+ -- the number of LEB128 operands for each of the standard opcodes.
- for J in 1 .. uint32 (Prologue.Opcode_Base - 1) loop
- Prologue.Opcode_Lengths (J) := Read (C.Lines);
+ for J in 1 .. Integer (Header.Opcode_Base - 1) loop
+ Standard_Opcode_Lengths (J) := Read (C.Lines);
end loop;
- -- The include directories table follows. This is a list of null
- -- terminated strings terminated by a double null. We only store
- -- its offset for later decoding.
+ -- The directories table follows. Up to DWARF 4, this is a list of null
+ -- terminated strings terminated by a null byte. In DWARF 5, this is a
+ -- sequence of Directories_Count entries encoded as described by the
+ -- Directory_Entry_Format field. We store its offset for later decoding.
- Tell (C.Lines, Prologue.Includes_Offset);
- Char := Read (C.Lines);
+ if Header.Version <= 4 then
+ Tell (C.Lines, Header.Directories);
+ Char := Read (C.Lines);
- if Char /= 0 then
- loop
- Prev := Char;
- Char := Read (C.Lines);
- exit when Char = 0 and Prev = 0;
+ if Char /= 0 then
+ loop
+ Prev := Char;
+ Char := Read (C.Lines);
+ exit when Char = 0 and Prev = 0;
+ end loop;
+ end if;
+
+ else
+ Header.Directory_Entry_Format_Count := Read (C.Lines);
+ Read_Entry_Format_Array (C.Lines,
+ Header.Directory_Entry_Format,
+ Header.Directory_Entry_Format_Count);
+
+ Header.Directories_Count := Read_LEB128 (C.Lines);
+ Tell (C.Lines, Header.Directories);
+ for J in 1 .. Header.Directories_Count loop
+ for K in 1 .. Integer (Header.Directory_Entry_Format_Count) loop
+ Skip_Form (C.Lines,
+ Header.Directory_Entry_Format (K).Form,
+ Header.Is64,
+ Header.Address_Size);
+ end loop;
end loop;
end if;
- -- The file_names table is next. Each record is a null terminated string
- -- for the file name, an unsigned LEB128 directory index, an unsigned
- -- LEB128 modification time, and an LEB128 file length. The table is
- -- terminated by a null byte.
+ -- The file_names table is next. Up to DWARF 4, this is a list of record
+ -- containing a null terminated string for the file name, an unsigned
+ -- LEB128 directory index in the Directories table, an unsigned LEB128
+ -- modification time, and an unsigned LEB128 for the file length; the
+ -- table is terminated by a null byte. In DWARF 5, this is a sequence
+ -- of File_Names_Count entries encoded as described by the
+ -- File_Name_Entry_Format field. We store its offset for later decoding.
- Tell (C.Lines, Prologue.File_Names_Offset);
+ if Header.Version <= 4 then
+ Tell (C.Lines, Header.File_Names);
- loop
- -- Read the filename
+ -- Read the file names
- Read_C_String (C.Lines, Buf);
- exit when Buf (0) = 0;
- Dummy := Read_LEB128 (C.Lines); -- Skip the directory index.
- Dummy := Read_LEB128 (C.Lines); -- Skip the modification time.
- Dummy := Read_LEB128 (C.Lines); -- Skip the file length.
- end loop;
+ loop
+ Read_C_String (C.Lines, Buf);
+ exit when Buf (0) = 0;
+ Dummy := Read_LEB128 (C.Lines); -- Skip the directory index.
+ Dummy := Read_LEB128 (C.Lines); -- Skip the modification time.
+ Dummy := Read_LEB128 (C.Lines); -- Skip the file length.
+ end loop;
+
+ else
+ Header.File_Name_Entry_Format_Count := Read (C.Lines);
+ Read_Entry_Format_Array (C.Lines,
+ Header.File_Name_Entry_Format,
+ Header.File_Name_Entry_Format_Count);
+
+ Header.File_Names_Count := Read_LEB128 (C.Lines);
+ Tell (C.Lines, Header.File_Names);
+ for J in 1 .. Header.File_Names_Count loop
+ for K in 1 .. Integer (Header.File_Name_Entry_Format_Count) loop
+ Skip_Form (C.Lines,
+ Header.File_Name_Entry_Format (K).Form,
+ Header.Is64,
+ Header.Address_Size);
+ end loop;
+ end loop;
+ end if;
-- Check we're where we think we are. This sanity check ensures we think
- -- the prologue ends where the prologue says it does. It we aren't then
- -- we've probably gotten out of sync somewhere.
+ -- the header ends where the header says it does. It we aren't, then we
+ -- have probably gotten out of sync somewhere.
Tell (C.Lines, Off);
- if Prologue.Unit_Length /= 0
- and then Off /= Last_Byte_Of_Prologue + 1
+ if Header.Unit_Length /= 0
+ and then Off /= Last_Byte_Of_Header + 1
then
- raise Dwarf_Error with "Parse error reading DWARF information";
+ raise Dwarf_Error with "parse error reading DWARF information";
end if;
- end Parse_Prologue;
+ end Parse_Header;
- --------------------------
- -- Read_And_Execute_Isn --
- --------------------------
+ ---------------------------
+ -- Read_And_Execute_Insn --
+ ---------------------------
- procedure Read_And_Execute_Isn
+ procedure Read_And_Execute_Insn
(C : in out Dwarf_Context;
Done : out Boolean)
is
@@ -572,7 +675,7 @@ package body System.Dwarf_Lines is
Obj : Object_File renames C.Obj.all;
Registers : Line_Info_Registers renames C.Registers;
- Prologue : Line_Info_Prologue renames C.Prologue;
+ Header : Line_Info_Header renames C.Header;
begin
Done := False;
@@ -582,8 +685,8 @@ package body System.Dwarf_Lines is
Initialize_State_Machine (C);
end if;
- -- If we have reached the next prologue, read it. Beware of possibly
- -- empty blocks.
+ -- If we have reached the next header, read it. Beware of possibly empty
+ -- blocks.
-- When testing for the end of section, beware of possible zero padding
-- at the end. Bail out as soon as there's not even room for at least a
@@ -592,9 +695,9 @@ package body System.Dwarf_Lines is
-- or Off+3 > Section_Length.
Tell (C.Lines, Off);
- while Off = C.Next_Prologue loop
+ while Off = C.Next_Header loop
Initialize_State_Machine (C);
- Parse_Prologue (C);
+ Parse_Header (C);
Tell (C.Lines, Off);
exit when Off + 3 > Length (C.Lines);
end loop;
@@ -606,7 +709,7 @@ package body System.Dwarf_Lines is
-- We are finished when we either reach the end of the section, or we
-- have reached zero padding at the end of the section.
- if Prologue.Unit_Length = 0 or else Off + 3 > Length (C.Lines) then
+ if Header.Unit_Length = 0 or else Off + 3 > Length (C.Lines) then
Done := True;
return;
end if;
@@ -617,7 +720,7 @@ package body System.Dwarf_Lines is
-- Extended opcodes
- if Opcode = 0 then
+ if Opcode = DW_LNS_extended_op then
Extended_Length := Read_LEB128 (C.Lines);
Extended_Opcode := Read (C.Lines);
@@ -656,7 +759,7 @@ package body System.Dwarf_Lines is
-- Standard opcodes
- elsif Opcode < Prologue.Opcode_Base then
+ elsif Opcode < Header.Opcode_Base then
case Opcode is
-- Append a row to the line info matrix
@@ -671,7 +774,7 @@ package body System.Dwarf_Lines is
uint32_Operand := Read_LEB128 (C.Lines);
Registers.Address :=
Registers.Address +
- uint64 (uint32_Operand * uint32 (Prologue.Min_Isn_Length));
+ uint64 (uint32_Operand * uint32 (Header.Minimum_Insn_Length));
-- Add a signed word to the current source line
@@ -708,8 +811,8 @@ package body System.Dwarf_Lines is
Registers.Address :=
Registers.Address +
uint64
- (((255 - Prologue.Opcode_Base) / Prologue.Line_Range) *
- Prologue.Min_Isn_Length);
+ (((255 - Header.Opcode_Base) / Header.Line_Range) *
+ Header.Minimum_Insn_Length);
-- Advance the program counter by a constant
@@ -744,7 +847,7 @@ package body System.Dwarf_Lines is
Line_Increment : int32;
begin
- Opcode := Opcode - Prologue.Opcode_Base;
+ Opcode := Opcode - Header.Opcode_Base;
-- The adjusted opcode is a uint8 encoding an address increment
-- and a signed line increment. The upperbound is allowed to be
@@ -752,18 +855,16 @@ package body System.Dwarf_Lines is
-- prevent overflows.
Address_Increment :=
- int32 (Opcode / Prologue.Line_Range) *
- int32 (Prologue.Min_Isn_Length);
+ int32 (Opcode / Header.Line_Range) *
+ int32 (Header.Minimum_Insn_Length);
Line_Increment :=
- int32 (Prologue.Line_Base) +
- int32 (Opcode mod Prologue.Line_Range);
+ int32 (Header.Line_Base) +
+ int32 (Opcode mod Header.Line_Range);
Registers.Address :=
Registers.Address + uint64 (Address_Increment);
Registers.Line := uint32 (int32 (Registers.Line) + Line_Increment);
Registers.Basic_Block := False;
- Registers.Prologue_End := False;
- Registers.Epilogue_Begin := False;
Registers.Is_Row := True;
end;
end if;
@@ -775,7 +876,7 @@ package body System.Dwarf_Lines is
Registers.Is_Row := False;
Done := True;
- end Read_And_Execute_Isn;
+ end Read_And_Execute_Insn;
----------------------
-- Set_Load_Address --
@@ -792,10 +893,10 @@ package body System.Dwarf_Lines is
function To_File_Name
(C : in out Dwarf_Context;
- Code : uint32) return String
+ File : uint32) return String
is
Buf : Buffer;
- J : uint32;
+ Off : Offset;
Dir_Idx : uint32;
pragma Unreferenced (Dir_Idx);
@@ -806,25 +907,56 @@ package body System.Dwarf_Lines is
Length : uint32;
pragma Unreferenced (Length);
+ File_Entry_Format : Entry_Format_Array
+ renames C.Header.File_Name_Entry_Format;
+
begin
- Seek (C.Lines, C.Prologue.File_Names_Offset);
+ Seek (C.Lines, C.Header.File_Names);
- -- Find the entry
+ -- Find the entry. Note that, up to DWARF 4, the index is 1-based
+ -- whereas, in DWARF 5, it is 0-based.
- J := 0;
- loop
- J := J + 1;
- Read_C_String (C.Lines, Buf);
+ if C.Header.Version <= 4 then
+ for J in 1 .. File loop
+ Read_C_String (C.Lines, Buf);
- if Buf (Buf'First) = 0 then
- return "???";
- end if;
+ if Buf (Buf'First) = 0 then
+ return "???";
+ end if;
- Dir_Idx := Read_LEB128 (C.Lines);
- Mod_Time := Read_LEB128 (C.Lines);
- Length := Read_LEB128 (C.Lines);
- exit when J = Code;
- end loop;
+ Dir_Idx := Read_LEB128 (C.Lines);
+ Mod_Time := Read_LEB128 (C.Lines);
+ Length := Read_LEB128 (C.Lines);
+ end loop;
+
+ -- DWARF 5
+
+ else
+ for J in 0 .. File loop
+ for K in 1 .. Integer (C.Header.File_Name_Entry_Format_Count) loop
+ if File_Entry_Format (K).C_Type = DW_LNCT_path then
+ case File_Entry_Format (K).Form is
+ when DW_FORM_string =>
+ Read_C_String (C.Lines, Buf);
+
+ when DW_FORM_line_strp =>
+ Read_Section_Offset (C.Lines, Off, C.Header.Is64);
+ Seek (C.Line_Str, Off);
+ Read_C_String (C.Line_Str, Buf);
+
+ when others =>
+ raise Dwarf_Error with "DWARF form not implemented";
+ end case;
+
+ else
+ Skip_Form (C.Lines,
+ File_Entry_Format (K).Form,
+ C.Header.Is64,
+ C.Header.Address_Size);
+ end if;
+ end loop;
+ end loop;
+ end if;
return To_String (Buf);
end To_File_Name;
@@ -840,6 +972,7 @@ package body System.Dwarf_Lines is
is
Len32 : uint32;
Len64 : uint64;
+
begin
Len32 := Read (S);
if Len32 < 16#ffff_fff0# then
@@ -872,6 +1005,43 @@ package body System.Dwarf_Lines is
end if;
end Read_Section_Offset;
+ -----------------------------
+ -- Read_Entry_Format_Array --
+ -----------------------------
+
+ procedure Read_Entry_Format_Array
+ (S : in out Mapped_Stream;
+ A : out Entry_Format_Array;
+ Len : uint8)
+ is
+ C_Type, Form : uint32;
+ N : Integer;
+
+ begin
+ N := A'First;
+
+ for J in 1 .. Len loop
+ C_Type := Read_LEB128 (S);
+ Form := Read_LEB128 (S);
+
+ case C_Type is
+ when DW_LNCT_path .. DW_LNCT_MD5 =>
+ if N not in A'Range then
+ raise Dwarf_Error with "DWARF duplicate content type";
+ end if;
+
+ A (N) := (C_Type, Form);
+ N := N + 1;
+
+ when DW_LNCT_lo_user .. DW_LNCT_hi_user =>
+ null;
+
+ when others =>
+ raise Dwarf_Error with "DWARF content type not implemented";
+ end case;
+ end loop;
+ end Read_Entry_Format_Array;
+
--------------------
-- Aranges_Lookup --
--------------------
@@ -921,31 +1091,53 @@ package body System.Dwarf_Lines is
Ptr_Sz : uint8)
is
Skip : Offset;
+
begin
+ -- 7.5.5 Classes and Forms
+
case Form is
when DW_FORM_addr =>
Skip := Offset (Ptr_Sz);
+ when DW_FORM_addrx =>
+ Skip := Offset (uint32'(Read_LEB128 (S)));
+ when DW_FORM_block1 =>
+ Skip := Offset (uint8'(Read (S)));
when DW_FORM_block2 =>
Skip := Offset (uint16'(Read (S)));
when DW_FORM_block4 =>
Skip := Offset (uint32'(Read (S)));
- when DW_FORM_data2 | DW_FORM_ref2 =>
- Skip := 2;
- when DW_FORM_data4 | DW_FORM_ref4 =>
- Skip := 4;
- when DW_FORM_data8 | DW_FORM_ref8 | DW_FORM_ref_sig8 =>
- Skip := 8;
- when DW_FORM_string =>
- while uint8'(Read (S)) /= 0 loop
- null;
- end loop;
- return;
when DW_FORM_block | DW_FORM_exprloc =>
Skip := Offset (uint32'(Read_LEB128 (S)));
- when DW_FORM_block1 | DW_FORM_ref1 =>
- Skip := Offset (uint8'(Read (S)));
- when DW_FORM_data1 | DW_FORM_flag =>
+ when DW_FORM_addrx1
+ | DW_FORM_data1
+ | DW_FORM_flag
+ | DW_FORM_ref1
+ | DW_FORM_strx1
+ =>
Skip := 1;
+ when DW_FORM_addrx2
+ | DW_FORM_data2
+ | DW_FORM_ref2
+ | DW_FORM_strx2
+ =>
+ Skip := 2;
+ when DW_FORM_addrx3 | DW_FORM_strx3 =>
+ Skip := 3;
+ when DW_FORM_addrx4
+ | DW_FORM_data4
+ | DW_FORM_ref4
+ | DW_FORM_ref_sup4
+ | DW_FORM_strx4
+ =>
+ Skip := 4;
+ when DW_FORM_data8
+ | DW_FORM_ref8
+ | DW_FORM_ref_sup8
+ | DW_FORM_ref_sig8
+ =>
+ Skip := 8;
+ when DW_FORM_data16 =>
+ Skip := 16;
when DW_FORM_sdata =>
declare
Val : constant int32 := Read_LEB128 (S);
@@ -953,9 +1145,12 @@ package body System.Dwarf_Lines is
begin
return;
end;
- when DW_FORM_strp | DW_FORM_ref_addr | DW_FORM_sec_offset =>
- Skip := (if Is64 then 8 else 4);
- when DW_FORM_udata | DW_FORM_ref_udata =>
+ when DW_FORM_udata
+ | DW_FORM_ref_udata
+ | DW_FORM_loclistx
+ | DW_FORM_rnglistx
+ | DW_FORM_strx
+ =>
declare
Val : constant uint32 := Read_LEB128 (S);
pragma Unreferenced (Val);
@@ -964,11 +1159,24 @@ package body System.Dwarf_Lines is
end;
when DW_FORM_flag_present =>
return;
- when DW_FORM_indirect =>
+ when DW_FORM_ref_addr
+ | DW_FORM_sec_offset
+ | DW_FORM_strp
+ | DW_FORM_line_strp
+ | DW_FORM_strp_sup
+ =>
+ Skip := (if Is64 then 8 else 4);
+ when DW_FORM_string =>
+ while uint8'(Read (S)) /= 0 loop
+ null;
+ end loop;
+ return;
+ when DW_FORM_implicit_const | DW_FORM_indirect =>
raise Constraint_Error;
when others =>
raise Constraint_Error;
end case;
+
Seek (S, Tell (S) + Skip);
end Skip_Form;
@@ -981,20 +1189,21 @@ package body System.Dwarf_Lines is
Abbrev_Offset : Offset;
Abbrev_Num : uint32)
is
- Num : uint32;
Abbrev : uint32;
Tag : uint32;
Has_Child : uint8;
- pragma Unreferenced (Abbrev, Tag, Has_Child);
+ pragma Unreferenced (Tag, Has_Child);
+
begin
Seek (C.Abbrev, Abbrev_Offset);
- Num := 1;
+ -- 7.5.3 Abbreviations Tables
loop
- exit when Num = Abbrev_Num;
+ Abbrev := Read_LEB128 (C.Abbrev);
+
+ exit when Abbrev = Abbrev_Num;
- Abbrev := Read_LEB128 (C.Abbrev);
Tag := Read_LEB128 (C.Abbrev);
Has_Child := Read (C.Abbrev);
@@ -1002,12 +1211,19 @@ package body System.Dwarf_Lines is
declare
Name : constant uint32 := Read_LEB128 (C.Abbrev);
Form : constant uint32 := Read_LEB128 (C.Abbrev);
+ Cst : int32;
+ pragma Unreferenced (Cst);
+
begin
- exit when Name = 0 and Form = 0;
+ -- DW_FORM_implicit_const takes its value from the table
+
+ if Form = DW_FORM_implicit_const then
+ Cst := Read_LEB128 (C.Abbrev);
+ end if;
+
+ exit when Name = 0 and then Form = 0;
end;
end loop;
-
- Num := Num + 1;
end loop;
end Seek_Abbrev;
@@ -1029,23 +1245,40 @@ package body System.Dwarf_Lines is
Abbrev : uint32;
Has_Child : uint8;
pragma Unreferenced (Has_Child);
+ Unit_Type : uint8;
+ pragma Unreferenced (Unit_Type);
+
begin
Line_Offset := 0;
Success := False;
Seek (C.Info, Info_Offset);
+ -- 7.5.1.1 Compilation Unit Header
+
Read_Initial_Length (C.Info, Unit_Length, Is64);
Version := Read (C.Info);
- if Version not in 2 .. 4 then
- return;
- end if;
- Read_Section_Offset (C.Info, Abbrev_Offset, Is64);
+ if Version >= 5 then
+ Unit_Type := Read (C.Info);
+
+ Addr_Sz := Read (C.Info);
+ if Addr_Sz /= (Address'Size / SSU) then
+ return;
+ end if;
+
+ Read_Section_Offset (C.Info, Abbrev_Offset, Is64);
+
+ elsif Version >= 2 then
+ Read_Section_Offset (C.Info, Abbrev_Offset, Is64);
+
+ Addr_Sz := Read (C.Info);
+ if Addr_Sz /= (Address'Size / SSU) then
+ return;
+ end if;
- Addr_Sz := Read (C.Info);
- if Addr_Sz /= (Address'Size / SSU) then
+ else
return;
end if;
@@ -1060,17 +1293,9 @@ package body System.Dwarf_Lines is
Seek_Abbrev (C, Abbrev_Offset, Abbrev);
- -- First ULEB128 is the abbrev code
-
- if Read_LEB128 (C.Abbrev) /= Abbrev then
- -- Ill formed abbrev table
- return;
- end if;
-
-- Then the tag
if Read_LEB128 (C.Abbrev) /= uint32'(DW_TAG_Compile_Unit) then
- -- Expect compile unit
return;
end if;
@@ -1104,8 +1329,6 @@ package body System.Dwarf_Lines is
end if;
end;
end loop;
-
- return;
end Debug_Info_Lookup;
-------------------------
@@ -1121,6 +1344,7 @@ package body System.Dwarf_Lines is
Is64 : Boolean;
Version : uint16;
Sz : uint8;
+
begin
Success := False;
Info_Offset := 0;
@@ -1149,6 +1373,7 @@ package body System.Dwarf_Lines is
end if;
-- Handle alignment on twice the address size
+
declare
Cur_Off : constant Offset := Tell (C.Aranges);
Align : constant Offset := 2 * Address'Size / SSU;
@@ -1173,6 +1398,7 @@ package body System.Dwarf_Lines is
is
begin
-- Read table
+
if Address'Size = 32 then
declare
S, L : uint32;
@@ -1182,6 +1408,7 @@ package body System.Dwarf_Lines is
Start := Storage_Offset (S);
Len := Storage_Count (L);
end;
+
elsif Address'Size = 64 then
declare
S, L : uint64;
@@ -1191,6 +1418,7 @@ package body System.Dwarf_Lines is
Start := Storage_Offset (S);
Len := Storage_Count (L);
end;
+
else
raise Constraint_Error;
end if;
@@ -1202,8 +1430,11 @@ package body System.Dwarf_Lines is
procedure Enable_Cache (C : in out Dwarf_Context) is
Cache : Search_Array_Access;
+
begin
- -- Phase 1: count number of symbols. Phase 2: fill the cache.
+ -- Phase 1: count number of symbols.
+ -- Phase 2: fill the cache.
+
declare
S : Object_Symbol;
Val : uint64;
@@ -1220,6 +1451,7 @@ package body System.Dwarf_Lines is
while S /= Null_Symbol loop
-- Discard symbols of length 0 or located outside of the
-- execution code section outer boundaries.
+
Sz := uint32 (Size (S));
Val := Value (S);
@@ -1227,11 +1459,11 @@ package body System.Dwarf_Lines is
and then Val >= Xcode_Low
and then Val <= Xcode_High
then
-
Addr := uint32 (Val - Xcode_Low);
-- Try to filter symbols at the same address. This is a best
-- effort as they might not be consecutive.
+
if Addr /= Prev_Addr then
Nbr_Symbols := Nbr_Symbols + 1;
Prev_Addr := Addr;
@@ -1251,6 +1483,7 @@ package body System.Dwarf_Lines is
if Phase = 1 then
-- Allocate the cache
+
Cache := new Search_Array (1 .. Nbr_Symbols);
C.Cache := Cache;
end if;
@@ -1258,13 +1491,16 @@ package body System.Dwarf_Lines is
pragma Assert (Nbr_Symbols = C.Cache'Last);
end;
- -- Sort the cache.
+ -- Sort the cache
+
Sort_Search_Array (C.Cache.all);
-- Set line offsets
+
if not C.Has_Debug then
return;
end if;
+
declare
Info_Offset : Offset;
Line_Offset : Offset;
@@ -1285,6 +1521,7 @@ package body System.Dwarf_Lines is
exit when not Success;
-- Read table
+
loop
Read_Aranges_Entry (C, Ar_Start, Ar_Len);
exit when Ar_Start = 0 and Ar_Len = 0;
@@ -1293,6 +1530,7 @@ package body System.Dwarf_Lines is
Start := uint32 (Ar_Start - C.Low);
-- Search START in the array
+
First := Cache'First;
Last := Cache'Last;
Mid := First; -- In case of array with one element
@@ -1307,9 +1545,10 @@ package body System.Dwarf_Lines is
end if;
end loop;
- -- Fill info.
+ -- Fill info
-- There can be overlapping symbols
+
while Mid > Cache'First
and then Cache (Mid - 1).First <= Start
and then Cache (Mid - 1).First + Cache (Mid - 1).Size > Start
@@ -1321,9 +1560,11 @@ package body System.Dwarf_Lines is
and then Start + Len > Cache (Mid).First
then
-- MID is within the bounds
+
Cache (Mid).Line := uint32 (Line_Offset);
elsif Start + Len <= Cache (Mid).First then
-- Over
+
exit;
end if;
Mid := Mid + 1;
@@ -1350,7 +1591,7 @@ package body System.Dwarf_Lines is
procedure Set_Result (Match : Line_Info_Registers) is
Dir_Idx : uint32;
- J : uint32;
+ Off : Offset;
Mod_Time : uint32;
pragma Unreferenced (Mod_Time);
@@ -1358,46 +1599,123 @@ package body System.Dwarf_Lines is
Length : uint32;
pragma Unreferenced (Length);
+ Directory_Entry_Format : Entry_Format_Array
+ renames C.Header.Directory_Entry_Format;
+
+ File_Entry_Format : Entry_Format_Array
+ renames C.Header.File_Name_Entry_Format;
+
begin
- Seek (C.Lines, C.Prologue.File_Names_Offset);
+ Seek (C.Lines, C.Header.File_Names);
+ Dir_Idx := 0;
- -- Find the entry
+ -- Find the entry. Note that, up to DWARF 4, the index is 1-based
+ -- whereas, in DWARF 5, it is 0-based.
- J := 0;
- loop
- J := J + 1;
- File_Name := Read_C_String (C.Lines);
+ if C.Header.Version <= 4 then
+ for J in 1 .. Match.File loop
+ File_Name := Read_C_String (C.Lines);
- if File_Name (File_Name'First) = ASCII.NUL then
- -- End of file list, so incorrect entry
- return;
- end if;
+ if File_Name (File_Name'First) = ASCII.NUL then
+ -- End of file list, so incorrect entry
+ return;
+ end if;
- Dir_Idx := Read_LEB128 (C.Lines);
- Mod_Time := Read_LEB128 (C.Lines);
- Length := Read_LEB128 (C.Lines);
- exit when J = Match.File;
- end loop;
+ Dir_Idx := Read_LEB128 (C.Lines);
+ Mod_Time := Read_LEB128 (C.Lines);
+ Length := Read_LEB128 (C.Lines);
+ end loop;
+
+ if Dir_Idx = 0 then
+ -- No directory
+
+ Dir_Name := null;
+
+ else
+ Seek (C.Lines, C.Header.Directories);
+
+ for J in 1 .. Dir_Idx loop
+ Dir_Name := Read_C_String (C.Lines);
- if Dir_Idx = 0 then
- -- No directory
- Dir_Name := null;
+ if Dir_Name (Dir_Name'First) = ASCII.NUL then
+ -- End of directory list, so ill-formed table
+
+ return;
+ end if;
+ end loop;
+ end if;
+
+ -- DWARF 5
else
- Seek (C.Lines, C.Prologue.Includes_Offset);
+ for J in 0 .. Match.File loop
+ for K in 1 .. Integer (C.Header.File_Name_Entry_Format_Count)
+ loop
+ if File_Entry_Format (K).C_Type = DW_LNCT_path then
+ case File_Entry_Format (K).Form is
+ when DW_FORM_string =>
+ File_Name := Read_C_String (C.Lines);
- J := 0;
- loop
- J := J + 1;
- Dir_Name := Read_C_String (C.Lines);
+ when DW_FORM_line_strp =>
+ Read_Section_Offset (C.Lines, Off, C.Header.Is64);
+ Seek (C.Line_Str, Off);
+ File_Name := Read_C_String (C.Line_Str);
- if Dir_Name (Dir_Name'First) = ASCII.NUL then
- -- End of directory list, so ill-formed table
- return;
- end if;
+ when others =>
+ raise Dwarf_Error with "DWARF form not implemented";
+ end case;
+
+ elsif File_Entry_Format (K).C_Type = DW_LNCT_directory_index
+ then
+ case File_Entry_Format (K).Form is
+ when DW_FORM_data1 =>
+ Dir_Idx := uint32 (uint8'(Read (C.Lines)));
+
+ when DW_FORM_data2 =>
+ Dir_Idx := uint32 (uint16'(Read (C.Lines)));
+
+ when DW_FORM_udata =>
+ Dir_Idx := Read_LEB128 (C.Lines);
- exit when J = Dir_Idx;
+ when others =>
+ raise Dwarf_Error with "invalid DWARF";
+ end case;
+ else
+ Skip_Form (C.Lines,
+ File_Entry_Format (K).Form,
+ C.Header.Is64,
+ C.Header.Address_Size);
+ end if;
+ end loop;
+ end loop;
+
+ Seek (C.Lines, C.Header.Directories);
+
+ for J in 0 .. Dir_Idx loop
+ for K in 1 .. Integer (C.Header.Directory_Entry_Format_Count)
+ loop
+ if Directory_Entry_Format (K).C_Type = DW_LNCT_path then
+ case Directory_Entry_Format (K).Form is
+ when DW_FORM_string =>
+ Dir_Name := Read_C_String (C.Lines);
+
+ when DW_FORM_line_strp =>
+ Read_Section_Offset (C.Lines, Off, C.Header.Is64);
+ Seek (C.Line_Str, Off);
+ Dir_Name := Read_C_String (C.Line_Str);
+
+ when others =>
+ raise Dwarf_Error with "DWARF form not implemented";
+ end case;
+
+ else
+ Skip_Form (C.Lines,
+ Directory_Entry_Format (K).Form,
+ C.Header.Is64,
+ C.Header.Address_Size);
+ end if;
+ end loop;
end loop;
end if;
@@ -1414,13 +1732,15 @@ package body System.Dwarf_Lines is
begin
-- Initialize result
+
Dir_Name := null;
File_Name := null;
Subprg_Name := (null, 0);
Line_Num := 0;
+ -- Look up the symbol in the cache
+
if C.Cache /= null then
- -- Look in the cache
declare
Addr_Off : constant uint32 := uint32 (Addr - C.Low);
First, Last, Mid : Natural;
@@ -1447,12 +1767,13 @@ package body System.Dwarf_Lines is
S := Read_Symbol (C.Obj.all, Offset (C.Cache (Mid).Sym));
Subprg_Name := Object_Reader.Name (C.Obj.all, S);
else
- -- Not found
return;
end if;
end;
+
+ -- Search for the symbol in the binary
+
else
- -- Search symbol
S := First_Symbol (C.Obj.all);
while S /= Null_Symbol loop
if Spans (S, Addr_Int) then
@@ -1479,15 +1800,15 @@ package body System.Dwarf_Lines is
end if;
Seek (C.Lines, Line_Offset);
- C.Next_Prologue := 0;
+ C.Next_Header := 0;
Initialize_State_Machine (C);
- Parse_Prologue (C);
+ Parse_Header (C);
Previous_Row.Line := 0;
-- Advance to the first entry
loop
- Read_And_Execute_Isn (C, Done);
+ Read_And_Execute_Insn (C, Done);
if C.Registers.Is_Row then
Previous_Row := C.Registers;
@@ -1499,8 +1820,8 @@ package body System.Dwarf_Lines is
-- Read the rest of the entries
- while Tell (C.Lines) < C.Next_Prologue loop
- Read_And_Execute_Isn (C, Done);
+ while Tell (C.Lines) < C.Next_Header loop
+ Read_And_Execute_Insn (C, Done);
if C.Registers.Is_Row then
if not Previous_Row.End_Sequence
@@ -1533,6 +1854,7 @@ package body System.Dwarf_Lines is
return I - Str'First;
end if;
end loop;
+
return Str'Last;
end String_Length;
@@ -1558,6 +1880,7 @@ package body System.Dwarf_Lines is
Subprg_Name : String_Ptr_Len;
Line_Num : Natural;
Off : Natural;
+
begin
if not C.Has_Debug then
Symbol_Found := False;
@@ -1657,4 +1980,5 @@ package body System.Dwarf_Lines is
Append (Res, ASCII.LF);
end loop;
end Symbolic_Traceback;
+
end System.Dwarf_Lines;
diff --git a/gcc/ada/libgnat/s-dwalin.ads b/gcc/ada/libgnat/s-dwalin.ads
index 072f089..132d3e1 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2009-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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,13 +30,10 @@
------------------------------------------------------------------------------
-- This package provides routines to read DWARF line number information from
--- a generic object file with as little overhead as possible. This allows
--- conversions from PC addresses to human readable source locations.
+-- a binary file with as little overhead as possible. This allows conversions
+-- from PC addresses to human-readable source locations.
--
--- Objects must be built with debugging information, however only the
--- .debug_line section of the object file is referenced. In cases where object
--- size is a consideration it's possible to strip all other .debug sections,
--- which will decrease the size of the object significantly.
+-- Files must be compiled with at least minimal debugging information (-g1).
with Ada.Exceptions.Traceback;
@@ -50,11 +47,11 @@ package System.Dwarf_Lines is
package SOR renames System.Object_Reader;
type Dwarf_Context (In_Exception : Boolean := False) is private;
- -- Type encapsulation the state of the Dwarf reader. When In_Exception
- -- is True we are parsing as part of a exception handler decorator, we do
- -- not want an exception to be raised, the parsing is done safely skipping
- -- DWARF file that cannot be read or with stripped debug section for
- -- example.
+ -- Type encapsulating the state of the DWARF reader. When In_Exception is
+ -- True, we are parsing as part of an exception handler decorator so we do
+ -- not want another exception to be raised and the parsing is done safely,
+ -- skipping binary files that cannot be read or have been stripped from
+ -- their debug sections for example.
procedure Open
(File_Name : String;
@@ -65,14 +62,13 @@ package System.Dwarf_Lines is
procedure Set_Load_Address (C : in out Dwarf_Context; Addr : Address);
-- Set the load address of a file. This is used to rebase PIE (Position
- -- Independant Executable) binaries.
+ -- Independent Executable) binaries.
function Is_Inside (C : Dwarf_Context; Addr : Address) return Boolean;
pragma Inline (Is_Inside);
-- Return true iff a run-time address Addr is within the module
- function Low_Address (C : Dwarf_Context)
- return System.Address;
+ function Low_Address (C : Dwarf_Context) return System.Address;
pragma Inline (Low_Address);
-- Return the lowest address of C, accounting for the module load address
@@ -83,7 +79,7 @@ package System.Dwarf_Lines is
-- Dump the cache (if present)
procedure Enable_Cache (C : in out Dwarf_Context);
- -- Read symbols information to speed up Symbolic_Traceback.
+ -- Read symbol information to speed up Symbolic_Traceback.
procedure Symbolic_Traceback
(Cin : Dwarf_Context;
@@ -102,45 +98,64 @@ package System.Dwarf_Lines is
private
-- The following section numbers reference
- -- "DWARF Debugging Information Format, Version 3"
+ -- "DWARF Debugging Information Format, Version 5"
-- published by the Standards Group, http://freestandards.org.
-- 6.2.2 State Machine Registers
type Line_Info_Registers is record
- Address : SOR.uint64;
- File : SOR.uint32;
- Line : SOR.uint32;
- Column : SOR.uint32;
- Is_Stmt : Boolean;
- Basic_Block : Boolean;
- End_Sequence : Boolean;
- Prologue_End : Boolean;
- Epilogue_Begin : Boolean;
- ISA : SOR.uint32;
- Is_Row : Boolean;
+ Address : SOR.uint64;
+ File : SOR.uint32;
+ Line : SOR.uint32;
+ Column : SOR.uint32;
+ Is_Stmt : Boolean;
+ Basic_Block : Boolean;
+ End_Sequence : Boolean;
+ -- Prologue_End : Boolean;
+ -- Epilogue_Begin : Boolean;
+ -- ISA : SOR.uint32;
+ -- Discriminator : SOR.uint32; -- DWARF 4/5
+ Is_Row : Boolean; -- local
end record;
- -- 6.2.4 The Line Number Program Prologue
-
- MAX_OPCODE_LENGTHS : constant := 256;
-
- type Opcodes_Lengths_Array is
- array (SOR.uint32 range 1 .. MAX_OPCODE_LENGTHS) of SOR.uint8;
-
- type Line_Info_Prologue is record
- Unit_Length : SOR.uint32;
- Version : SOR.uint16;
- Prologue_Length : SOR.uint32;
- Min_Isn_Length : SOR.uint8;
- Default_Is_Stmt : SOR.uint8;
- Line_Base : SOR.int8;
- Line_Range : SOR.uint8;
- Opcode_Base : SOR.uint8;
- Opcode_Lengths : Opcodes_Lengths_Array;
- Includes_Offset : SOR.Offset;
- File_Names_Offset : SOR.Offset;
+ -- 6.2.4 The Line Number Program Header
+
+ MAX_OPCODE : constant := 256;
+
+ type Opcode_Length_Array is array (1 .. MAX_OPCODE) of SOR.uint8;
+
+ MAX_ENTRY : constant := 5;
+
+ type Entry_Format_Pair is record
+ C_Type : SOR.uint32;
+ Form : SOR.uint32;
+ end record;
+
+ type Entry_Format_Array is array (1 .. MAX_ENTRY) of Entry_Format_Pair;
+
+ type Line_Info_Header is record
+ Unit_Length : SOR.Offset;
+ Version : SOR.uint16;
+ Address_Size : SOR.uint8; -- DWARF 5
+ Segment_Selector_Size : SOR.uint8; -- DWARF 5
+ Header_Length : SOR.uint32;
+ Minimum_Insn_Length : SOR.uint8;
+ Maximum_Op_Per_Insn : SOR.uint8; -- DWARF 4/5
+ Default_Is_Stmt : SOR.uint8;
+ Line_Base : SOR.int8;
+ Line_Range : SOR.uint8;
+ Opcode_Base : SOR.uint8;
+ -- Standard_Opcode_Lengths : Opcode_Length_Array;
+ Directory_Entry_Format_Count : SOR.uint8; -- DWARF 5
+ Directory_Entry_Format : Entry_Format_Array; -- DWARF 5
+ Directories_Count : SOR.uint32; -- DWARF 5
+ Directories : SOR.Offset;
+ File_Name_Entry_Format_Count : SOR.uint8; -- DWARF 5
+ File_Name_Entry_Format : Entry_Format_Array; -- DWARF 5
+ File_Names_Count : SOR.uint32; -- DWARF 5
+ File_Names : SOR.Offset;
+ Is64 : Boolean; -- local
end record;
type Search_Entry is record
@@ -175,15 +190,16 @@ private
Cache : Search_Array_Access;
-- Quick access to symbol and debug info (when present).
- Lines : SOR.Mapped_Stream;
- Aranges : SOR.Mapped_Stream;
- Info : SOR.Mapped_Stream;
- Abbrev : SOR.Mapped_Stream;
- -- Dwarf line, aranges, info and abbrev sections
+ Abbrev : SOR.Mapped_Stream;
+ Aranges : SOR.Mapped_Stream;
+ Info : SOR.Mapped_Stream;
+ Lines : SOR.Mapped_Stream;
+ Line_Str : SOR.Mapped_Stream; -- DWARF 5
+ -- DWARF sections
- Prologue : Line_Info_Prologue;
- Registers : Line_Info_Registers;
- Next_Prologue : SOR.Offset;
+ Header : Line_Info_Header;
+ Registers : Line_Info_Registers;
+ Next_Header : SOR.Offset;
-- State for lines
end record;
diff --git a/gcc/ada/libgnat/s-elaall.adb b/gcc/ada/libgnat/s-elaall.adb
index 03ed66c..5807433 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2014-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 27344bf..44c1f60 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2014-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 56efde6..2c22ee9 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2006-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 c1836b2..6c93f4c 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2006-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 228cf2b..fa220b3 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2006-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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,17 +29,4 @@
-- --
------------------------------------------------------------------------------
--- This package does not require a body, since it is a package renaming. We
--- provide a dummy file containing a No_Body pragma so that previous versions
--- of the body (which did exist) will not interfere.
-
--- pragma No_Body;
-
--- The above pragma is commented out, since for now we can't use No_Body in
--- a unit marked as a Compiler_Unit, since this requires GNAT 6.1, and we
--- do not yet require this for bootstrapping. So instead we use a dummy Taft
--- amendment type to require the body:
-
-package body System.Exceptions is
- type Require_Body is new Integer;
-end System.Exceptions;
+pragma No_Body;
diff --git a/gcc/ada/libgnat/s-except.ads b/gcc/ada/libgnat/s-except.ads
index 29d960e..10448bc 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2006-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -34,30 +34,10 @@ pragma Compiler_Unit_Warning;
package System.Exceptions is
pragma Preelaborate;
- -- To let Ada.Exceptions "with" us and let us "with" Standard_Library
-
- ZCX_By_Default : constant Boolean;
- -- Visible copy to allow Ada.Exceptions to know the exception model
+ -- To let Ada.Exceptions "with" us
private
- type Require_Body;
- -- Dummy Taft-amendment type to make it legal (and required) to provide
- -- a body for this package.
- --
- -- We do this because this unit used to have a body in earlier versions
- -- of GNAT, and it causes various bootstrap path problems etc if we remove
- -- a body, since we may pick up old unwanted bodies.
- --
- -- Note: we use this standard Ada method of requiring a body rather
- -- than the cleaner pragma No_Body because System.Exceptions is a compiler
- -- unit, and older bootstrap compilers do not support pragma No_Body. This
- -- type can be removed, and s-except.adb can be replaced by a source
- -- containing just that pragma, when we decide to move to a 2008 compiler
- -- as the minimal bootstrap compiler version. ???
-
- ZCX_By_Default : constant Boolean := System.ZCX_By_Default;
-
Foreign_Exception : exception;
pragma Unreferenced (Foreign_Exception);
-- This hidden exception is used to represent non-Ada exception to
diff --git a/gcc/ada/libgnat/s-excmac__arm.adb b/gcc/ada/libgnat/s-excmac__arm.adb
index faf53b7..8dc6974 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2013-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 65269ae..f69690d 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2013-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 ead0550..1b03a1b 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2013-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 f7148a3..ffb8ea3 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2013-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 ec5e0a7..48e3247 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1996-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 d0ead62..0d1774e 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1996-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 2ada43b..963f5f9 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-2020, AdaCore --
+-- Copyright (C) 2000-2021, 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 e3b360f..6be48fb 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-2020, AdaCore --
+-- Copyright (C) 2000-2021, 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-exnflt.ads b/gcc/ada/libgnat/s-exnflt.ads
new file mode 100644
index 0000000..13079fc
--- /dev/null
+++ b/gcc/ada/libgnat/s-exnflt.ads
@@ -0,0 +1,41 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- S Y S T E M . E X N _ F L T --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 2021, Free Software Foundation, Inc. --
+-- --
+-- GNAT is 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. --
+-- --
+------------------------------------------------------------------------------
+
+-- Float exponentiation (checks off)
+
+with System.Exponr;
+
+package System.Exn_Flt is
+
+ function Exn_Float is new Exponr (Float);
+ pragma Pure_Function (Exn_Float);
+
+end System.Exn_Flt;
diff --git a/gcc/ada/libgnat/s-exnint.adb b/gcc/ada/libgnat/s-exnint.adb
index 3914192..052dd1c 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 ac64e58..cfdf933 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-exnlfl.ads b/gcc/ada/libgnat/s-exnlfl.ads
new file mode 100644
index 0000000..58d4a4c
--- /dev/null
+++ b/gcc/ada/libgnat/s-exnlfl.ads
@@ -0,0 +1,41 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- S Y S T E M . E X N _ L F L T --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 2021, Free Software Foundation, Inc. --
+-- --
+-- GNAT is 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. --
+-- --
+------------------------------------------------------------------------------
+
+-- Long_Float exponentiation (checks off)
+
+with System.Exponr;
+
+package System.Exn_LFlt is
+
+ function Exn_Long_Float is new Exponr (Long_Float);
+ pragma Pure_Function (Exn_Long_Float);
+
+end System.Exn_LFlt;
diff --git a/gcc/ada/libgnat/s-exnllf.adb b/gcc/ada/libgnat/s-exnllf.adb
index 7ca2675..2186c6d 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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,154 +29,8 @@
-- --
------------------------------------------------------------------------------
--- Note: the reason for treating exponents in the range 0 .. 4 specially is
--- to ensure identical results to the static inline expansion in the case of
--- a compile time known exponent in this range. The use of Float'Machine and
--- Long_Float'Machine is to avoid unwanted extra precision in the results.
+-- This package does not require a body, since it is an instantiation. We
+-- provide a dummy file containing a No_Body pragma so that previous versions
+-- of the body (which did exist) will not interfere.
--- Note that for a negative exponent in Left ** Right, we compute the result
--- as:
-
--- 1.0 / (Left ** (-Right))
-
--- Note that the case of Left being zero is not special, it will simply result
--- in a division by zero at the end, yielding a correctly signed infinity, or
--- possibly generating an overflow.
-
--- Note on overflow: This coding assumes that the target generates infinities
--- with standard IEEE semantics. If this is not the case, then the code
--- for negative exponent may raise Constraint_Error. This follows the
--- implementation permission given in RM 4.5.6(12).
-
-package body System.Exn_LLF is
-
- subtype Negative is Integer range Integer'First .. -1;
-
- function Exp
- (Left : Long_Long_Float;
- Right : Natural) return Long_Long_Float;
- -- Common routine used if Right is greater or equal to 5
-
- ---------------
- -- Exn_Float --
- ---------------
-
- function Exn_Float
- (Left : Float;
- Right : Integer) return Float
- is
- Temp : Float;
- begin
- case Right is
- when 0 =>
- return 1.0;
- when 1 =>
- return Left;
- when 2 =>
- return Float'Machine (Left * Left);
- when 3 =>
- return Float'Machine (Left * Left * Left);
- when 4 =>
- Temp := Float'Machine (Left * Left);
- return Float'Machine (Temp * Temp);
- when Negative =>
- return Float'Machine (1.0 / Exn_Float (Left, -Right));
- when others =>
- return
- Float'Machine
- (Float (Exp (Long_Long_Float (Left), Right)));
- end case;
- end Exn_Float;
-
- --------------------
- -- Exn_Long_Float --
- --------------------
-
- function Exn_Long_Float
- (Left : Long_Float;
- Right : Integer) return Long_Float
- is
- Temp : Long_Float;
- begin
- case Right is
- when 0 =>
- return 1.0;
- when 1 =>
- return Left;
- when 2 =>
- return Long_Float'Machine (Left * Left);
- when 3 =>
- return Long_Float'Machine (Left * Left * Left);
- when 4 =>
- Temp := Long_Float'Machine (Left * Left);
- return Long_Float'Machine (Temp * Temp);
- when Negative =>
- return Long_Float'Machine (1.0 / Exn_Long_Float (Left, -Right));
- when others =>
- return
- Long_Float'Machine
- (Long_Float (Exp (Long_Long_Float (Left), Right)));
- end case;
- end Exn_Long_Float;
-
- -------------------------
- -- Exn_Long_Long_Float --
- -------------------------
-
- function Exn_Long_Long_Float
- (Left : Long_Long_Float;
- Right : Integer) return Long_Long_Float
- is
- Temp : Long_Long_Float;
- begin
- case Right is
- when 0 =>
- return 1.0;
- when 1 =>
- return Left;
- when 2 =>
- return Left * Left;
- when 3 =>
- return Left * Left * Left;
- when 4 =>
- Temp := Left * Left;
- return Temp * Temp;
- when Negative =>
- return 1.0 / Exn_Long_Long_Float (Left, -Right);
- when others =>
- return Exp (Left, Right);
- end case;
- end Exn_Long_Long_Float;
-
- ---------
- -- Exp --
- ---------
-
- function Exp
- (Left : Long_Long_Float;
- Right : Natural) return Long_Long_Float
- is
- Result : Long_Long_Float := 1.0;
- Factor : Long_Long_Float := Left;
- Exp : Natural := Right;
-
- begin
- -- We use the standard logarithmic approach, Exp gets shifted right
- -- testing successive low order bits and Factor is the value of the
- -- base raised to the next power of 2. If the low order bit or Exp is
- -- set, multiply the result by this factor.
-
- loop
- if Exp rem 2 /= 0 then
- Result := Result * Factor;
- end if;
-
- Exp := Exp / 2;
- exit when Exp = 0;
- Factor := Factor * Factor;
- end loop;
-
- return Result;
- end Exp;
-
-end System.Exn_LLF;
+pragma No_Body;
diff --git a/gcc/ada/libgnat/s-exnllf.ads b/gcc/ada/libgnat/s-exnllf.ads
index 6a334de..2b02a65 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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,21 +29,13 @@
-- --
------------------------------------------------------------------------------
--- [Long_[Long_]]Float exponentiation (checks off)
+-- Long_Long_Float exponentiation (checks off)
-package System.Exn_LLF is
- pragma Pure;
-
- function Exn_Float
- (Left : Float;
- Right : Integer) return Float;
+with System.Exponr;
- function Exn_Long_Float
- (Left : Long_Float;
- Right : Integer) return Long_Float;
+package System.Exn_LLF is
- function Exn_Long_Long_Float
- (Left : Long_Long_Float;
- Right : Integer) return Long_Long_Float;
+ function Exn_Long_Long_Float is new Exponr (Long_Long_Float);
+ pragma Pure_Function (Exn_Long_Long_Float);
end System.Exn_LLF;
diff --git a/gcc/ada/libgnat/s-exnlli.adb b/gcc/ada/libgnat/s-exnlli.adb
index b1c33ea..4fdcf89 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 3c2786b..4a54344 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-exnllli.ads b/gcc/ada/libgnat/s-exnllli.ads
index 9573d7d..06a9784 100644
--- a/gcc/ada/libgnat/s-exnllli.ads
+++ b/gcc/ada/libgnat/s-exnllli.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 489d768..b19a72f 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 70d16e0..f41b6fa 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 98946dc..ccfbec0 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 bf58a9a..d9c8544 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-expllli.ads b/gcc/ada/libgnat/s-expllli.ads
index 0e4375d..1ee278d 100644
--- a/gcc/ada/libgnat/s-expllli.ads
+++ b/gcc/ada/libgnat/s-expllli.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-explllu.ads b/gcc/ada/libgnat/s-explllu.ads
index 2f7c6a9..5a54ada 100644
--- a/gcc/ada/libgnat/s-explllu.ads
+++ b/gcc/ada/libgnat/s-explllu.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 3a383f7..0c46560 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 9e30090..9f7b404 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 1d6b404..d3465d9 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 925ae11..aa87efc 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-exponn.adb b/gcc/ada/libgnat/s-exponn.adb
index f1522d0..8a1cd78 100644
--- a/gcc/ada/libgnat/s-exponn.adb
+++ b/gcc/ada/libgnat/s-exponn.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-exponn.ads b/gcc/ada/libgnat/s-exponn.ads
index f4cd18f..c95b0ed 100644
--- a/gcc/ada/libgnat/s-exponn.ads
+++ b/gcc/ada/libgnat/s-exponn.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-exponr.adb b/gcc/ada/libgnat/s-exponr.adb
new file mode 100644
index 0000000..ad7f401
--- /dev/null
+++ b/gcc/ada/libgnat/s-exponr.adb
@@ -0,0 +1,125 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- S Y S T E M . E X P O N R --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 2021, Free Software Foundation, Inc. --
+-- --
+-- GNAT is 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. --
+-- --
+------------------------------------------------------------------------------
+
+-- Note that the reason for treating exponents in the range 0 .. 4 specially
+-- is to ensure identical results with the static expansion in the case of a
+-- compile-time known exponent in this range; similarly, the use 'Machine is
+-- to avoid unwanted extra precision in the results.
+
+-- For a negative exponent, we compute the result as per RM 4.5.6(11/3):
+
+-- Left ** Right = 1.0 / (Left ** (-Right))
+
+-- Note that the case of Left being zero is not special, it will simply result
+-- in a division by zero at the end, yielding a correctly signed infinity, or
+-- possibly raising an overflow exception.
+
+-- Note on overflow: this coding assumes that the target generates infinities
+-- with standard IEEE semantics. If this is not the case, then the code for
+-- negative exponents may raise Constraint_Error, which is in keeping with the
+-- implementation permission given in RM 4.5.6(12).
+
+with System.Double_Real;
+
+function System.Exponr (Left : Num; Right : Integer) return Num is
+
+ package Double_Real is new System.Double_Real (Num);
+ use type Double_Real.Double_T;
+
+ subtype Double_T is Double_Real.Double_T;
+ -- The double floating-point type
+
+ subtype Safe_Negative is Integer range Integer'First + 1 .. -1;
+ -- The range of safe negative exponents
+
+ function Expon (Left : Num; Right : Natural) return Num;
+ -- Routine used if Right is greater than 4
+
+ -----------
+ -- Expon --
+ -----------
+
+ function Expon (Left : Num; Right : Natural) return Num is
+ Result : Double_T := Double_Real.To_Double (1.0);
+ Factor : Double_T := Double_Real.To_Double (Left);
+ Exp : Natural := Right;
+
+ begin
+ -- We use the standard logarithmic approach, Exp gets shifted right
+ -- testing successive low order bits and Factor is the value of the
+ -- base raised to the next power of 2. If the low order bit or Exp
+ -- is set, multiply the result by this factor.
+
+ loop
+ if Exp rem 2 /= 0 then
+ Result := Result * Factor;
+ exit when Exp = 1;
+ end if;
+
+ Exp := Exp / 2;
+ Factor := Double_Real.Sqr (Factor);
+ end loop;
+
+ return Double_Real.To_Single (Result);
+ end Expon;
+
+begin
+ case Right is
+ when 0 =>
+ return 1.0;
+
+ when 1 =>
+ return Left;
+
+ when 2 =>
+ return Num'Machine (Left * Left);
+
+ when 3 =>
+ return Num'Machine (Left * Left * Left);
+
+ when 4 =>
+ declare
+ Sqr : constant Num := Num'Machine (Left * Left);
+
+ begin
+ return Num'Machine (Sqr * Sqr);
+ end;
+
+ when Safe_Negative =>
+ return Num'Machine (1.0 / Exponr (Left, -Right));
+
+ when Integer'First =>
+ return Num'Machine (1.0 / (Exponr (Left, Integer'Last) * Left));
+
+ when others =>
+ return Num'Machine (Expon (Left, Right));
+ end case;
+end System.Exponr;
diff --git a/gcc/ada/libgnat/a-stobbu.ads b/gcc/ada/libgnat/s-exponr.ads
index 027e711..e5bdec7 100644
--- a/gcc/ada/libgnat/a-stobbu.ads
+++ b/gcc/ada/libgnat/s-exponr.ads
@@ -2,11 +2,11 @@
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
--- ADA.STRINGS.TEXT_OUTPUT.BIT_BUCKETS --
+-- S Y S T E M . E X P O N R --
-- --
-- S p e c --
-- --
--- Copyright (C) 2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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,10 @@
-- --
------------------------------------------------------------------------------
-package Ada.Strings.Text_Output.Bit_Buckets is
- function Bit_Bucket return Sink_Access;
-end Ada.Strings.Text_Output.Bit_Buckets;
+-- Real exponentiation (checks off)
+
+generic
+
+ type Num is digits <>;
+
+function System.Exponr (Left : Num; Right : Integer) return Num;
diff --git a/gcc/ada/libgnat/s-expont.adb b/gcc/ada/libgnat/s-expont.adb
index bcdcae4..3c259cf 100644
--- a/gcc/ada/libgnat/s-expont.adb
+++ b/gcc/ada/libgnat/s-expont.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-expont.ads b/gcc/ada/libgnat/s-expont.ads
index 7a519fd..022cb64 100644
--- a/gcc/ada/libgnat/s-expont.ads
+++ b/gcc/ada/libgnat/s-expont.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-exponu.adb b/gcc/ada/libgnat/s-exponu.adb
index d2b9305..9525638 100644
--- a/gcc/ada/libgnat/s-exponu.adb
+++ b/gcc/ada/libgnat/s-exponu.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-exponu.ads b/gcc/ada/libgnat/s-exponu.ads
index 2a913d6..7faa122 100644
--- a/gcc/ada/libgnat/s-exponu.ads
+++ b/gcc/ada/libgnat/s-exponu.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 f513da2..6f943da 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 3826f4f..b49e7c0 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 615e5f4..079326b 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 9f25987..e591cca 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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,15 +35,12 @@
-- floating-point implementations.
with Ada.Unchecked_Conversion;
-with Interfaces;
with System.Unsigned_Types;
pragma Warnings (Off, "non-static constant in preelaborated unit");
-- Every constant is static given our instantiation model
package body System.Fat_Gen is
- use type Interfaces.Unsigned_64;
-
pragma Assert (T'Machine_Radix = 2);
-- This version does not handle radix 16
@@ -62,17 +59,6 @@ package body System.Fat_Gen is
-- Tiny : constant T := Rad ** (T'Machine_Emin - Mantissa);
-- Smallest positive denormalized number
- Tiny16 : constant Interfaces.Unsigned_16 := 1;
- Tiny32 : constant Interfaces.Unsigned_32 := 1;
- Tiny64 : constant Interfaces.Unsigned_64 := 1;
- Tiny80 : constant array (1 .. 2) of Interfaces.Unsigned_64 :=
- (1 * Standard'Default_Bit_Order,
- 2**48 * (1 - Standard'Default_Bit_Order));
- for Tiny80'Alignment use Standard'Maximum_Alignment;
- -- We cannot use the direct declaration because it cannot be translated
- -- into C90, as the hexadecimal floating constants were introduced in C99.
- -- So we work around this by using an overlay of the integer constant.
-
RM1 : constant T := Rad ** (Mantissa - 1);
-- Smallest positive member of the large consecutive integers. It is equal
-- to the ratio Small / Tiny, which means that multiplying by it normalizes
@@ -110,22 +96,23 @@ package body System.Fat_Gen is
-- component of Float_Rep, named Most Significant Word (MSW).
-- - The sign occupies the most significant bit of the MSW and the
- -- exponent is in the following bits. The exception is 80-bit
- -- double extended, where they occupy the low 16-bit halfword.
-
- -- The low-level primitives Copy_Sign, Decompose, Scaling and Valid are
- -- implemented by accessing the bit pattern of the floating-point number.
- -- Only the normalization of denormalized numbers, if any, and the gradual
- -- underflow are left to the hardware, mainly because there is some leeway
- -- for the hardware implementation in this area: for example, the MSB of
- -- the mantissa, which is 1 for normalized numbers and 0 for denormalized
+ -- exponent is in the following bits.
+
+ -- The low-level primitives Copy_Sign, Decompose, Finite_Succ, Scaling and
+ -- Valid are implemented by accessing the bit pattern of the floating-point
+ -- number. Only the normalization of denormalized numbers, if any, and the
+ -- gradual underflow are left to the hardware, mainly because there is some
+ -- leeway for the hardware implementation in this area: for example the MSB
+ -- of the mantissa, that is 1 for normalized numbers and 0 for denormalized
-- numbers, may or may not be stored by the hardware.
- Siz : constant := (if System.Word_Size > 32 then 32 else System.Word_Size);
+ Siz : constant := 16;
type Float_Word is mod 2**Siz;
+ -- We use the GCD of the size of all the supported floating-point formats
- N : constant Natural := (T'Size + Siz - 1) / Siz;
- Rep_Last : constant Natural := Natural'Min (N - 1, (Mantissa + 16) / Siz);
+ N : constant Natural := (T'Size + Siz - 1) / Siz;
+ NR : constant Natural := (Mantissa + 16 + Siz - 1) / Siz;
+ Rep_Last : constant Natural := Natural'Min (N, NR) - 1;
-- Determine the number of Float_Words needed for representing the
-- entire floating-point value. Do not take into account excessive
-- padding, as occurs on IA-64 where 80 bits floats get padded to 128
@@ -143,12 +130,9 @@ package body System.Fat_Gen is
-- we assume Word_Order = Bit_Order.
Exp_Factor : constant Float_Word :=
- (if Mantissa = 64
- then 1
- else 2**(Siz - 1) / Float_Word (IEEE_Emax - IEEE_Emin + 3));
+ 2**(Siz - 1) / Float_Word (IEEE_Emax - IEEE_Emin + 3);
-- Factor that the extracted exponent needs to be divided by to be in
- -- range 0 .. IEEE_Emax - IEEE_Emin + 2. The special case is 80-bit
- -- double extended, where the exponent starts the 3rd float word.
+ -- range 0 .. IEEE_Emax - IEEE_Emin + 2
Exp_Mask : constant Float_Word :=
Float_Word (IEEE_Emax - IEEE_Emin + 2) * Exp_Factor;
@@ -156,10 +140,8 @@ package body System.Fat_Gen is
-- range 0 .. IEEE_Emax - IEEE_Emin + 2 contains 2**N values, for some
-- N in Natural.
- Sign_Mask : constant Float_Word :=
- (if Mantissa = 64 then 2**15 else 2**(Siz - 1));
- -- Value needed to mask out the sign field. The special case is 80-bit
- -- double extended, where the exponent starts the 3rd float word.
+ Sign_Mask : constant Float_Word := 2**(Siz - 1);
+ -- Value needed to mask out the sign field
-----------------------
-- Local Subprograms --
@@ -171,6 +153,9 @@ package body System.Fat_Gen is
-- the sign of the exponent. The absolute value of Frac is in the range
-- 0.0 <= Frac < 1.0. If Frac = 0.0 or -0.0, then Expo is always zero.
+ function Finite_Succ (X : T) return T;
+ -- Return the successor of X, a finite number not equal to T'Last
+
--------------
-- Adjacent --
--------------
@@ -306,6 +291,179 @@ package body System.Fat_Gen is
return X_Exp;
end Exponent;
+ -----------------
+ -- Finite_Succ --
+ -----------------
+
+ function Finite_Succ (X : T) return T is
+ XX : T := T'Machine (X);
+
+ Rep : Float_Rep;
+ for Rep'Address use XX'Address;
+ -- Rep is a view of the input floating-point parameter
+
+ begin
+ -- If the floating-point type does not support denormalized numbers,
+ -- there is a couple of problematic values, namely -Small and Zero,
+ -- because the increment is equal to Small in these cases.
+
+ if not T'Denorm then
+ declare
+ Small : constant T := Rad ** (T'Machine_Emin - 1);
+ -- Smallest positive normalized number declared here and not at
+ -- library level for the sake of the CCG compiler, which cannot
+ -- currently compile the constant because the target is C90.
+
+ begin
+ if X = -Small then
+ XX := 0.0;
+ return -XX;
+ elsif X = 0.0 then
+ return Small;
+ end if;
+ end;
+ end if;
+
+ -- In all the other cases, the increment is equal to 1 in the binary
+ -- integer representation of the number if X is nonnegative and equal
+ -- to -1 if X is negative.
+
+ if XX >= 0.0 then
+ -- First clear the sign of negative Zero
+
+ Rep (MSW) := Rep (MSW) and not Sign_Mask;
+
+ -- Deal with big endian
+
+ if MSW = 0 then
+ for J in reverse 0 .. Rep_Last loop
+ Rep (J) := Rep (J) + 1;
+
+ -- For 80-bit IEEE Extended, the MSB of the mantissa is stored
+ -- so, when it has been flipped, its status must be reanalyzed.
+
+ if Mantissa = 64 and then J = 1 then
+
+ -- If the MSB changed from denormalized to normalized, then
+ -- keep it normalized since the exponent will be bumped.
+
+ if Rep (J) = 2**(Siz - 1) then
+ null;
+
+ -- If the MSB changed from normalized, restore it since we
+ -- cannot denormalize in this context.
+
+ elsif Rep (J) = 0 then
+ Rep (J) := 2**(Siz - 1);
+
+ else
+ exit;
+ end if;
+
+ -- In other cases, stop if there is no carry
+
+ else
+ exit when Rep (J) > 0;
+ end if;
+ end loop;
+
+ -- Deal with little endian
+
+ else
+ for J in 0 .. Rep_Last loop
+ Rep (J) := Rep (J) + 1;
+
+ -- For 80-bit IEEE Extended, the MSB of the mantissa is stored
+ -- so, when it has been flipped, its status must be reanalyzed.
+
+ if Mantissa = 64 and then J = Rep_Last - 1 then
+
+ -- If the MSB changed from denormalized to normalized, then
+ -- keep it normalized since the exponent will be bumped.
+
+ if Rep (J) = 2**(Siz - 1) then
+ null;
+
+ -- If the MSB changed from normalized, restore it since we
+ -- cannot denormalize in this context.
+
+ elsif Rep (J) = 0 then
+ Rep (J) := 2**(Siz - 1);
+
+ else
+ exit;
+ end if;
+
+ -- In other cases, stop if there is no carry
+
+ else
+ exit when Rep (J) > 0;
+ end if;
+ end loop;
+ end if;
+
+ else
+ if MSW = 0 then
+ for J in reverse 0 .. Rep_Last loop
+ Rep (J) := Rep (J) - 1;
+
+ -- For 80-bit IEEE Extended, the MSB of the mantissa is stored
+ -- so, when it has been flipped, its status must be reanalyzed.
+
+ if Mantissa = 64 and then J = 1 then
+
+ -- If the MSB changed from normalized to denormalized, then
+ -- keep it normalized if the exponent is not 1.
+
+ if Rep (J) = 2**(Siz - 1) - 1 then
+ if Rep (0) /= 2**(Siz - 1) + 1 then
+ Rep (J) := 2**Siz - 1;
+ end if;
+
+ else
+ exit;
+ end if;
+
+ -- In other cases, stop if there is no borrow
+
+ else
+ exit when Rep (J) < 2**Siz - 1;
+ end if;
+ end loop;
+
+ else
+ for J in 0 .. Rep_Last loop
+ Rep (J) := Rep (J) - 1;
+
+ -- For 80-bit IEEE Extended, the MSB of the mantissa is stored
+ -- so, when it has been flipped, its status must be reanalyzed.
+
+ if Mantissa = 64 and then J = Rep_Last - 1 then
+
+ -- If the MSB changed from normalized to denormalized, then
+ -- keep it normalized if the exponent is not 1.
+
+ if Rep (J) = 2**(Siz - 1) - 1 then
+ if Rep (Rep_Last) /= 2**(Siz - 1) + 1 then
+ Rep (J) := 2**Siz - 1;
+ end if;
+
+ else
+ exit;
+ end if;
+
+ -- In other cases, stop if there is no borrow
+
+ else
+ exit when Rep (J) < 2**Siz - 1;
+ end if;
+ end loop;
+ end if;
+ end if;
+
+ return XX;
+ end Finite_Succ;
+
-----------
-- Floor --
-----------
@@ -424,66 +582,27 @@ package body System.Fat_Gen is
----------
function Pred (X : T) return T is
- Tiny : constant T;
- pragma Import (Ada, Tiny);
- for Tiny'Address use (if T'Size = 16 then Tiny16'Address
- elsif T'Size = 32 then Tiny32'Address
- elsif T'Size = 64 then Tiny64'Address
- elsif Mantissa = 64 then Tiny80'Address
- else raise Program_Error);
- X_Frac : T;
- X_Exp : UI;
-
begin
- -- Zero has to be treated specially, since its exponent is zero
-
- if X = 0.0 then
- return -Tiny;
-
-- Special treatment for largest negative number: raise Constraint_Error
- elsif X = T'First then
+ if X = T'First then
raise Constraint_Error with "Pred of largest negative number";
- -- For infinities, return unchanged
+ -- For finite numbers, use the symmetry around zero of floating point
- elsif X < T'First or else X > T'Last then
+ elsif X > T'First and then X <= T'Last then
+ pragma Annotate (CodePeer, Intentional, "test always true",
+ "Check for invalid float");
pragma Annotate (CodePeer, Intentional, "condition predetermined",
"Check for invalid float");
- return X;
- pragma Annotate (CodePeer, Intentional, "dead code",
- "Check float range.");
+ return -Finite_Succ (-X);
- -- Subtract from the given number a number equivalent to the value
- -- of its least significant bit. Given that the most significant bit
- -- represents a value of 1.0 * Radix ** (Exp - 1), the value we want
- -- is obtained by shifting this by (Mantissa-1) bits to the right,
- -- i.e. decreasing the exponent by that amount.
+ -- For infinities and NaNs, return unchanged
else
- Decompose (X, X_Frac, X_Exp);
-
- -- For a denormalized number or a normalized number with the lowest
- -- exponent, just subtract the Tiny.
-
- if X_Exp <= T'Machine_Emin then
- return X - Tiny;
-
- -- A special case, if the number we had was a power of two on the
- -- positive side of zero, then we want to subtract half of what we
- -- would have subtracted, since the exponent is going to be reduced.
-
- -- Note that X_Frac has the same sign as X so, if X_Frac is Invrad,
- -- then we know that we had a power of two on the positive side.
-
- elsif X_Frac = Invrad then
- return X - Scaling (1.0, X_Exp - Mantissa - 1);
-
- -- Otherwise the adjustment is unchanged
-
- else
- return X - Scaling (1.0, X_Exp - Mantissa);
- end if;
+ return X;
+ pragma Annotate (CodePeer, Intentional, "dead code",
+ "Check float range.");
end if;
end Pred;
@@ -652,21 +771,26 @@ package body System.Fat_Gen is
-- Check for overflow
if Adjustment > IEEE_Emax - Exp then
- XX := 0.0;
- return (if Minus then -1.0 / XX else 1.0 / XX);
- pragma Annotate
- (CodePeer, Intentional, "overflow check", "Infinity produced");
- pragma Annotate
- (CodePeer, Intentional, "divide by zero", "Infinity produced");
+ -- Optionally raise Constraint_Error as per RM A.5.3(29)
+
+ if T'Machine_Overflows then
+ raise Constraint_Error with "Too large exponent";
+
+ else
+ XX := 0.0;
+ return (if Minus then -1.0 / XX else 1.0 / XX);
+ pragma Annotate (CodePeer, Intentional, "overflow check",
+ "Infinity produced");
+ pragma Annotate (CodePeer, Intentional, "divide by zero",
+ "Infinity produced");
+ end if;
-- Check for underflow
elsif Adjustment < IEEE_Emin - Exp then
- -- Check for gradual underflow
+ -- Check for possibly gradual underflow (up to the hardware)
- if T'Denorm
- and then Adjustment >= IEEE_Emin - (Mantissa - 1) - Exp
- then
+ if Adjustment >= IEEE_Emin - Mantissa - Exp then
Expf := IEEE_Emin;
Expi := Exp + Adjustment - Expf;
@@ -688,6 +812,16 @@ package body System.Fat_Gen is
Float_Word (IEEE_Ebias + Expf) * Exp_Factor;
if Expi < 0 then
+ -- Given that Expi >= -Mantissa, only -64 is problematic
+
+ if Expi = -64 then
+ pragma Annotate
+ (CodePeer, Intentional, "test always false",
+ "test always false in some instantiations");
+ XX := XX / 2.0;
+ Expi := -63;
+ end if;
+
XX := XX / T (UST.Long_Long_Unsigned (2) ** (-Expi));
end if;
@@ -700,66 +834,27 @@ package body System.Fat_Gen is
----------
function Succ (X : T) return T is
- Tiny : constant T;
- pragma Import (Ada, Tiny);
- for Tiny'Address use (if T'Size = 16 then Tiny16'Address
- elsif T'Size = 32 then Tiny32'Address
- elsif T'Size = 64 then Tiny64'Address
- elsif Mantissa = 64 then Tiny80'Address
- else raise Program_Error);
- X_Frac : T;
- X_Exp : UI;
-
begin
- -- Treat zero specially since it has a zero exponent
-
- if X = 0.0 then
- return Tiny;
-
-- Special treatment for largest positive number: raise Constraint_Error
- elsif X = T'Last then
+ if X = T'Last then
raise Constraint_Error with "Succ of largest positive number";
- -- For infinities, return unchanged
+ -- For finite numbers, call the specific routine
- elsif X < T'First or else X > T'Last then
+ elsif X >= T'First and then X < T'Last then
+ pragma Annotate (CodePeer, Intentional, "test always true",
+ "Check for invalid float");
pragma Annotate (CodePeer, Intentional, "condition predetermined",
"Check for invalid float");
- return X;
- pragma Annotate (CodePeer, Intentional, "dead code",
- "Check float range.");
+ return Finite_Succ (X);
- -- Add to the given number a number equivalent to the value of its
- -- least significant bit. Given that the most significant bit
- -- represents a value of 1.0 * Radix ** (Exp - 1), the value we want
- -- is obtained by shifting this by (Mantissa-1) bits to the right,
- -- i.e. decreasing the exponent by that amount.
+ -- For infinities and NaNs, return unchanged
else
- Decompose (X, X_Frac, X_Exp);
-
- -- For a denormalized number or a normalized number with the lowest
- -- exponent, just add the Tiny.
-
- if X_Exp <= T'Machine_Emin then
- return X + Tiny;
-
- -- A special case, if the number we had was a power of two on the
- -- negative side of zero, then we want to add half of what we would
- -- have added, since the exponent is going to be reduced.
-
- -- Note that X_Frac has the same sign as X, so if X_Frac is -Invrad,
- -- then we know that we had a power of two on the negative side.
-
- elsif X_Frac = -Invrad then
- return X + Scaling (1.0, X_Exp - Mantissa - 1);
-
- -- Otherwise the adjustment is unchanged
-
- else
- return X + Scaling (1.0, X_Exp - Mantissa);
- end if;
+ return X;
+ pragma Annotate (CodePeer, Intentional, "dead code",
+ "Check float range.");
end if;
end Succ;
@@ -879,7 +974,19 @@ package body System.Fat_Gen is
else pragma Assert (Exp = IEEE_Emin - 1);
-- This is a denormalized number, valid if T'Denorm is True or 0.0
- return T'Denorm or else X.all = 0.0;
+ if T'Denorm then
+ return True;
+
+ -- Note that we cannot do a direct comparison with 0.0 because the
+ -- hardware may evaluate it to True for all denormalized numbers.
+
+ else
+ -- First clear the sign bit (the exponent is already zero)
+
+ Rep (MSW) := Rep (MSW) and not Sign_Mask;
+
+ return (for all J in 0 .. Rep_Last => Rep (J) = 0);
+ end if;
end if;
end Valid;
diff --git a/gcc/ada/libgnat/s-fatgen.ads b/gcc/ada/libgnat/s-fatgen.ads
index 700cfdc..1b191e2 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 2be41118..08e0764 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 6361296..7aad47a 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 1532cdb..6fff2da 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 d969cec..30fa836 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2013-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 c574487..152cd96 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 de464d8..56bd3e6 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 3e9ae58..05029e1 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2015-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 eb30ea1..ea5a3fb 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2011-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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,7 @@ package System.Finalization_Masters is
for Finalization_Master_Ptr'Storage_Size use 0;
procedure Attach (N : not null FM_Node_Ptr; L : not null FM_Node_Ptr);
- -- Compiler interface, do not call from withing the run-time. Prepend a
+ -- Compiler interface, do not call from within the run-time. Prepend a
-- node to a specific finalization master.
procedure Attach_Unprotected
diff --git a/gcc/ada/libgnat/s-finroo.adb b/gcc/ada/libgnat/s-finroo.adb
index c56f8fa..591b474 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 c3b36c0..23393c5 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 9eabefc..008e629 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-2020, AdaCore --
+-- Copyright (C) 2011-2021, 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 a5617c0..0c66b78 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-2020, AdaCore --
+-- Copyright (C) 2000-2021, 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 1dc3132..baf4edd 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-2020, AdaCore --
+-- Copyright (C) 2011-2021, 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-fode128.ads b/gcc/ada/libgnat/s-fode128.ads
index 200a020..c5490cf 100644
--- a/gcc/ada/libgnat/s-fode128.ads
+++ b/gcc/ada/libgnat/s-fode128.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2020-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-fode32.ads b/gcc/ada/libgnat/s-fode32.ads
index 15c07a4..7e0d377 100644
--- a/gcc/ada/libgnat/s-fode32.ads
+++ b/gcc/ada/libgnat/s-fode32.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2020-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-fode64.ads b/gcc/ada/libgnat/s-fode64.ads
index 7e98185..826aa50 100644
--- a/gcc/ada/libgnat/s-fode64.ads
+++ b/gcc/ada/libgnat/s-fode64.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2020-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-fofi128.ads b/gcc/ada/libgnat/s-fofi128.ads
index aaa117f..cbb9b02 100644
--- a/gcc/ada/libgnat/s-fofi128.ads
+++ b/gcc/ada/libgnat/s-fofi128.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2020-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-fofi32.ads b/gcc/ada/libgnat/s-fofi32.ads
index cf94fb8..b5b2645 100644
--- a/gcc/ada/libgnat/s-fofi32.ads
+++ b/gcc/ada/libgnat/s-fofi32.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2020-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-fofi64.ads b/gcc/ada/libgnat/s-fofi64.ads
index cdde204..41acc77 100644
--- a/gcc/ada/libgnat/s-fofi64.ads
+++ b/gcc/ada/libgnat/s-fofi64.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2020-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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_d.adb b/gcc/ada/libgnat/s-fore_d.adb
index 1141c67..73f563f 100644
--- a/gcc/ada/libgnat/s-fore_d.adb
+++ b/gcc/ada/libgnat/s-fore_d.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2020-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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_d.ads b/gcc/ada/libgnat/s-fore_d.ads
index 25e3449..b930370 100644
--- a/gcc/ada/libgnat/s-fore_d.ads
+++ b/gcc/ada/libgnat/s-fore_d.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2020-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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_f.adb b/gcc/ada/libgnat/s-fore_f.adb
index c9c476d..109bffa 100644
--- a/gcc/ada/libgnat/s-fore_f.adb
+++ b/gcc/ada/libgnat/s-fore_f.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2020-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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_f.ads b/gcc/ada/libgnat/s-fore_f.ads
index cf6d983..52cf449 100644
--- a/gcc/ada/libgnat/s-fore_f.ads
+++ b/gcc/ada/libgnat/s-fore_f.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2020-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-forrea.adb b/gcc/ada/libgnat/s-forrea.adb
index cb74dc6..739ac92 100644
--- a/gcc/ada/libgnat/s-forrea.adb
+++ b/gcc/ada/libgnat/s-forrea.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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,12 +31,12 @@
package body System.Fore_Real is
- ---------------
- -- Fore_Real --
- ---------------
+ ----------------
+ -- Fore_Fixed --
+ ----------------
- function Fore_Real (Lo, Hi : Long_Long_Float) return Natural is
- T : Long_Long_Float := Long_Long_Float'Max (abs Lo, abs Hi);
+ function Fore_Fixed (Lo, Hi : Long_Float) return Natural is
+ T : Long_Float := Long_Float'Max (abs Lo, abs Hi);
F : Natural;
begin
@@ -52,6 +52,6 @@ package body System.Fore_Real is
end loop;
return F;
- end Fore_Real;
+ end Fore_Fixed;
end System.Fore_Real;
diff --git a/gcc/ada/libgnat/s-forrea.ads b/gcc/ada/libgnat/s-forrea.ads
index 6b0a211..73784c0 100644
--- a/gcc/ada/libgnat/s-forrea.ads
+++ b/gcc/ada/libgnat/s-forrea.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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 package contains the routine used for the Fore attribute of ordinary
--- fixed point types whose Small is neither an integer nor its reciprocal.
+-- This package contains the routine for the Fore attribute of ordinary fixed
+-- point types whose Small is not a ratio of two sufficiently small integers.
package System.Fore_Real is
pragma Pure;
- function Fore_Real (Lo, Hi : Long_Long_Float) return Natural;
+ function Fore_Fixed (Lo, Hi : Long_Float) return Natural;
-- Compute Fore attribute value for a fixed point type. The parameters
- -- are the low and high bounds, converted to Long_Long_Float.
+ -- are the low and high bounds, converted to Long_Float.
end System.Fore_Real;
diff --git a/gcc/ada/libgnat/s-gearop.adb b/gcc/ada/libgnat/s-gearop.adb
index 3eaeec2..957efd5 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2006-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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.ads b/gcc/ada/libgnat/s-gearop.ads
index 2ee455c..340cf96 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2006-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 bf222ac..8d03f0a 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2012-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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.ads b/gcc/ada/libgnat/s-genbig.ads
index be8340e..6fc1c10 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2012-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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.adb b/gcc/ada/libgnat/s-geveop.adb
index ff62a34..bfbb232 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2002-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 33f4e69..8ad85a5 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2002-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 9c859cf..201fc6f 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1999-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 e95884f..8c27fab 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1999-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 d8c180e..be92ba6 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-2020, AdaCore --
+-- Copyright (C) 1999-2021, 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 476f4aa..af2db2f 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-2020, AdaCore --
+-- Copyright (C) 1995-2021, 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 6313ab3..b3b3dfa 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-2020, AdaCore --
+-- Copyright (C) 1995-2021, 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-imageb.adb b/gcc/ada/libgnat/s-imageb.adb
index 72e8fb3..e8d367b 100644
--- a/gcc/ada/libgnat/s-imageb.adb
+++ b/gcc/ada/libgnat/s-imageb.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-imageb.ads b/gcc/ada/libgnat/s-imageb.ads
index 109f5c7..b739807 100644
--- a/gcc/ada/libgnat/s-imageb.ads
+++ b/gcc/ada/libgnat/s-imageb.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-imaged.adb b/gcc/ada/libgnat/s-imaged.adb
index 726b9d8..42c6423 100644
--- a/gcc/ada/libgnat/s-imaged.adb
+++ b/gcc/ada/libgnat/s-imaged.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2020-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-imaged.ads b/gcc/ada/libgnat/s-imaged.ads
index 5c3f82a..b53f96f 100644
--- a/gcc/ada/libgnat/s-imaged.ads
+++ b/gcc/ada/libgnat/s-imaged.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2020-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-imagef.adb b/gcc/ada/libgnat/s-imagef.adb
index 94a7a2f..e18fbf3 100644
--- a/gcc/ada/libgnat/s-imagef.adb
+++ b/gcc/ada/libgnat/s-imagef.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2020-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-imagef.ads b/gcc/ada/libgnat/s-imagef.ads
index ace7e6b..cac268a 100644
--- a/gcc/ada/libgnat/s-imagef.ads
+++ b/gcc/ada/libgnat/s-imagef.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2020-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -60,7 +60,7 @@ package System.Image_F is
-- For0 and Aft0 are the values of the Fore and Aft attributes for the
-- fixed point type whose mantissa type is Int and whose small is Num/Den.
-- This function is used only for fixed point whose Small is an integer or
- -- its reciprocal (see package System.Img_Real for the handling of other
+ -- its reciprocal (see package System.Image_R for the handling of other
-- ordinary fixed-point types). The caller guarantees that S is long enough
-- to hold the result and has a lower bound of 1.
diff --git a/gcc/ada/libgnat/s-imagei.adb b/gcc/ada/libgnat/s-imagei.adb
index 36c1f6f..a942eaf 100644
--- a/gcc/ada/libgnat/s-imagei.adb
+++ b/gcc/ada/libgnat/s-imagei.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-imagei.ads b/gcc/ada/libgnat/s-imagei.ads
index 2163af8..f80d92d 100644
--- a/gcc/ada/libgnat/s-imagei.ads
+++ b/gcc/ada/libgnat/s-imagei.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-imagen.adb b/gcc/ada/libgnat/s-imagen.adb
new file mode 100644
index 0000000..48c2e9f
--- /dev/null
+++ b/gcc/ada/libgnat/s-imagen.adb
@@ -0,0 +1,79 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- S Y S T E M . I M A G E _ N --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 2021, Free Software Foundation, Inc. --
+-- --
+-- GNAT is 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.Unchecked_Conversion;
+
+package body System.Image_N is
+
+ -----------------------
+ -- Image_Enumeration --
+ -----------------------
+
+ procedure Image_Enumeration
+ (Pos : Natural;
+ S : in out String;
+ P : out Natural;
+ Names : String;
+ Indexes : System.Address)
+ is
+ pragma Assert (S'First = 1);
+
+ subtype Names_Index is
+ Index_Type range Index_Type (Names'First)
+ .. Index_Type (Names'Last) + 1;
+ subtype Index is Natural range Natural'First .. Names'Length;
+ type Index_Table is array (Index) of Names_Index;
+ type Index_Table_Ptr is access Index_Table;
+
+ function To_Index_Table_Ptr is
+ new Ada.Unchecked_Conversion (System.Address, Index_Table_Ptr);
+
+ IndexesT : constant Index_Table_Ptr := To_Index_Table_Ptr (Indexes);
+
+ pragma Assert (Pos in IndexesT'Range);
+ pragma Assert (Pos + 1 in IndexesT'Range);
+
+ Start : constant Natural := Natural (IndexesT (Pos));
+ Next : constant Natural := Natural (IndexesT (Pos + 1));
+
+ pragma Assert (Next - 1 >= Start);
+ pragma Assert (Start >= Names'First);
+ pragma Assert (Next - 1 <= Names'Last);
+
+ pragma Assert (Next - Start <= S'Last);
+ -- The caller should guarantee that S is large enough to contain the
+ -- enumeration image.
+ begin
+ S (1 .. Next - Start) := Names (Start .. Next - 1);
+ P := Next - Start;
+ end Image_Enumeration;
+
+end System.Image_N;
diff --git a/gcc/ada/libgnat/s-imgenu.ads b/gcc/ada/libgnat/s-imagen.ads
index ccb1d07..6598be9 100644
--- a/gcc/ada/libgnat/s-imgenu.ads
+++ b/gcc/ada/libgnat/s-imagen.ads
@@ -2,11 +2,11 @@
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
--- S Y S T E M . I M G _ E N U M --
+-- S Y S T E M . I M A G E _ N --
-- --
-- S p e c --
-- --
--- Copyright (C) 2000-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -34,45 +34,30 @@
-- package System (where it is too early to start building image tables).
-- Special routines exist for the enumeration types in these packages.
--- Note: this is an obsolete package, replaced by System.Img_Enum_New, which
--- provides procedures instead of functions for these enumeration image calls.
--- The reason we maintain this package is that when bootstrapping with old
--- compilers, the old compiler will search for this unit, expecting to find
--- these functions. The new compiler will search for procedures in the new
--- version of the unit.
+generic
-pragma Compiler_Unit_Warning;
+ type Index_Type is range <>;
-package System.Img_Enum is
+package System.Image_N is
pragma Pure;
- function Image_Enumeration_8
+ procedure Image_Enumeration
(Pos : Natural;
+ S : in out String;
+ P : out Natural;
Names : String;
- Indexes : System.Address) return String;
+ Indexes : System.Address);
-- Used to compute Enum'Image (Str) where Enum is some enumeration type
- -- other than those defined in package Standard. Names is a string with a
- -- lower bound of 1 containing the characters of all the enumeration
- -- literals concatenated together in sequence. Indexes is the address of an
- -- array of type array (0 .. N) of Natural_8, where N is the number of
+ -- other than those defined in package Standard. Names is a string with
+ -- a lower bound of 1 containing the characters of all the enumeration
+ -- literals concatenated together in sequence. Indexes is the address of
+ -- an array of type array (0 .. N) of Index_Type, where N is the number of
-- enumeration literals in the type. The Indexes values are the starting
-- subscript of each enumeration literal, indexed by Pos values, with an
-- extra entry at the end containing Names'Length + 1. The reason that
-- Indexes is passed by address is that the actual type is created on the
- -- fly by the expander. The value returned is the desired 'Image value.
+ -- fly by the expander. The desired 'Image value is stored in S (1 .. P)
+ -- and P is set on return. The caller guarantees that S is long enough to
+ -- hold the result and that the lower bound is 1.
- function Image_Enumeration_16
- (Pos : Natural;
- Names : String;
- Indexes : System.Address) return String;
- -- Identical to Image_Enumeration_8 except that it handles types
- -- using array (0 .. Num) of Natural_16 for the Indexes table.
-
- function Image_Enumeration_32
- (Pos : Natural;
- Names : String;
- Indexes : System.Address) return String;
- -- Identical to Image_Enumeration_8 except that it handles types
- -- using array (0 .. Num) of Natural_32 for the Indexes table.
-
-end System.Img_Enum;
+end System.Image_N;
diff --git a/gcc/ada/libgnat/s-imager.adb b/gcc/ada/libgnat/s-imager.adb
new file mode 100644
index 0000000..882bb27
--- /dev/null
+++ b/gcc/ada/libgnat/s-imager.adb
@@ -0,0 +1,464 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- S Y S T E M . I M A G E _ R --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
+-- --
+-- GNAT is 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.Double_Real;
+with System.Float_Control;
+with System.Img_Util; use System.Img_Util;
+
+package body System.Image_R is
+
+ -- The following defines the maximum number of digits that we can convert
+ -- accurately. This is limited by the precision of the Num type, and also
+ -- by the number of digits that can be held in the Uns type, which is the
+ -- integer type we use as an intermediate in the computation. But, in both
+ -- cases, we can work with a double value in these types.
+
+ -- Note that in the following, the "-2" accounts for the space and one
+ -- extra digit, since we need the maximum number of 9's that can be
+ -- represented, e.g. for the 64-bit case, Long_Long_Unsigned'Width is
+ -- 21, since the maximum value (approx 1.8E+19) has 20 digits, but the
+ -- maximum number of 9's that can be represented is only 19.
+
+ Maxdigs : constant Natural := 2 * Natural'Min (Uns'Width - 2, Num'Digits);
+
+ Maxscaling : constant := 5000;
+ -- Max decimal scaling required during conversion of floating-point
+ -- numbers to decimal. This is used to defend against infinite
+ -- looping in the conversion, as can be caused by erroneous executions.
+ -- The largest exponent used on any current system is 2**16383, which
+ -- is approximately 10**4932, and the highest number of decimal digits
+ -- is about 35 for 128-bit floating-point formats, so 5000 leaves
+ -- enough room for scaling such values
+
+ package Double_Real is new System.Double_Real (Num);
+ use type Double_Real.Double_T;
+
+ subtype Double_T is Double_Real.Double_T;
+ -- The double floating-point type
+
+ function From_Unsigned is new Double_Real.From_Unsigned (Uns);
+ function To_Unsigned is new Double_Real.To_Unsigned (Uns);
+ -- Convert betwwen a double Num and a single Uns
+
+ function Is_Negative (V : Num) return Boolean;
+ -- Return True if V is negative for the purpose of the output, i.e. return
+ -- True for negative zeros only if Signed_Zeros is True.
+
+ -----------------------
+ -- Image_Fixed_Point --
+ -----------------------
+
+ procedure Image_Fixed_Point
+ (V : Num;
+ S : in out String;
+ P : out Natural;
+ Aft : Natural)
+ is
+ pragma Assert (S'First = 1);
+
+ begin
+ -- Output space at start if non-negative
+
+ if V >= 0.0 then
+ S (1) := ' ';
+ P := 1;
+ else
+ P := 0;
+ end if;
+
+ Set_Image_Real (V, S, P, 1, Aft, 0);
+ end Image_Fixed_Point;
+
+ --------------------------
+ -- Image_Floating_Point --
+ --------------------------
+
+ procedure Image_Floating_Point
+ (V : Num;
+ S : in out String;
+ P : out Natural;
+ Digs : Natural)
+ is
+ pragma Assert (S'First = 1);
+
+ begin
+ -- Decide whether a blank should be prepended before the call to
+ -- Set_Image_Real. We generate a blank for positive values, and
+ -- also for positive zeros. For negative zeros, we generate a
+ -- blank only if Signed_Zeros is False (the RM only permits the
+ -- output of -0.0 when Signed_Zeros is True). We do not generate
+ -- a blank for positive infinity, since we output an explicit +.
+
+ if not Is_Negative (V) and then V <= Num'Last then
+ pragma Annotate (CodePeer, False_Positive, "condition predetermined",
+ "CodePeer analysis ignores NaN and Inf values");
+ pragma Assert (S'Last > 1);
+ -- The caller is responsible for S to be large enough for all
+ -- Image_Floating_Point operation.
+ S (1) := ' ';
+ P := 1;
+ else
+ P := 0;
+ end if;
+
+ Set_Image_Real (V, S, P, 1, Digs - 1, 3);
+ end Image_Floating_Point;
+
+ -----------------
+ -- Is_Negative --
+ -----------------
+
+ function Is_Negative (V : Num) return Boolean is
+ begin
+ if V < 0.0 then
+ return True;
+
+ elsif V > 0.0 then
+ return False;
+
+ elsif not Num'Signed_Zeros then
+ return False;
+
+ else
+ return Num'Copy_Sign (1.0, V) < 0.0;
+ end if;
+ end Is_Negative;
+
+ --------------------
+ -- Set_Image_Real --
+ --------------------
+
+ procedure Set_Image_Real
+ (V : Num;
+ S : in out String;
+ P : in out Natural;
+ Fore : Natural;
+ Aft : Natural;
+ Exp : Natural)
+ is
+ Powten : constant array (0 .. Maxpow) of Double_T;
+ pragma Import (Ada, Powten);
+ for Powten'Address use Powten_Address;
+
+ NFrac : constant Natural := Natural'Max (Aft, 1);
+ -- Number of digits after the decimal point
+
+ Digs : String (1 .. 3 + Maxdigs);
+ -- Array used to hold digits of converted integer value
+
+ Ndigs : Natural;
+ -- Number of digits stored in Digs (and also subscript of last digit)
+
+ Scale : Integer := 0;
+ -- Exponent such that the result is Digs (1 .. NDigs) * 10**(-Scale)
+
+ X : Double_T;
+ -- Current absolute value of the input after scaling
+
+ procedure Adjust_Scale (S : Natural);
+ -- Adjusts the value in X by multiplying or dividing by a power of
+ -- ten so that it is in the range 10**(S-1) <= X < 10**S. Scale is
+ -- adjusted to reflect the power of ten used to divide the result,
+ -- i.e. one is added to the scale value for each multiplication by
+ -- 10.0 and one is subtracted for each division by 10.0.
+
+ ------------------
+ -- Adjust_Scale --
+ ------------------
+
+ procedure Adjust_Scale (S : Natural) is
+ Lo, Mid, Hi : Natural;
+ XP : Double_T;
+
+ begin
+ -- Cases where scaling up is required
+
+ if X < Powten (S - 1) then
+
+ -- What we are looking for is a power of ten to multiply X by
+ -- so that the result lies within the required range.
+
+ loop
+ XP := X * Powten (Maxpow);
+ exit when XP >= Powten (S - 1) or else Scale > Maxscaling;
+ X := XP;
+ Scale := Scale + Maxpow;
+ end loop;
+
+ -- The following exception is only raised in case of erroneous
+ -- execution, where a number was considered valid but still
+ -- fails to scale up. One situation where this can happen is
+ -- when a system which is supposed to be IEEE-compliant, but
+ -- has been reconfigured to flush denormals to zero.
+
+ if Scale > Maxscaling then
+ raise Constraint_Error;
+ end if;
+
+ -- Here we know that we must multiply by at least 10**1 and that
+ -- 10**Maxpow takes us too far: binary search to find right one.
+
+ -- Because of roundoff errors, it is possible for the value
+ -- of XP to be just outside of the interval when Lo >= Hi. In
+ -- that case we adjust explicitly by a factor of 10. This
+ -- can only happen with a value that is very close to an
+ -- exact power of 10.
+
+ Lo := 1;
+ Hi := Maxpow;
+
+ loop
+ Mid := (Lo + Hi) / 2;
+ XP := X * Powten (Mid);
+
+ if XP < Powten (S - 1) then
+
+ if Lo >= Hi then
+ Mid := Mid + 1;
+ XP := XP * 10.0;
+ exit;
+
+ else
+ Lo := Mid + 1;
+ end if;
+
+ elsif XP >= Powten (S) then
+
+ if Lo >= Hi then
+ Mid := Mid - 1;
+ XP := XP / 10.0;
+ exit;
+
+ else
+ Hi := Mid - 1;
+ end if;
+
+ else
+ exit;
+ end if;
+ end loop;
+
+ X := XP;
+ Scale := Scale + Mid;
+
+ -- Cases where scaling down is required
+
+ elsif X >= Powten (S) then
+
+ -- What we are looking for is a power of ten to divide X by
+ -- so that the result lies within the required range.
+
+ loop
+ XP := X / Powten (Maxpow);
+ exit when XP < Powten (S) or else Scale < -Maxscaling;
+ X := XP;
+ Scale := Scale - Maxpow;
+ end loop;
+
+ -- The following exception is only raised in case of erroneous
+ -- execution, where a number was considered valid but still
+ -- fails to scale up. One situation where this can happen is
+ -- when a system which is supposed to be IEEE-compliant, but
+ -- has been reconfigured to flush denormals to zero.
+
+ if Scale < -Maxscaling then
+ raise Constraint_Error;
+ end if;
+
+ -- Here we know that we must divide by at least 10**1 and that
+ -- 10**Maxpow takes us too far, binary search to find right one.
+
+ Lo := 1;
+ Hi := Maxpow;
+
+ loop
+ Mid := (Lo + Hi) / 2;
+ XP := X / Powten (Mid);
+
+ if XP < Powten (S - 1) then
+
+ if Lo >= Hi then
+ XP := XP * 10.0;
+ Mid := Mid - 1;
+ exit;
+
+ else
+ Hi := Mid - 1;
+ end if;
+
+ elsif XP >= Powten (S) then
+
+ if Lo >= Hi then
+ XP := XP / 10.0;
+ Mid := Mid + 1;
+ exit;
+
+ else
+ Lo := Mid + 1;
+ end if;
+
+ else
+ exit;
+ end if;
+ end loop;
+
+ X := XP;
+ Scale := Scale - Mid;
+
+ -- Here we are already scaled right
+
+ else
+ null;
+ end if;
+ end Adjust_Scale;
+
+ -- Start of processing for Set_Image_Real
+
+ begin
+ -- We call the floating-point processor reset routine so we can be sure
+ -- that the processor is properly set for conversions. This is notably
+ -- needed on Windows, where calls to the operating system randomly reset
+ -- the processor into 64-bit mode.
+
+ if Num'Machine_Mantissa = 64 then
+ System.Float_Control.Reset;
+ end if;
+
+ -- Deal with invalid values first
+
+ if not V'Valid then
+
+ -- Note that we're taking our chances here, as V might be
+ -- an invalid bit pattern resulting from erroneous execution
+ -- (caused by using uninitialized variables for example).
+
+ -- No matter what, we'll at least get reasonable behavior,
+ -- converting to infinity or some other value, or causing an
+ -- exception to be raised is fine.
+
+ -- If the following two tests succeed, then we definitely have
+ -- an infinite value, so we print +Inf or -Inf.
+
+ if V > Num'Last then
+ pragma Annotate (CodePeer, False_Positive, "dead code",
+ "CodePeer analysis ignores NaN and Inf values");
+ pragma Annotate (CodePeer, False_Positive, "test always true",
+ "CodePeer analysis ignores NaN and Inf values");
+
+ Set_Floating_Invalid_Value (Infinity, S, P, Fore, Aft, Exp);
+
+ elsif V < Num'First then
+ Set_Floating_Invalid_Value (Minus_Infinity, S, P, Fore, Aft, Exp);
+
+ -- In all other cases we print NaN
+
+ else
+ Set_Floating_Invalid_Value (Not_A_Number, S, P, Fore, Aft, Exp);
+ end if;
+
+ return;
+ end if;
+
+ -- Set the first character like Image
+
+ Digs (1) := (if Is_Negative (V) then '-' else ' ');
+ Ndigs := 1;
+
+ X := Double_Real.To_Double (abs (V));
+
+ -- If X is zero, we are done
+
+ if X = 0.0 then
+ Digs (2) := '0';
+ Ndigs := 2;
+
+ -- Otherwise, scale X and convert it to an integer
+
+ else
+ -- In exponent notation, we need exactly NFrac + 1 digits and always
+ -- round the last one.
+
+ if Exp > 0 then
+ Adjust_Scale (Natural'Min (NFrac + 1, Maxdigs));
+ X := X + 0.5;
+
+ -- In straight notation, we compute the maximum number of digits and
+ -- compare how many of them will be put after the decimal point with
+ -- Nfrac, in order to find out whether we need to round the last one
+ -- here or whether the rounding is performed by Set_Decimal_Digits.
+
+ else
+ Adjust_Scale (Maxdigs);
+ if Scale <= NFrac then
+ X := X + 0.5;
+ end if;
+ end if;
+
+ -- If X fits in an Uns, do the conversion directly. Note that this is
+ -- always the case for the Image attribute.
+
+ if X <= Num (Uns'Last) then
+ Set_Image_Unsigned (To_Unsigned (X), Digs, Ndigs);
+
+ -- Otherwise, do the conversion in two steps
+
+ else pragma Assert (X <= 10.0 ** Num'Digits * Num (Uns'Last));
+ declare
+ Y : constant Uns := To_Unsigned (X / Powten (Num'Digits));
+
+ Buf : String (1 .. Num'Digits);
+ Len : Natural;
+
+ begin
+ Set_Image_Unsigned (Y, Digs, Ndigs);
+
+ X := X - From_Unsigned (Y) * Powten (Num'Digits);
+
+ Len := 0;
+ Set_Image_Unsigned (To_Unsigned (X), Buf, Len);
+
+ for J in 1 .. Num'Digits - Len loop
+ Digs (Ndigs + J) := '0';
+ end loop;
+
+ for J in 1 .. Len loop
+ Digs (Ndigs + Num'Digits - Len + J) := Buf (J);
+ end loop;
+
+ Ndigs := Ndigs + Num'Digits;
+ end;
+ end if;
+ end if;
+
+ Set_Decimal_Digits (Digs, Ndigs, S, P, Scale, Fore, Aft, Exp);
+ end Set_Image_Real;
+
+end System.Image_R;
diff --git a/gcc/ada/libgnat/s-imager.ads b/gcc/ada/libgnat/s-imager.ads
new file mode 100644
index 0000000..1aa8687
--- /dev/null
+++ b/gcc/ada/libgnat/s-imager.ads
@@ -0,0 +1,92 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- S Y S T E M . I M A G E _ R --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
+-- --
+-- GNAT is 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 routines for the Image attribute of real types, and
+-- is also for Float_IO/Fixed_IO output.
+
+generic
+
+ type Num is digits <>;
+
+ Maxpow : Positive;
+
+ Powten_Address : System.Address;
+
+ type Uns is mod <>;
+
+ with procedure Set_Image_Unsigned
+ (V : Uns;
+ S : in out String;
+ P : in out Natural);
+
+package System.Image_R is
+ pragma Pure;
+
+ procedure Image_Fixed_Point
+ (V : Num;
+ S : in out String;
+ P : out Natural;
+ Aft : Natural);
+ -- Computes fixed_type'Image (V) and returns the result in S (1 .. P)
+ -- updating P on return. The result is computed according to the rules for
+ -- image for fixed-point types (RM 3.5(34)), where Aft is the value of the
+ -- Aft attribute for the fixed-point type. The caller guarantees that S is
+ -- long enough to hold the result and has a lower bound of 1.
+ --
+ -- Note: this procedure should NOT be called with V = -0.0 or V = +/-Inf.
+
+ procedure Image_Floating_Point
+ (V : Num;
+ S : in out String;
+ P : out Natural;
+ Digs : Natural);
+ -- Computes Uns'Image (V) and returns the result in S (1 .. P) updating P
+ -- on return. The result is computed according to the rules for image for
+ -- floating-point types (RM 3.5(33)), where Digs is the value of the Digits
+ -- attribute for the floating-point type. The caller guarantees that S is
+ -- long enough to hold the result and has a lower bound of 1.
+
+ procedure Set_Image_Real
+ (V : Num;
+ S : in out String;
+ P : in out Natural;
+ Fore : Natural;
+ Aft : Natural;
+ Exp : Natural);
+ -- Sets the image of V starting at S (P + 1), updating P to point to the
+ -- last character stored, the caller promises that the buffer is large
+ -- enough and no check is made for this. Constraint_Error will not
+ -- necessarily be raised if this is violated, since it is perfectly valid
+ -- to compile this unit with checks off). The Fore, Aft and Exp values
+ -- 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.
+
+end System.Image_R;
diff --git a/gcc/ada/libgnat/s-imageu.adb b/gcc/ada/libgnat/s-imageu.adb
index 8ffb8f0..fa3ac80 100644
--- a/gcc/ada/libgnat/s-imageu.adb
+++ b/gcc/ada/libgnat/s-imageu.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-imageu.ads b/gcc/ada/libgnat/s-imageu.ads
index 39e738a..4dcd6bc 100644
--- a/gcc/ada/libgnat/s-imageu.ads
+++ b/gcc/ada/libgnat/s-imageu.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-imagew.adb b/gcc/ada/libgnat/s-imagew.adb
index dd3b96e..a76a4dc 100644
--- a/gcc/ada/libgnat/s-imagew.adb
+++ b/gcc/ada/libgnat/s-imagew.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-imagew.ads b/gcc/ada/libgnat/s-imagew.ads
index 14c0c60..edf2ec3 100644
--- a/gcc/ada/libgnat/s-imagew.ads
+++ b/gcc/ada/libgnat/s-imagew.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-imde128.ads b/gcc/ada/libgnat/s-imde128.ads
index cffd0c0..1812325 100644
--- a/gcc/ada/libgnat/s-imde128.ads
+++ b/gcc/ada/libgnat/s-imde128.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2020-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-imde32.ads b/gcc/ada/libgnat/s-imde32.ads
index bf19e9c..f2583cc 100644
--- a/gcc/ada/libgnat/s-imde32.ads
+++ b/gcc/ada/libgnat/s-imde32.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2020-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-imde64.ads b/gcc/ada/libgnat/s-imde64.ads
index dfc8403..e603c5d 100644
--- a/gcc/ada/libgnat/s-imde64.ads
+++ b/gcc/ada/libgnat/s-imde64.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2020-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-imen16.ads b/gcc/ada/libgnat/s-imen16.ads
new file mode 100644
index 0000000..755549e
--- /dev/null
+++ b/gcc/ada/libgnat/s-imen16.ads
@@ -0,0 +1,51 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- S Y S T E M . I M G _ E N U M _ 1 6 --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 2021, Free Software Foundation, Inc. --
+-- --
+-- GNAT is 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. --
+-- --
+------------------------------------------------------------------------------
+
+-- Instantiation of System.Image_N for enumeration types whose names table
+-- has a length that fits in a 16-bit but not a 8-bit integer.
+
+with Interfaces;
+with System.Image_N;
+
+package System.Img_Enum_16 is
+ pragma Pure;
+
+ package Impl is new Image_N (Interfaces.Integer_16);
+
+ procedure Image_Enumeration_16
+ (Pos : Natural;
+ S : in out String;
+ P : out Natural;
+ Names : String;
+ Indexes : System.Address)
+ renames Impl.Image_Enumeration;
+
+end System.Img_Enum_16;
diff --git a/gcc/ada/libgnat/s-imen32.ads b/gcc/ada/libgnat/s-imen32.ads
new file mode 100644
index 0000000..3cb88d8
--- /dev/null
+++ b/gcc/ada/libgnat/s-imen32.ads
@@ -0,0 +1,51 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- S Y S T E M . I M G _ E N U M _ 3 2 --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 2021, Free Software Foundation, Inc. --
+-- --
+-- GNAT is 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. --
+-- --
+------------------------------------------------------------------------------
+
+-- Instantiation of System.Image_N for enumeration types whose names table
+-- has a length that fits in a 32-bit but not a 16-bit integer.
+
+with Interfaces;
+with System.Image_N;
+
+package System.Img_Enum_32 is
+ pragma Pure;
+
+ package Impl is new Image_N (Interfaces.Integer_32);
+
+ procedure Image_Enumeration_32
+ (Pos : Natural;
+ S : in out String;
+ P : out Natural;
+ Names : String;
+ Indexes : System.Address)
+ renames Impl.Image_Enumeration;
+
+end System.Img_Enum_32;
diff --git a/gcc/ada/libgnat/s-imenne.adb b/gcc/ada/libgnat/s-imenne.adb
index 3052ea2..4ca7a12 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2000-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 e150891..eba31c2 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2000-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -34,11 +34,11 @@
-- package System (where it is too early to start building image tables).
-- Special routines exist for the enumeration types in these packages.
--- This is the new version of the package, for use by compilers built after
--- Nov 21st, 2007, which provides procedures that avoid using the secondary
--- stack. The original package System.Img_Enum is maintained in the sources
--- for bootstrapping with older versions of the compiler which expect to find
--- functions in this package.
+-- Note: this is an obsolete package replaced by instantiations of the generic
+-- package System.Image_N. The reason we maintain this package is that when
+-- bootstrapping with an old compiler, the old compiler will search for this
+-- unit, expecting to find these functions. The new compiler will search for
+-- procedures in the instances of System.Image_N instead.
pragma Compiler_Unit_Warning;
diff --git a/gcc/ada/libgnat/s-imenu8.ads b/gcc/ada/libgnat/s-imenu8.ads
new file mode 100644
index 0000000..8c5a64d
--- /dev/null
+++ b/gcc/ada/libgnat/s-imenu8.ads
@@ -0,0 +1,51 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- S Y S T E M . I M G _ E N U M _ 8 --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 2021, Free Software Foundation, Inc. --
+-- --
+-- GNAT is 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. --
+-- --
+------------------------------------------------------------------------------
+
+-- Instantiation of System.Image_N for enumeration types whose names table
+-- has a length that fits in a 8-bit integer.
+
+with Interfaces;
+with System.Image_N;
+
+package System.Img_Enum_8 is
+ pragma Pure;
+
+ package Impl is new Image_N (Interfaces.Integer_8);
+
+ procedure Image_Enumeration_8
+ (Pos : Natural;
+ S : in out String;
+ P : out Natural;
+ Names : String;
+ Indexes : System.Address)
+ renames Impl.Image_Enumeration;
+
+end System.Img_Enum_8;
diff --git a/gcc/ada/libgnat/s-imfi128.ads b/gcc/ada/libgnat/s-imfi128.ads
index 24fdf97..ab988fa 100644
--- a/gcc/ada/libgnat/s-imfi128.ads
+++ b/gcc/ada/libgnat/s-imfi128.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2020-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-imfi32.ads b/gcc/ada/libgnat/s-imfi32.ads
index 8c425df..98b8e8c 100644
--- a/gcc/ada/libgnat/s-imfi32.ads
+++ b/gcc/ada/libgnat/s-imfi32.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2020-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-imfi64.ads b/gcc/ada/libgnat/s-imfi64.ads
index 9045bf6..ba83a50 100644
--- a/gcc/ada/libgnat/s-imfi64.ads
+++ b/gcc/ada/libgnat/s-imfi64.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2020-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 fbbbcec..ea8feb9 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 9cf24ae..09171c3 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 35ae001..69ee639 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 1bf8449..45b3bfa 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 06048eb..bfcae49 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 5c9ead8..6cd954d 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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
deleted file mode 100644
index 7eae182..0000000
--- a/gcc/ada/libgnat/s-imgenu.adb
+++ /dev/null
@@ -1,128 +0,0 @@
-------------------------------------------------------------------------------
--- --
--- GNAT RUN-TIME COMPONENTS --
--- --
--- S Y S T E M . I M G _ E N U M --
--- --
--- B o d y --
--- --
--- 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- --
--- 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 Compiler_Unit_Warning;
-
-with Ada.Unchecked_Conversion;
-
-package body System.Img_Enum is
-
- -------------------------
- -- Image_Enumeration_8 --
- -------------------------
-
- function Image_Enumeration_8
- (Pos : Natural;
- Names : String;
- Indexes : System.Address)
- return String
- is
- type Natural_8 is range 0 .. 2 ** 7 - 1;
- type Index_Table is array (Natural) of Natural_8;
- type Index_Table_Ptr is access Index_Table;
-
- function To_Index_Table_Ptr is
- new Ada.Unchecked_Conversion (System.Address, Index_Table_Ptr);
-
- IndexesT : constant Index_Table_Ptr := To_Index_Table_Ptr (Indexes);
-
- Start : constant Natural := Natural (IndexesT (Pos));
- Next : constant Natural := Natural (IndexesT (Pos + 1));
-
- subtype Result_Type is String (1 .. Next - Start);
- -- We need this result type to force the result to have the
- -- required lower bound of 1, rather than the slice bounds.
-
- begin
- return Result_Type (Names (Start .. Next - 1));
- end Image_Enumeration_8;
-
- --------------------------
- -- Image_Enumeration_16 --
- --------------------------
-
- function Image_Enumeration_16
- (Pos : Natural;
- Names : String;
- Indexes : System.Address)
- return String
- is
- type Natural_16 is range 0 .. 2 ** 15 - 1;
- type Index_Table is array (Natural) of Natural_16;
- type Index_Table_Ptr is access Index_Table;
-
- function To_Index_Table_Ptr is
- new Ada.Unchecked_Conversion (System.Address, Index_Table_Ptr);
-
- IndexesT : constant Index_Table_Ptr := To_Index_Table_Ptr (Indexes);
-
- Start : constant Natural := Natural (IndexesT (Pos));
- Next : constant Natural := Natural (IndexesT (Pos + 1));
-
- subtype Result_Type is String (1 .. Next - Start);
- -- We need this result type to force the result to have the
- -- required lower bound of 1, rather than the slice bounds.
-
- begin
- return Result_Type (Names (Start .. Next - 1));
- end Image_Enumeration_16;
-
- --------------------------
- -- Image_Enumeration_32 --
- --------------------------
-
- function Image_Enumeration_32
- (Pos : Natural;
- Names : String;
- Indexes : System.Address)
- return String
- is
- type Natural_32 is range 0 .. 2 ** 31 - 1;
- type Index_Table is array (Natural) of Natural_32;
- type Index_Table_Ptr is access Index_Table;
-
- function To_Index_Table_Ptr is
- new Ada.Unchecked_Conversion (System.Address, Index_Table_Ptr);
-
- IndexesT : constant Index_Table_Ptr := To_Index_Table_Ptr (Indexes);
-
- Start : constant Natural := Natural (IndexesT (Pos));
- Next : constant Natural := Natural (IndexesT (Pos + 1));
-
- subtype Result_Type is String (1 .. Next - Start);
- -- We need this result type to force the result to have the
- -- required lower bound of 1, rather than the slice bounds.
-
- begin
- return Result_Type (Names (Start .. Next - 1));
- end Image_Enumeration_32;
-
-end System.Img_Enum;
diff --git a/gcc/ada/libgnat/s-imgflt.ads b/gcc/ada/libgnat/s-imgflt.ads
new file mode 100644
index 0000000..44f00b8
--- /dev/null
+++ b/gcc/ada/libgnat/s-imgflt.ads
@@ -0,0 +1,66 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S Y S T E M . I M G _ F L T --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 2021, Free Software Foundation, Inc. --
+-- --
+-- GNAT is 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 routines for the Image attribute of floating point
+-- types based on Float, also used for Float_IO output.
+
+with System.Image_R;
+with System.Img_Uns;
+with System.Powten_Flt;
+with System.Unsigned_Types;
+
+package System.Img_Flt is
+ pragma Pure;
+
+ package Impl is new Image_R
+ (Float,
+ System.Powten_Flt.Maxpow,
+ System.Powten_Flt.Powten'Address,
+ Unsigned_Types.Unsigned,
+ System.Img_Uns.Set_Image_Unsigned);
+
+ procedure Image_Float
+ (V : Float;
+ S : in out String;
+ P : out Natural;
+ Digs : Natural)
+ renames Impl.Image_Floating_Point;
+
+ procedure Set_Image_Float
+ (V : Float;
+ S : in out String;
+ P : in out Natural;
+ Fore : Natural;
+ Aft : Natural;
+ Exp : Natural)
+ renames Impl.Set_Image_Real;
+
+end System.Img_Flt;
diff --git a/gcc/ada/libgnat/s-imgint.adb b/gcc/ada/libgnat/s-imgint.adb
index acadd1c..f031120 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 08ce31d..5a1b8ed 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-imglfl.ads b/gcc/ada/libgnat/s-imglfl.ads
new file mode 100644
index 0000000..48f7fc0
--- /dev/null
+++ b/gcc/ada/libgnat/s-imglfl.ads
@@ -0,0 +1,80 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S Y S T E M . I M G _ L F L T --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 2021, Free Software Foundation, Inc. --
+-- --
+-- GNAT is 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 routines for the Image attribute of fixed or floating
+-- point types based on Long_Float, also used for Float_IO/Fixed_IO output.
+
+with System.Img_LLU;
+with System.Image_R;
+with System.Powten_LFlt;
+with System.Unsigned_Types;
+
+package System.Img_LFlt is
+ pragma Pure;
+
+ -- Note that the following instantiation is really for a 32-bit target,
+ -- where 128-bit integer types are not available. For a 64-bit targaet,
+ -- it is possible to use Long_Long_Unsigned and Long_Long_Long_Unsigned
+ -- instead of Unsigned and Long_Long_Unsigned, in order to double the
+ -- number of significant digits. But we do not do it by default to avoid
+ -- dragging 128-bit integer types for the sake of backward compatibility.
+
+ package Impl is new Image_R
+ (Long_Float,
+ System.Powten_LFlt.Maxpow,
+ System.Powten_LFlt.Powten'Address,
+ Unsigned_Types.Long_Long_Unsigned,
+ System.Img_LLU.Set_Image_Long_Long_Unsigned);
+
+ procedure Image_Fixed
+ (V : Long_Float;
+ S : in out String;
+ P : out Natural;
+ Aft : Natural)
+ renames Impl.Image_Fixed_Point;
+
+ procedure Image_Long_Float
+ (V : Long_Float;
+ S : in out String;
+ P : out Natural;
+ Digs : Natural)
+ renames Impl.Image_Floating_Point;
+
+ procedure Set_Image_Long_Float
+ (V : Long_Float;
+ S : in out String;
+ P : in out Natural;
+ Fore : Natural;
+ Aft : Natural;
+ Exp : Natural)
+ renames Impl.Set_Image_Real;
+
+end System.Img_LFlt;
diff --git a/gcc/ada/libgnat/s-imgllb.adb b/gcc/ada/libgnat/s-imgllb.adb
index 90ba5ce..291a815 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 bfaf2ee..b65dbed 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-imgllf.ads b/gcc/ada/libgnat/s-imgllf.ads
new file mode 100644
index 0000000..2a5a3e2
--- /dev/null
+++ b/gcc/ada/libgnat/s-imgllf.ads
@@ -0,0 +1,73 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S Y S T E M . I M G _ L L F --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 2021, Free Software Foundation, Inc. --
+-- --
+-- GNAT is 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 routines for the Image attribute of floating point
+-- types based on Long_Long_Float, also used for Float_IO output.
+
+with System.Img_LLU;
+with System.Image_R;
+with System.Powten_LLF;
+with System.Unsigned_Types;
+
+package System.Img_LLF is
+ pragma Pure;
+
+ -- Note that the following instantiation is really for a 32-bit target,
+ -- where 128-bit integer types are not available. For a 64-bit targaet,
+ -- it is possible to use Long_Long_Unsigned and Long_Long_Long_Unsigned
+ -- instead of Unsigned and Long_Long_Unsigned, in order to double the
+ -- number of significant digits. But we do not do it by default to avoid
+ -- dragging 128-bit integer types for the sake of backward compatibility.
+
+ package Impl is new Image_R
+ (Long_Long_Float,
+ System.Powten_LLF.Maxpow,
+ System.Powten_LLF.Powten'Address,
+ Unsigned_Types.Long_Long_Unsigned,
+ System.Img_LLU.Set_Image_Long_Long_Unsigned);
+
+ procedure Image_Long_Long_Float
+ (V : Long_Long_Float;
+ S : in out String;
+ P : out Natural;
+ Digs : Natural)
+ renames Impl.Image_Floating_Point;
+
+ procedure Set_Image_Long_Long_Float
+ (V : Long_Long_Float;
+ S : in out String;
+ P : in out Natural;
+ Fore : Natural;
+ Aft : Natural;
+ Exp : Natural)
+ renames Impl.Set_Image_Real;
+
+end System.Img_LLF;
diff --git a/gcc/ada/libgnat/s-imglli.adb b/gcc/ada/libgnat/s-imglli.adb
index cdaeb7e..6eb265c 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 49defc5..2e0b42c 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-imglllb.ads b/gcc/ada/libgnat/s-imglllb.ads
index b246037..6d1e418 100644
--- a/gcc/ada/libgnat/s-imglllb.ads
+++ b/gcc/ada/libgnat/s-imglllb.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-imgllli.ads b/gcc/ada/libgnat/s-imgllli.ads
index c6d41f9..5ca2f39 100644
--- a/gcc/ada/libgnat/s-imgllli.ads
+++ b/gcc/ada/libgnat/s-imgllli.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-imglllu.ads b/gcc/ada/libgnat/s-imglllu.ads
index 8b6f16a..4406cb1 100644
--- a/gcc/ada/libgnat/s-imglllu.ads
+++ b/gcc/ada/libgnat/s-imglllu.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-imglllw.ads b/gcc/ada/libgnat/s-imglllw.ads
index de33f18..8958f8c 100644
--- a/gcc/ada/libgnat/s-imglllw.ads
+++ b/gcc/ada/libgnat/s-imglllw.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 680b11b..050f357 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 dabc68d..e8b9d77 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 5702a93..1c3f185 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 12986e5..1862b78 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 2ec6a1a..255e659 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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,689 +29,8 @@
-- --
------------------------------------------------------------------------------
-with System.Img_LLU; use System.Img_LLU;
-with System.Img_Uns; use System.Img_Uns;
-with System.Powten_LLF; use System.Powten_LLF;
-with System.Float_Control;
+-- This package does not require a body, since it is a package renaming. We
+-- provide a dummy file containing a No_Body pragma so that previous versions
+-- of the body (which did exist) will not interfere.
-package body System.Img_Real is
-
- -- The following defines the maximum number of digits that we can convert
- -- accurately. This is limited by the precision of Long_Long_Float, and
- -- also by the number of digits we can hold in Long_Long_Unsigned, which
- -- is the integer type we use as an intermediate for the result.
-
- -- We assume that in practice, the limitation will come from the digits
- -- value, rather than the integer value. This is true for typical IEEE
- -- implementations, and at worst, the only loss is for some precision
- -- in very high precision floating-point output.
-
- -- Note that in the following, the "-2" accounts for the sign and one
- -- extra digit, since we need the maximum number of 9's that can be
- -- represented, e.g. for the 64-bit case, Long_Long_Unsigned'Width is
- -- 21, since the maximum value (approx 1.8E+19) has 20 digits, but the
- -- maximum number of 9's that can be represented is only 19.
-
- Maxdigs : constant :=
- Natural'Min
- (Long_Long_Unsigned'Width - 2, Long_Long_Float'Digits);
-
- Unsdigs : constant := Unsigned'Width - 2;
- -- Number of digits that can be converted using type Unsigned
-
- Maxscaling : constant := 5000;
- -- Max decimal scaling required during conversion of floating-point
- -- numbers to decimal. This is used to defend against infinite
- -- looping in the conversion, as can be caused by erroneous executions.
- -- The largest exponent used on any current system is 2**16383, which
- -- is approximately 10**4932, and the highest number of decimal digits
- -- is about 35 for 128-bit floating-point formats, so 5000 leaves
- -- enough room for scaling such values
-
- function Is_Negative (V : Long_Long_Float) return Boolean;
- pragma Import (Intrinsic, Is_Negative);
-
- --------------------------
- -- Image_Floating_Point --
- --------------------------
-
- procedure Image_Floating_Point
- (V : Long_Long_Float;
- S : in out String;
- P : out Natural;
- Digs : Natural)
- is
- pragma Assert (S'First = 1);
-
- begin
- -- Decide whether a blank should be prepended before the call to
- -- Set_Image_Real. We generate a blank for positive values, and
- -- also for positive zeroes. For negative zeroes, we generate a
- -- blank only if Signed_Zeros is False (the RM only permits the
- -- output of -0.0 when Signed_Zeros is True). We do not generate
- -- a blank for positive infinity, since we output an explicit +.
-
- if (not Is_Negative (V) and then V <= Long_Long_Float'Last)
- or else (not Long_Long_Float'Signed_Zeros and then V = -0.0)
- then
- pragma Annotate (CodePeer, False_Positive, "condition predetermined",
- "CodePeer analysis ignores NaN and Inf values");
- pragma Assert (S'Last > 1);
- -- The caller is responsible for S to be large enough for all
- -- Image_Floating_Point operation.
- S (1) := ' ';
- P := 1;
- else
- P := 0;
- end if;
-
- Set_Image_Real (V, S, P, 1, Digs - 1, 3);
- end Image_Floating_Point;
-
- --------------------------------
- -- Image_Ordinary_Fixed_Point --
- --------------------------------
-
- procedure Image_Ordinary_Fixed_Point
- (V : Long_Long_Float;
- S : in out String;
- P : out Natural;
- Aft : Natural)
- is
- pragma Assert (S'First = 1);
-
- begin
- -- Output space at start if non-negative
-
- if V >= 0.0 then
- S (1) := ' ';
- P := 1;
- else
- P := 0;
- end if;
-
- Set_Image_Real (V, S, P, 1, Aft, 0);
- end Image_Ordinary_Fixed_Point;
-
- --------------------
- -- Set_Image_Real --
- --------------------
-
- procedure Set_Image_Real
- (V : Long_Long_Float;
- S : out String;
- P : in out Natural;
- Fore : Natural;
- Aft : Natural;
- Exp : Natural)
- is
- NFrac : constant Natural := Natural'Max (Aft, 1);
- Minus : Boolean;
- X : Long_Long_Float;
- Scale : Integer;
- Expon : Integer;
-
- 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)
-
- procedure Adjust_Scale (S : Natural);
- -- Adjusts the value in X by multiplying or dividing by a power of
- -- ten so that it is in the range 10**(S-1) <= X < 10**S. Includes
- -- adding 0.5 to round the result, readjusting if the rounding causes
- -- the result to wander out of the range. Scale is adjusted to reflect
- -- the power of ten used to divide the result (i.e. one is added to
- -- the scale value for each division by 10.0, or one is subtracted
- -- for each multiplication by 10.0).
-
- procedure Convert_Integer;
- -- Takes the value in X, outputs integer digits into Digs. On return,
- -- Ndigs is set to the number of digits stored. The digits are stored
- -- in Digs (1 .. Ndigs),
-
- procedure Set (C : Character);
- -- Sets character C in output buffer
-
- procedure Set_Blanks_And_Sign (N : Integer);
- -- Sets leading blanks and minus sign if needed. N is the number of
- -- positions to be filled (a minus sign is output even if N is zero
- -- or negative, but for a positive value, if N is non-positive, then
- -- the call has no effect).
-
- procedure Set_Digs (S, E : Natural);
- -- Set digits S through E from Digs buffer. No effect if S > E
-
- procedure Set_Special_Fill (N : Natural);
- -- After outputting +Inf, -Inf or NaN, this routine fills out the
- -- rest of the field with * characters. The argument is the number
- -- of characters output so far (either 3 or 4)
-
- procedure Set_Zeros (N : Integer);
- -- Set N zeros, no effect if N is negative
-
- pragma Inline (Set);
- pragma Inline (Set_Digs);
- pragma Inline (Set_Zeros);
-
- ------------------
- -- Adjust_Scale --
- ------------------
-
- procedure Adjust_Scale (S : Natural) is
- Lo : Natural;
- Hi : Natural;
- Mid : Natural;
- XP : Long_Long_Float;
-
- begin
- -- Cases where scaling up is required
-
- if X < Powten (S - 1) then
-
- -- What we are looking for is a power of ten to multiply X by
- -- so that the result lies within the required range.
-
- loop
- XP := X * Powten (Maxpow);
- exit when XP >= Powten (S - 1) or else Scale < -Maxscaling;
- X := XP;
- Scale := Scale - Maxpow;
- end loop;
-
- -- The following exception is only raised in case of erroneous
- -- execution, where a number was considered valid but still
- -- fails to scale up. One situation where this can happen is
- -- when a system which is supposed to be IEEE-compliant, but
- -- has been reconfigured to flush denormals to zero.
-
- if Scale < -Maxscaling then
- raise Constraint_Error;
- end if;
-
- -- Here we know that we must multiply by at least 10**1 and that
- -- 10**Maxpow takes us too far: binary search to find right one.
-
- -- Because of roundoff errors, it is possible for the value
- -- of XP to be just outside of the interval when Lo >= Hi. In
- -- that case we adjust explicitly by a factor of 10. This
- -- can only happen with a value that is very close to an
- -- exact power of 10.
-
- Lo := 1;
- Hi := Maxpow;
-
- loop
- Mid := (Lo + Hi) / 2;
- XP := X * Powten (Mid);
-
- if XP < Powten (S - 1) then
-
- if Lo >= Hi then
- Mid := Mid + 1;
- XP := XP * 10.0;
- exit;
-
- else
- Lo := Mid + 1;
- end if;
-
- elsif XP >= Powten (S) then
-
- if Lo >= Hi then
- Mid := Mid - 1;
- XP := XP / 10.0;
- exit;
-
- else
- Hi := Mid - 1;
- end if;
-
- else
- exit;
- end if;
- end loop;
-
- X := XP;
- Scale := Scale - Mid;
-
- -- Cases where scaling down is required
-
- elsif X >= Powten (S) then
-
- -- 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;
- X := XP;
- Scale := Scale + Maxpow;
- end loop;
-
- -- The following exception is only raised in case of erroneous
- -- execution, where a number was considered valid but still
- -- fails to scale up. One situation where this can happen is
- -- when a system which is supposed to be IEEE-compliant, but
- -- has been reconfigured to flush denormals to zero.
-
- if Scale > Maxscaling then
- raise Constraint_Error;
- end if;
-
- -- Here we know that we must divide by at least 10**1 and that
- -- 10**Maxpow takes us too far, binary search to find right one.
-
- Lo := 1;
- Hi := Maxpow;
-
- loop
- Mid := (Lo + Hi) / 2;
- XP := X / Powten (Mid);
-
- if XP < Powten (S - 1) then
-
- if Lo >= Hi then
- XP := XP * 10.0;
- Mid := Mid - 1;
- exit;
-
- else
- Hi := Mid - 1;
- end if;
-
- elsif XP >= Powten (S) then
-
- if Lo >= Hi then
- XP := XP / 10.0;
- Mid := Mid + 1;
- exit;
-
- else
- Lo := Mid + 1;
- end if;
-
- else
- exit;
- end if;
- end loop;
-
- X := XP;
- Scale := Scale + Mid;
-
- -- Here we are already scaled right
-
- else
- null;
- end if;
-
- -- Round, readjusting scale if needed. Note that if a readjustment
- -- occurs, then it is never necessary to round again, because there
- -- is no possibility of such a second rounding causing a change.
-
- X := X + 0.5;
-
- if X >= Powten (S) then
- X := X / 10.0;
- Scale := Scale + 1;
- end if;
-
- end Adjust_Scale;
-
- ---------------------
- -- Convert_Integer --
- ---------------------
-
- procedure Convert_Integer is
- begin
- -- Use Unsigned routine if possible, since on many machines it will
- -- be significantly more efficient than the Long_Long_Unsigned one.
-
- if X < Powten (Unsdigs) then
- pragma Assert (X in 0.0 .. Long_Long_Float (Unsigned'Last));
- Ndigs := 0;
- Set_Image_Unsigned
- (Unsigned (Long_Long_Float'Truncation (X)),
- Digs, Ndigs);
-
- -- But if we want more digits than fit in Unsigned, we have to use
- -- the Long_Long_Unsigned routine after all.
-
- else
- pragma Assert (X < Powten (Maxdigs));
- pragma Assert
- (X in 0.0 .. Long_Long_Float (Long_Long_Unsigned'Last));
-
- Ndigs := 0;
- Set_Image_Long_Long_Unsigned
- (Long_Long_Unsigned (Long_Long_Float'Truncation (X)),
- Digs, Ndigs);
- end if;
- end Convert_Integer;
-
- ---------
- -- Set --
- ---------
-
- procedure Set (C : Character) is
- begin
- pragma Assert (P in S'First - 1 .. S'Last - 1);
- -- No check is done as documented in the header: updating P to point
- -- to the last character stored, the caller promises that the buffer
- -- is large enough and no check is made for this. Constraint_Error
- -- will not necessarily be raised if this requirement is violated,
- -- since it is perfectly valid to compile this unit with checks off.
- P := P + 1;
- S (P) := C;
- end Set;
-
- -------------------------
- -- Set_Blanks_And_Sign --
- -------------------------
-
- procedure Set_Blanks_And_Sign (N : Integer) is
- begin
- if Minus then
- for J in 1 .. N - 1 loop
- Set (' ');
- end loop;
-
- Set ('-');
-
- else
- for J in 1 .. N loop
- Set (' ');
- end loop;
- end if;
- end Set_Blanks_And_Sign;
-
- --------------
- -- Set_Digs --
- --------------
-
- procedure Set_Digs (S, E : Natural) is
- begin
- pragma Assert (S >= Digs'First and E <= Digs'Last);
- -- S and E should be in the Digs array range
- for J in S .. E loop
- Set (Digs (J));
- end loop;
- end Set_Digs;
-
- ----------------------
- -- Set_Special_Fill --
- ----------------------
-
- procedure Set_Special_Fill (N : Natural) is
- F : Natural;
-
- begin
- pragma Assert ((Fore + Aft - N + 1) in Natural);
- -- Fore + Aft - N + 1 should be in the Natural range
- F := Fore + 1 + Aft - N;
-
- if Exp /= 0 then
- pragma Assert (F + Exp + 1 <= Natural'Last);
- -- F + Exp + 1 should be in the Natural range
- F := F + Exp + 1;
- end if;
-
- for J in 1 .. F loop
- Set ('*');
- end loop;
- end Set_Special_Fill;
-
- ---------------
- -- Set_Zeros --
- ---------------
-
- procedure Set_Zeros (N : Integer) is
- begin
- for J in 1 .. N loop
- Set ('0');
- end loop;
- end Set_Zeros;
-
- -- Start of processing for Set_Image_Real
-
- begin
- -- We call the floating-point processor reset routine so we can be sure
- -- that the processor is properly set for conversions. This is notably
- -- needed on Windows, where calls to the operating system randomly reset
- -- the processor into 64-bit mode.
-
- System.Float_Control.Reset;
-
- Scale := 0;
-
- -- Deal with invalid values first,
-
- if not V'Valid then
-
- -- Note that we're taking our chances here, as V might be
- -- an invalid bit pattern resulting from erroneous execution
- -- (caused by using uninitialized variables for example).
-
- -- No matter what, we'll at least get reasonable behavior,
- -- converting to infinity or some other value, or causing an
- -- exception to be raised is fine.
-
- -- If the following test succeeds, then we definitely have
- -- an infinite value, so we print Inf.
-
- if V > Long_Long_Float'Last then
- pragma Annotate (CodePeer, False_Positive, "dead code",
- "CodePeer analysis ignores NaN and Inf values");
- pragma Annotate (CodePeer, False_Positive, "test always true",
- "CodePeer analysis ignores NaN and Inf values");
- Set ('+');
- Set ('I');
- Set ('n');
- Set ('f');
- Set_Special_Fill (4);
- -- In all other cases we print NaN
-
- elsif V < Long_Long_Float'First then
- Set ('-');
- Set ('I');
- Set ('n');
- Set ('f');
- Set_Special_Fill (4);
- else
- Set ('N');
- Set ('a');
- Set ('N');
- Set_Special_Fill (3);
- end if;
-
- return;
- end if;
-
- -- Positive values
-
- if V > 0.0 then
- X := V;
- Minus := False;
-
- -- Negative values
-
- elsif V < 0.0 then
- X := -V;
- Minus := True;
-
- -- Zero values
-
- elsif V = 0.0 then
- if Long_Long_Float'Signed_Zeros and then Is_Negative (V) then
- Minus := True;
- else
- Minus := False;
- end if;
-
- Set_Blanks_And_Sign (Fore - 1);
- Set ('0');
- Set ('.');
- Set_Zeros (NFrac);
-
- if Exp /= 0 then
- Set ('E');
- Set ('+');
- Set_Zeros (Natural'Max (1, Exp - 1));
- end if;
-
- return;
-
- else
- -- It should not be possible for a NaN to end up here.
- -- Either the 'Valid test has failed, or we have some form
- -- of erroneous execution. Raise Constraint_Error instead of
- -- attempting to go ahead printing the value.
-
- raise Constraint_Error;
- end if;
-
- -- X and Minus are set here, and X is known to be a valid,
- -- non-zero floating-point number.
-
- -- Case of non-zero value with Exp = 0
-
- if Exp = 0 then
-
- -- First step is to multiply by 10 ** Nfrac to get an integer
- -- value to be output, an then add 0.5 to round the result.
-
- declare
- NF : Natural := NFrac;
-
- begin
- loop
- -- If we are larger than Powten (Maxdigs) now, then
- -- we have too many significant digits, and we have
- -- not even finished multiplying by NFrac (NF shows
- -- the number of unaccounted-for digits).
-
- if X >= Powten (Maxdigs) then
-
- -- In this situation, we only to generate a reasonable
- -- number of significant digits, and then zeroes after.
- -- So first we rescale to get:
-
- -- 10 ** (Maxdigs - 1) <= X < 10 ** Maxdigs
-
- -- and then convert the resulting integer
-
- Adjust_Scale (Maxdigs);
- Convert_Integer;
-
- -- If that caused rescaling, then add zeros to the end
- -- of the number to account for this scaling. Also add
- -- zeroes to account for the undone multiplications
-
- for J in 1 .. Scale + NF loop
- Ndigs := Ndigs + 1;
- pragma Assert (Ndigs <= Digs'Last);
- Digs (Ndigs) := '0';
- end loop;
-
- exit;
-
- -- If multiplication is complete, then convert the resulting
- -- integer after rounding (note that X is non-negative)
-
- elsif NF = 0 then
- X := X + 0.5;
- Convert_Integer;
- exit;
-
- -- Otherwise we can go ahead with the multiplication. If it
- -- can be done in one step, then do it in one step.
-
- elsif NF < Maxpow then
- X := X * Powten (NF);
- NF := 0;
-
- -- If it cannot be done in one step, then do partial scaling
-
- else
- X := X * Powten (Maxpow);
- NF := NF - Maxpow;
- end if;
- end loop;
- end;
-
- -- If number of available digits is less or equal to NFrac,
- -- then we need an extra zero before the decimal point.
-
- if Ndigs <= NFrac then
- Set_Blanks_And_Sign (Fore - 1);
- Set ('0');
- Set ('.');
- Set_Zeros (NFrac - Ndigs);
- Set_Digs (1, Ndigs);
-
- -- Normal case with some digits before the decimal point
-
- else
- Set_Blanks_And_Sign (Fore - (Ndigs - NFrac));
- Set_Digs (1, Ndigs - NFrac);
- Set ('.');
- Set_Digs (Ndigs - NFrac + 1, Ndigs);
- end if;
-
- -- Case of non-zero value with non-zero Exp value
-
- else
- -- If NFrac is less than Maxdigs, then all the fraction digits are
- -- significant, so we can scale the resulting integer accordingly.
-
- if NFrac < Maxdigs then
- Adjust_Scale (NFrac + 1);
- Convert_Integer;
-
- -- Otherwise, we get the maximum number of digits available
-
- else
- Adjust_Scale (Maxdigs);
- Convert_Integer;
-
- for J in 1 .. NFrac - Maxdigs + 1 loop
- Ndigs := Ndigs + 1;
- pragma Assert (Ndigs <= Digs'Last);
- Digs (Ndigs) := '0';
- Scale := Scale - 1;
- end loop;
- end if;
-
- Set_Blanks_And_Sign (Fore - 1);
- Set (Digs (1));
- Set ('.');
- Set_Digs (2, Ndigs);
-
- -- The exponent is the scaling factor adjusted for the digits
- -- that we output after the decimal point, since these were
- -- included in the scaled digits that we output.
-
- Expon := Scale + NFrac;
-
- Set ('E');
- Ndigs := 0;
-
- if Expon >= 0 then
- Set ('+');
- Set_Image_Unsigned (Unsigned (Expon), Digs, Ndigs);
- else
- Set ('-');
- Set_Image_Unsigned (Unsigned (-Expon), Digs, Ndigs);
- end if;
-
- Set_Zeros (Exp - Ndigs - 1);
- Set_Digs (1, Ndigs);
- end if;
-
- end Set_Image_Real;
-
-end System.Img_Real;
+pragma No_Body;
diff --git a/gcc/ada/libgnat/s-imgrea.ads b/gcc/ada/libgnat/s-imgrea.ads
index d8eb721..45abac1 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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,56 +29,20 @@
-- --
------------------------------------------------------------------------------
--- Image for fixed and float types (also used for Float_IO/Fixed_IO output)
+-- This obsolete package is preserved for the sake of backward compatibility
+
+with System.Img_LLF;
package System.Img_Real is
pragma Pure;
- procedure Image_Ordinary_Fixed_Point
- (V : Long_Long_Float;
- S : in out String;
- P : out Natural;
- Aft : Natural);
- -- Computes fixed_type'Image (V) and returns the result in S (1 .. P)
- -- updating P on return. The result is computed according to the rules for
- -- image for fixed-point types (RM 3.5(34)), where Aft is the value of the
- -- Aft attribute for the fixed-point type. This function is used only for
- -- ordinary fixed point (see package System.Img_Dec for handling of decimal
- -- fixed point). The caller guarantees that S is long enough to hold the
- -- result and has a lower bound of 1.
- --
- -- Remark: This procedure should NOT be called with V = -0.0 or V = +/-Inf,
- -- The result is irrelevant.
-
- procedure Image_Floating_Point
- (V : Long_Long_Float;
- S : in out String;
- P : out Natural;
- Digs : Natural);
- -- Computes float_type'Image (V) and returns the result in S (1 .. P)
- -- updating P on return. The result is computed according to the rules for
- -- image for floating-point types (RM 3.5(33)), where Digs is the value of
- -- the Digits attribute for the floating-point type. The caller guarantees
- -- that S is long enough to hold the result and has a lower bound of 1.
-
procedure Set_Image_Real
(V : Long_Long_Float;
- S : out String;
+ S : in out String;
P : in out Natural;
Fore : Natural;
Aft : Natural;
- Exp : Natural);
- -- Sets the image of V starting at S (P + 1), updating P to point to the
- -- last character stored, the caller promises that the buffer is large
- -- enough and no check is made for this. Constraint_Error will not
- -- necessarily be raised if this is violated, since it is perfectly valid
- -- to compile this unit with checks off). The Fore, Aft and Exp values
- -- 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.
+ Exp : Natural)
+ renames System.Img_LLF.Set_Image_Long_Long_Float;
end System.Img_Real;
diff --git a/gcc/ada/libgnat/s-imguns.adb b/gcc/ada/libgnat/s-imguns.adb
index 8db42b4..bc4d851 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 746fff1..e44f4fc 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-imguti.adb b/gcc/ada/libgnat/s-imguti.adb
index 571fb67..e86be49 100644
--- a/gcc/ada/libgnat/s-imguti.adb
+++ b/gcc/ada/libgnat/s-imguti.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2020-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -400,4 +400,85 @@ package body System.Img_Util is
end if;
end Set_Decimal_Digits;
+ --------------------------------
+ -- Set_Floating_Invalid_Value --
+ --------------------------------
+
+ procedure Set_Floating_Invalid_Value
+ (V : Floating_Invalid_Value;
+ S : out String;
+ P : in out Natural;
+ Fore : Natural;
+ Aft : Natural;
+ Exp : Natural)
+ is
+ procedure Set (C : Character);
+ -- Sets character C in output buffer
+
+ procedure Set_Special_Fill (N : Natural);
+ -- After outputting +Inf, -Inf or NaN, this routine fills out the
+ -- rest of the field with * characters. The argument is the number
+ -- of characters output so far (either 3 or 4)
+
+ ---------
+ -- Set --
+ ---------
+
+ procedure Set (C : Character) is
+ begin
+ pragma Assert (P in S'First - 1 .. S'Last - 1);
+ -- No check is done as documented in the header: updating P to point
+ -- to the last character stored, the caller promises that the buffer
+ -- is large enough and no check is made for this. Constraint_Error
+ -- will not necessarily be raised if this requirement is violated,
+ -- since it is perfectly valid to compile this unit with checks off.
+
+ P := P + 1;
+ S (P) := C;
+ end Set;
+
+ ----------------------
+ -- Set_Special_Fill --
+ ----------------------
+
+ procedure Set_Special_Fill (N : Natural) is
+ begin
+ if Exp /= 0 then
+ for J in N + 1 .. Fore + 1 + Aft + 1 + Exp loop
+ Set ('*');
+ end loop;
+
+ else
+ for J in N + 1 .. Fore + 1 + Aft loop
+ Set ('*');
+ end loop;
+ end if;
+ end Set_Special_Fill;
+
+ -- Start of processing for Set_Floating_Invalid_Value
+
+ begin
+ case V is
+ when Minus_Infinity =>
+ Set ('-');
+ Set ('I');
+ Set ('n');
+ Set ('f');
+ Set_Special_Fill (4);
+
+ when Infinity =>
+ Set ('+');
+ Set ('I');
+ Set ('n');
+ Set ('f');
+ Set_Special_Fill (4);
+
+ when Not_A_Number =>
+ Set ('N');
+ Set ('a');
+ Set ('N');
+ Set_Special_Fill (3);
+ end case;
+ end Set_Floating_Invalid_Value;
+
end System.Img_Util;
diff --git a/gcc/ada/libgnat/s-imguti.ads b/gcc/ada/libgnat/s-imguti.ads
index 6e21c65..68e8e2a 100644
--- a/gcc/ada/libgnat/s-imguti.ads
+++ b/gcc/ada/libgnat/s-imguti.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2020-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -34,6 +34,11 @@
package System.Img_Util is
pragma Pure;
+ 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.
+
procedure Set_Decimal_Digits
(Digs : in out String;
NDigs : Natural;
@@ -58,4 +63,19 @@ package System.Img_Util is
-- may destroy the value in Digs, which is why Digs is in-out (this happens
-- if rounding is required).
+ type Floating_Invalid_Value is (Minus_Infinity, Infinity, Not_A_Number);
+
+ procedure Set_Floating_Invalid_Value
+ (V : Floating_Invalid_Value;
+ S : out String;
+ P : in out Natural;
+ Fore : Natural;
+ Aft : Natural;
+ Exp : Natural);
+ -- Sets the image of a floating-point invalid value, starting at S (P + 1),
+ -- updating P to point to the last character stored. The caller promises
+ -- that the buffer is large enough and therefore no check is made for it.
+ -- Constraint_Error will not necessarily be raised if the requirement is
+ -- violated since it is valid to compile this unit with checks off.
+
end System.Img_Util;
diff --git a/gcc/ada/libgnat/s-imgwch.adb b/gcc/ada/libgnat/s-imgwch.adb
index 499a513..9663126 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 efc1463..7b285f4 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 9f04cce..a7e7d7a 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 89515e8..605625a 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 23301e9..9f42791 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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.ads b/gcc/ada/libgnat/s-io.ads
index 6b733b6..20284b1 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 bbc79a8..ff0d007 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2011-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 d2465f6..c78dc91 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 48eb280..d7a4c60 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1996-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 7ad511e..fbf35f8 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1996-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 cf87731..26c874c 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1999-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 ffe04be..1df1047 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1999-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 db33a57..147c161 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2001-2021, 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 f6ecf47..c026bcf 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2001-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 57e8b24..728779d 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2001-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 0e1f4f7..fc978a4 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-2020, AdaCore --
+-- Copyright (C) 2007-2021, 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 305d1f8..939c1ce 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-2020, AdaCore --
+-- Copyright (C) 2007-2021, 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-mmauni__long.ads b/gcc/ada/libgnat/s-mmauni__long.ads
index 4fbd00a..3a68579 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-2020, AdaCore --
+-- Copyright (C) 2007-2021, 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 631e0dd..588e42e 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-2020, AdaCore --
+-- Copyright (C) 2007-2021, 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 8c3a472..74ac1f6 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-2020, AdaCore --
+-- Copyright (C) 2007-2021, 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 e0b369f..6a3e4ce 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-2020, AdaCore --
+-- Copyright (C) 2007-2021, 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 234ce42..e9338cb 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-2020, AdaCore --
+-- Copyright (C) 2007-2021, 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 e17872c..8c9ae2b 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2010-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 0cfa522..9dd8c1f 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2009-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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,7 @@ package body System.Object_Reader is
function Trim_Trailing_Nuls (Str : String) return String;
-- Return a copy of a string with any trailing NUL characters truncated
- procedure Check_Read_Offset (S : in out Mapped_Stream; Size : uint32);
+ procedure Check_Read_Offset (S : Mapped_Stream; Size : uint32);
-- Check that the SIZE bytes at the current offset are still in the stream
-------------------------------------
@@ -78,6 +78,7 @@ package body System.Object_Reader is
EM_SPARCV9 : constant := 43; -- SPARC v9 64-bit
EM_IA_64 : constant := 50; -- Intel Merced
EM_X86_64 : constant := 62; -- AMD x86-64 architecture
+ EM_AARCH64 : constant := 183; -- Aarch64
EN_NIDENT : constant := 16;
@@ -648,6 +649,9 @@ package body System.Object_Reader is
when EM_ARM =>
Res.Arch := ARM;
+ when EM_AARCH64 =>
+ Res.Arch := AARCH64;
+
when others =>
raise Format_Error with "unrecognized architecture";
end case;
@@ -1931,7 +1935,7 @@ package body System.Object_Reader is
return To_String_Ptr_Len (Read (S));
end Read;
- procedure Check_Read_Offset (S : in out Mapped_Stream; Size : uint32) is
+ procedure Check_Read_Offset (S : Mapped_Stream; Size : uint32) is
begin
if S.Off + Offset (Size) > Offset (Last (S.Region)) then
raise IO_Error with "could not read from object file";
@@ -2038,7 +2042,8 @@ package body System.Object_Reader is
Address_32 := Read (S);
return uint64 (Address_32);
- when IA64
+ when AARCH64
+ | IA64
| PPC64
| SPARC64
| x86_64
diff --git a/gcc/ada/libgnat/s-objrea.ads b/gcc/ada/libgnat/s-objrea.ads
index b3cfe13..a83ca53 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2009-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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,9 +120,12 @@ package System.Object_Reader is
PPC64,
-- 64-bit PowerPC
- ARM);
+ ARM,
-- 32-bit ARM
+ AARCH64);
+ -- 64-bit ARM
+
------------------
-- Target types --
------------------
diff --git a/gcc/ada/libgnat/s-optide.adb b/gcc/ada/libgnat/s-optide.adb
index c979797..6ab0301 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-2020, AdaCore --
+-- Copyright (C) 2012-2021, 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 93522bc..19f4cf7 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-2020, AdaCore --
+-- Copyright (C) 1995-2021, 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- --
@@ -133,42 +133,6 @@ package body System.OS_Lib is
-- Converts a C String to an Ada String. We could do this making use of
-- Interfaces.C.Strings but we prefer not to import that entire package
- ---------
- -- "<" --
- ---------
-
- function "<" (X, Y : OS_Time) return Boolean is
- begin
- return Long_Integer (X) < Long_Integer (Y);
- end "<";
-
- ----------
- -- "<=" --
- ----------
-
- function "<=" (X, Y : OS_Time) return Boolean is
- begin
- return Long_Integer (X) <= Long_Integer (Y);
- end "<=";
-
- ---------
- -- ">" --
- ---------
-
- function ">" (X, Y : OS_Time) return Boolean is
- begin
- return Long_Integer (X) > Long_Integer (Y);
- end ">";
-
- ----------
- -- ">=" --
- ----------
-
- function ">=" (X, Y : OS_Time) return Boolean is
- begin
- return Long_Integer (X) >= Long_Integer (Y);
- end ">=";
-
-----------------
-- Args_Length --
-----------------
@@ -1347,13 +1311,13 @@ package body System.OS_Lib is
Second : out Second_Type)
is
procedure To_GM_Time
- (P_Time_T : Address;
- P_Year : Address;
- P_Month : Address;
- P_Day : Address;
- P_Hours : Address;
- P_Mins : Address;
- P_Secs : Address);
+ (P_OS_Time : Address;
+ P_Year : Address;
+ P_Month : Address;
+ P_Day : Address;
+ P_Hours : Address;
+ P_Mins : Address;
+ P_Secs : Address);
pragma Import (C, To_GM_Time, "__gnat_to_gm_time");
T : OS_Time := Date;
@@ -1385,13 +1349,13 @@ package body System.OS_Lib is
Locked_Processing : begin
SSL.Lock_Task.all;
To_GM_Time
- (P_Time_T => T'Address,
- P_Year => Y'Address,
- P_Month => Mo'Address,
- P_Day => D'Address,
- P_Hours => H'Address,
- P_Mins => Mn'Address,
- P_Secs => S'Address);
+ (P_OS_Time => T'Address,
+ P_Year => Y'Address,
+ P_Month => Mo'Address,
+ P_Day => D'Address,
+ P_Hours => H'Address,
+ P_Mins => Mn'Address,
+ P_Secs => S'Address);
SSL.Unlock_Task.all;
exception
@@ -1429,26 +1393,26 @@ package body System.OS_Lib is
Second : Second_Type) return OS_Time
is
procedure To_OS_Time
- (P_Time_T : Address;
- P_Year : Integer;
- P_Month : Integer;
- P_Day : Integer;
- P_Hours : Integer;
- P_Mins : Integer;
- P_Secs : Integer);
+ (P_OS_Time : Address;
+ P_Year : Integer;
+ P_Month : Integer;
+ P_Day : Integer;
+ P_Hours : Integer;
+ P_Mins : Integer;
+ P_Secs : Integer);
pragma Import (C, To_OS_Time, "__gnat_to_os_time");
Result : OS_Time;
begin
To_OS_Time
- (P_Time_T => Result'Address,
- P_Year => Year - 1900,
- P_Month => Month - 1,
- P_Day => Day,
- P_Hours => Hour,
- P_Mins => Minute,
- P_Secs => Second);
+ (P_OS_Time => Result'Address,
+ P_Year => Year - 1900,
+ P_Month => Month - 1,
+ P_Day => Day,
+ P_Hours => Hour,
+ P_Mins => Minute,
+ P_Secs => Second);
return Result;
end GM_Time_Of;
@@ -2158,8 +2122,10 @@ package body System.OS_Lib is
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);
+ or else Name (Name'First)
+ /= Directory_Separator
+ or else Name (Name'First + 1)
+ /= Directory_Separator);
end Missed_Drive_Letter;
-----------------
diff --git a/gcc/ada/libgnat/s-os_lib.ads b/gcc/ada/libgnat/s-os_lib.ads
index f786cca..2049e38 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1995-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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,8 +164,21 @@ package System.OS_Lib is
-- component parts to be interpreted in the local time zone, and returns
-- an OS_Time. Returns Invalid_Time if the creation fails.
- subtype time_t is Long_Integer;
- -- C time_t type of the time representation
+ ------------------
+ -- Time_t Stuff --
+ ------------------
+
+ -- Note: Do not use time_t in the compiler and host-based tools; instead
+ -- use OS_Time. These 3 declarations are intended for use only by consumers
+ -- of the GNAT.OS_Lib renaming of this package.
+
+ subtype time_t is Long_Long_Integer;
+ -- C time_t can be either long or long long, but this is a subtype not used
+ -- in the compiler or tools, but only for user applications, so we choose
+ -- the Ada equivalent of the latter because eventually that will be the
+ -- type used out of necessity. This may affect some user code on 32-bit
+ -- targets that have not yet migrated to the Posix 2008 standard,
+ -- particularly pre version 5 32-bit Linux.
function To_C (Time : OS_Time) return time_t;
-- Convert OS_Time to C time_t type
@@ -1098,24 +1111,18 @@ private
pragma Import (C, Current_Process_Id, "__gnat_current_process_id");
type OS_Time is
- range -(2 ** (Standard'Address_Size - Integer'(1))) ..
- +(2 ** (Standard'Address_Size - Integer'(1)) - 1);
+ range -(2 ** 63) .. +(2 ** 63 - 1);
-- Type used for timestamps in the compiler. This type is used to hold
-- time stamps, but may have a different representation than C's time_t.
-- This type needs to match the declaration of OS_Time in adaint.h.
- -- Add pragma Inline statements for comparison operations on OS_Time. It
- -- would actually be nice to use pragma Import (Intrinsic) here, but this
- -- was not properly supported till GNAT 3.15a, so that would cause
- -- bootstrap path problems. To be changed later ???
-
Invalid_Time : constant OS_Time := -1;
-- This value should match the return value from __gnat_file_time_*
- pragma Inline ("<");
- pragma Inline (">");
- pragma Inline ("<=");
- pragma Inline (">=");
+ pragma Import (Intrinsic, "<");
+ pragma Import (Intrinsic, ">");
+ pragma Import (Intrinsic, "<=");
+ pragma Import (Intrinsic, ">=");
pragma Inline (To_C);
pragma Inline (To_Ada);
diff --git a/gcc/ada/libgnat/s-osprim.ads b/gcc/ada/libgnat/s-osprim.ads
index fce4203..fb4eb9ff 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1998-2021, 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 8e85871..00d0ccb 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1998-2021, 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,6 +31,7 @@
-- This version is for darwin
+with System.Parameters;
package body System.OS_Primitives is
-- ??? These definitions are duplicated from System.OS_Interface
@@ -45,7 +46,8 @@ package body System.OS_Primitives is
pragma Convention (C, struct_timezone);
type struct_timezone_ptr is access all struct_timezone;
- type time_t is new Long_Integer;
+ type time_t is range -2 ** (System.Parameters.time_t_bits - 1)
+ .. 2 ** (System.Parameters.time_t_bits - 1) - 1;
type struct_timeval is record
tv_sec : time_t;
diff --git a/gcc/ada/libgnat/s-osprim__lynxos.ads b/gcc/ada/libgnat/s-osprim__lynxos.ads
index e181f7e..790c597 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1998-2021, 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 8e0c425..61f24fd 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1998-2021, 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 4413616..96bf70e 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1998-2021, 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- --
@@ -30,6 +30,7 @@
------------------------------------------------------------------------------
-- This version is for POSIX-like operating systems
+with System.Parameters;
package body System.OS_Primitives is
@@ -38,7 +39,8 @@ package body System.OS_Primitives is
-- these declarations in System.OS_Interface and move these ones in
-- the spec.
- type time_t is new Long_Integer;
+ type time_t is range -2 ** (System.Parameters.time_t_bits - 1)
+ .. 2 ** (System.Parameters.time_t_bits - 1) - 1;
type timespec is record
tv_sec : time_t;
diff --git a/gcc/ada/libgnat/s-osprim__posix2008.adb b/gcc/ada/libgnat/s-osprim__posix2008.adb
index 87bbdc1..44f14c4f 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1998-2021, 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- --
@@ -33,6 +33,7 @@
with System.CRTL;
with System.OS_Constants;
+with System.Parameters;
package body System.OS_Primitives is
subtype int is System.CRTL.int;
@@ -41,7 +42,8 @@ package body System.OS_Primitives is
-- we don't want to depend on any package. Consider removing these
-- declarations in System.OS_Interface and move these ones to the spec.
- type time_t is new System.CRTL.int64;
+ type time_t is range -2 ** (System.Parameters.time_t_bits - 1)
+ .. 2 ** (System.Parameters.time_t_bits - 1) - 1;
type timespec is record
tv_sec : time_t;
diff --git a/gcc/ada/libgnat/s-osprim__rtems.adb b/gcc/ada/libgnat/s-osprim__rtems.adb
index 5cdc03d..23669e1 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1998-2021, 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,6 +31,7 @@
-- This version is for POSIX-like operating systems
+with System.Parameters;
package body System.OS_Primitives is
-- ??? These definitions are duplicated from System.OS_Interface
@@ -38,7 +39,8 @@ package body System.OS_Primitives is
-- these declarations in System.OS_Interface and move these ones in
-- the spec.
- type time_t is new Long_Long_Integer;
+ type time_t is range -2 ** (System.Parameters.time_t_bits - 1)
+ .. 2 ** (System.Parameters.time_t_bits - 1) - 1;
type timespec is record
tv_sec : time_t;
diff --git a/gcc/ada/libgnat/s-osprim__solaris.adb b/gcc/ada/libgnat/s-osprim__solaris.adb
index 7165bc4..62e2d98 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1998-2021, 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 9a936c6..4d2db9b 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1998-2021, 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 40e7d49..ad2ac40 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1998-2021, 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 4a11379..9dc1ba9 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2013-2021, 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,6 +31,8 @@
-- This version is for Linux/x32
+with System.Parameters;
+
package body System.OS_Primitives is
-- ??? These definitions are duplicated from System.OS_Interface
@@ -38,7 +40,8 @@ package body System.OS_Primitives is
-- these declarations in System.OS_Interface and move these ones in
-- the spec.
- type time_t is new Long_Long_Integer;
+ type time_t is range -2 ** (System.Parameters.time_t_bits - 1)
+ .. 2 ** (System.Parameters.time_t_bits - 1) - 1;
type timespec is record
tv_sec : time_t;
diff --git a/gcc/ada/libgnat/s-osvers__vxworks-653.ads b/gcc/ada/libgnat/s-osvers__vxworks-653.ads
index 48b1c2a..e180e7c 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-2020, AdaCore --
+-- Copyright (C) 2010-2021, 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 32e7c0c..1f6c2ef 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 47d71f0..eb1094e 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 78a7005..c7845aa 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 cdcacc7..3f4ef87 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 623b955..02b5331 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 0c918a0..e7ca7b1 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 f0a3177..dbcb05e 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 4fa1385..49be5ee 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 8517f4d..af5804c 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 cdf62e3..f03afc0 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 d08751d..1ba1769 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 33ed2dd1..621e84f 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-pack100.adb b/gcc/ada/libgnat/s-pack100.adb
index bae251c..d3211e3 100644
--- a/gcc/ada/libgnat/s-pack100.adb
+++ b/gcc/ada/libgnat/s-pack100.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-pack100.ads b/gcc/ada/libgnat/s-pack100.ads
index dfb3e62..ada158d 100644
--- a/gcc/ada/libgnat/s-pack100.ads
+++ b/gcc/ada/libgnat/s-pack100.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-pack101.adb b/gcc/ada/libgnat/s-pack101.adb
index dfa1cf3..9ef16e5 100644
--- a/gcc/ada/libgnat/s-pack101.adb
+++ b/gcc/ada/libgnat/s-pack101.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-pack101.ads b/gcc/ada/libgnat/s-pack101.ads
index 2e77051..91eaf5c 100644
--- a/gcc/ada/libgnat/s-pack101.ads
+++ b/gcc/ada/libgnat/s-pack101.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-pack102.adb b/gcc/ada/libgnat/s-pack102.adb
index ebf1094..9da1d19 100644
--- a/gcc/ada/libgnat/s-pack102.adb
+++ b/gcc/ada/libgnat/s-pack102.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-pack102.ads b/gcc/ada/libgnat/s-pack102.ads
index 065f338..22c17024 100644
--- a/gcc/ada/libgnat/s-pack102.ads
+++ b/gcc/ada/libgnat/s-pack102.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-pack103.adb b/gcc/ada/libgnat/s-pack103.adb
index b5df31e..158daf9 100644
--- a/gcc/ada/libgnat/s-pack103.adb
+++ b/gcc/ada/libgnat/s-pack103.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-pack103.ads b/gcc/ada/libgnat/s-pack103.ads
index ad12b0e..0e1442f 100644
--- a/gcc/ada/libgnat/s-pack103.ads
+++ b/gcc/ada/libgnat/s-pack103.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-pack104.adb b/gcc/ada/libgnat/s-pack104.adb
index 573fe4a..4cf7e0e 100644
--- a/gcc/ada/libgnat/s-pack104.adb
+++ b/gcc/ada/libgnat/s-pack104.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-pack104.ads b/gcc/ada/libgnat/s-pack104.ads
index 3dee1a7..1e111f9 100644
--- a/gcc/ada/libgnat/s-pack104.ads
+++ b/gcc/ada/libgnat/s-pack104.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-pack105.adb b/gcc/ada/libgnat/s-pack105.adb
index b5e2aab..44052c5 100644
--- a/gcc/ada/libgnat/s-pack105.adb
+++ b/gcc/ada/libgnat/s-pack105.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-pack105.ads b/gcc/ada/libgnat/s-pack105.ads
index 2faf652..dfe49f8 100644
--- a/gcc/ada/libgnat/s-pack105.ads
+++ b/gcc/ada/libgnat/s-pack105.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-pack106.adb b/gcc/ada/libgnat/s-pack106.adb
index 645b5a2..a604456 100644
--- a/gcc/ada/libgnat/s-pack106.adb
+++ b/gcc/ada/libgnat/s-pack106.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-pack106.ads b/gcc/ada/libgnat/s-pack106.ads
index 27c7efa..b4a4711 100644
--- a/gcc/ada/libgnat/s-pack106.ads
+++ b/gcc/ada/libgnat/s-pack106.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-pack107.adb b/gcc/ada/libgnat/s-pack107.adb
index 7e1a86a..4c04486 100644
--- a/gcc/ada/libgnat/s-pack107.adb
+++ b/gcc/ada/libgnat/s-pack107.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-pack107.ads b/gcc/ada/libgnat/s-pack107.ads
index 3eba81d..dcd4c07 100644
--- a/gcc/ada/libgnat/s-pack107.ads
+++ b/gcc/ada/libgnat/s-pack107.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-pack108.adb b/gcc/ada/libgnat/s-pack108.adb
index afe28a5..6da22bd 100644
--- a/gcc/ada/libgnat/s-pack108.adb
+++ b/gcc/ada/libgnat/s-pack108.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-pack108.ads b/gcc/ada/libgnat/s-pack108.ads
index e751654..8bb2017 100644
--- a/gcc/ada/libgnat/s-pack108.ads
+++ b/gcc/ada/libgnat/s-pack108.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-pack109.adb b/gcc/ada/libgnat/s-pack109.adb
index e976ed4..3770666 100644
--- a/gcc/ada/libgnat/s-pack109.adb
+++ b/gcc/ada/libgnat/s-pack109.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-pack109.ads b/gcc/ada/libgnat/s-pack109.ads
index 2ea8b42..3d809c3 100644
--- a/gcc/ada/libgnat/s-pack109.ads
+++ b/gcc/ada/libgnat/s-pack109.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 ca2b3ad..ed3b901 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 e565d80..6298e49 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-pack110.adb b/gcc/ada/libgnat/s-pack110.adb
index a85eb3d..c88fdd5 100644
--- a/gcc/ada/libgnat/s-pack110.adb
+++ b/gcc/ada/libgnat/s-pack110.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-pack110.ads b/gcc/ada/libgnat/s-pack110.ads
index 570a994..74a5cf5 100644
--- a/gcc/ada/libgnat/s-pack110.ads
+++ b/gcc/ada/libgnat/s-pack110.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-pack111.adb b/gcc/ada/libgnat/s-pack111.adb
index 168877b..b760b90 100644
--- a/gcc/ada/libgnat/s-pack111.adb
+++ b/gcc/ada/libgnat/s-pack111.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-pack111.ads b/gcc/ada/libgnat/s-pack111.ads
index 784b861..a653ed4 100644
--- a/gcc/ada/libgnat/s-pack111.ads
+++ b/gcc/ada/libgnat/s-pack111.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-pack112.adb b/gcc/ada/libgnat/s-pack112.adb
index b8acf56..f6880fe 100644
--- a/gcc/ada/libgnat/s-pack112.adb
+++ b/gcc/ada/libgnat/s-pack112.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-pack112.ads b/gcc/ada/libgnat/s-pack112.ads
index 6b36a8b..fdc5349 100644
--- a/gcc/ada/libgnat/s-pack112.ads
+++ b/gcc/ada/libgnat/s-pack112.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-pack113.adb b/gcc/ada/libgnat/s-pack113.adb
index 58f84d4..d34b7d7 100644
--- a/gcc/ada/libgnat/s-pack113.adb
+++ b/gcc/ada/libgnat/s-pack113.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-pack113.ads b/gcc/ada/libgnat/s-pack113.ads
index 2f0bfc2..5c864af 100644
--- a/gcc/ada/libgnat/s-pack113.ads
+++ b/gcc/ada/libgnat/s-pack113.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-pack114.adb b/gcc/ada/libgnat/s-pack114.adb
index 079abeb..b74a46e 100644
--- a/gcc/ada/libgnat/s-pack114.adb
+++ b/gcc/ada/libgnat/s-pack114.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-pack114.ads b/gcc/ada/libgnat/s-pack114.ads
index 046026e..89bdec7 100644
--- a/gcc/ada/libgnat/s-pack114.ads
+++ b/gcc/ada/libgnat/s-pack114.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-pack115.adb b/gcc/ada/libgnat/s-pack115.adb
index 0459777..882ce51 100644
--- a/gcc/ada/libgnat/s-pack115.adb
+++ b/gcc/ada/libgnat/s-pack115.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-pack115.ads b/gcc/ada/libgnat/s-pack115.ads
index a2063a6..3ace3c4 100644
--- a/gcc/ada/libgnat/s-pack115.ads
+++ b/gcc/ada/libgnat/s-pack115.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-pack116.adb b/gcc/ada/libgnat/s-pack116.adb
index d03c857..f5c5aaa 100644
--- a/gcc/ada/libgnat/s-pack116.adb
+++ b/gcc/ada/libgnat/s-pack116.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-pack116.ads b/gcc/ada/libgnat/s-pack116.ads
index 3cd556d..fd219cb 100644
--- a/gcc/ada/libgnat/s-pack116.ads
+++ b/gcc/ada/libgnat/s-pack116.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-pack117.adb b/gcc/ada/libgnat/s-pack117.adb
index 92da470..817616f 100644
--- a/gcc/ada/libgnat/s-pack117.adb
+++ b/gcc/ada/libgnat/s-pack117.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-pack117.ads b/gcc/ada/libgnat/s-pack117.ads
index 478663a..c7f03cc 100644
--- a/gcc/ada/libgnat/s-pack117.ads
+++ b/gcc/ada/libgnat/s-pack117.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-pack118.adb b/gcc/ada/libgnat/s-pack118.adb
index aa1d763..0b4003d 100644
--- a/gcc/ada/libgnat/s-pack118.adb
+++ b/gcc/ada/libgnat/s-pack118.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-pack118.ads b/gcc/ada/libgnat/s-pack118.ads
index 0902c5c..3f5d0e1 100644
--- a/gcc/ada/libgnat/s-pack118.ads
+++ b/gcc/ada/libgnat/s-pack118.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-pack119.adb b/gcc/ada/libgnat/s-pack119.adb
index 9003175..250f895 100644
--- a/gcc/ada/libgnat/s-pack119.adb
+++ b/gcc/ada/libgnat/s-pack119.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-pack119.ads b/gcc/ada/libgnat/s-pack119.ads
index 75d1c4a..6821bd5 100644
--- a/gcc/ada/libgnat/s-pack119.ads
+++ b/gcc/ada/libgnat/s-pack119.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 d53e9a3..66c9dc1 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 84323be..3808774 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-pack120.adb b/gcc/ada/libgnat/s-pack120.adb
index 774085c..ad87b96 100644
--- a/gcc/ada/libgnat/s-pack120.adb
+++ b/gcc/ada/libgnat/s-pack120.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-pack120.ads b/gcc/ada/libgnat/s-pack120.ads
index ae5580a..b49d3bb 100644
--- a/gcc/ada/libgnat/s-pack120.ads
+++ b/gcc/ada/libgnat/s-pack120.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-pack121.adb b/gcc/ada/libgnat/s-pack121.adb
index a44f144..baeac89 100644
--- a/gcc/ada/libgnat/s-pack121.adb
+++ b/gcc/ada/libgnat/s-pack121.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-pack121.ads b/gcc/ada/libgnat/s-pack121.ads
index 5f4f5ed..a05586b 100644
--- a/gcc/ada/libgnat/s-pack121.ads
+++ b/gcc/ada/libgnat/s-pack121.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-pack122.adb b/gcc/ada/libgnat/s-pack122.adb
index 13c59ac..7cb7ef6 100644
--- a/gcc/ada/libgnat/s-pack122.adb
+++ b/gcc/ada/libgnat/s-pack122.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-pack122.ads b/gcc/ada/libgnat/s-pack122.ads
index 0094896..57a4575 100644
--- a/gcc/ada/libgnat/s-pack122.ads
+++ b/gcc/ada/libgnat/s-pack122.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-pack123.adb b/gcc/ada/libgnat/s-pack123.adb
index 27d7417..630cc7e 100644
--- a/gcc/ada/libgnat/s-pack123.adb
+++ b/gcc/ada/libgnat/s-pack123.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-pack123.ads b/gcc/ada/libgnat/s-pack123.ads
index f40fe87..b35eb86 100644
--- a/gcc/ada/libgnat/s-pack123.ads
+++ b/gcc/ada/libgnat/s-pack123.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-pack124.adb b/gcc/ada/libgnat/s-pack124.adb
index 2e6d9c0..8ca12eb 100644
--- a/gcc/ada/libgnat/s-pack124.adb
+++ b/gcc/ada/libgnat/s-pack124.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-pack124.ads b/gcc/ada/libgnat/s-pack124.ads
index 3a4f159..12cfee1 100644
--- a/gcc/ada/libgnat/s-pack124.ads
+++ b/gcc/ada/libgnat/s-pack124.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-pack125.adb b/gcc/ada/libgnat/s-pack125.adb
index ffc2c1c..32193d9 100644
--- a/gcc/ada/libgnat/s-pack125.adb
+++ b/gcc/ada/libgnat/s-pack125.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-pack125.ads b/gcc/ada/libgnat/s-pack125.ads
index dc4fdc9..b06dfcf 100644
--- a/gcc/ada/libgnat/s-pack125.ads
+++ b/gcc/ada/libgnat/s-pack125.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-pack126.adb b/gcc/ada/libgnat/s-pack126.adb
index c566fc9..c5529f4 100644
--- a/gcc/ada/libgnat/s-pack126.adb
+++ b/gcc/ada/libgnat/s-pack126.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-pack126.ads b/gcc/ada/libgnat/s-pack126.ads
index fd83f78..a9a4edc 100644
--- a/gcc/ada/libgnat/s-pack126.ads
+++ b/gcc/ada/libgnat/s-pack126.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-pack127.adb b/gcc/ada/libgnat/s-pack127.adb
index 3895c1f..3a261df 100644
--- a/gcc/ada/libgnat/s-pack127.adb
+++ b/gcc/ada/libgnat/s-pack127.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-pack127.ads b/gcc/ada/libgnat/s-pack127.ads
index c37ae59..9f37b9a 100644
--- a/gcc/ada/libgnat/s-pack127.ads
+++ b/gcc/ada/libgnat/s-pack127.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 9d9ee0e..72aec3f 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 bb56cfc..e68e0c2 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 cceb09e..919a59a 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 3c1c8e2..63f0929 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 0e91afc..231cb71 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 fb73d29..0b3f4e3 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 7ba49ca..28b1ecd 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 f47c7bd..5aa9bf7 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 e4b7d9f..bc077bb5 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 2e196bf..b96eccc 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 50336a9..cd424b2 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 58d7837..6c5df71 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 a2a2fda..2577f5a 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 10d75e8..558d0d7 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 a7011ee..de2974d 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 eee9f6d..be56b08 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 d41ed28..0dd92d0 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 79b92d4..8d0e3d7 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 b15950d..54cced1 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 ec08bd9..eaf1b3b 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 c2a320d..2523a86 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 c26a0e6..d690cac 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 99f1bb1..6c97572f 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 2b6c7e2..04ec3a9 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 6c80c55..24381f3 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 150e331..e0d590a 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 f3c51b0..720d017 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 8ce481b..320ec17 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 7a11643..fd0defb 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 763b1d0..8a4d168 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 e4209a2..e5dfa33 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 f977d80..40f640a 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 577012f..1ce3ea9 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 fc5965b..5d6b7cb 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 debf3db..b754b69 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 22db441..7bc763c 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 f2afef0..27d6e05 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 5d8cb4d..a063099 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 2f9580a..953b001 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 cd5d7fa..4e87915 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 49cad6f..ba0a0e6 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 21ca7d4..eca6935 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 bdb3fe3..b273b09 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 924268f..a8e9739 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 7f1ead5..5a5a1da 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 089434f..b5ade3f 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 f3feac3..d2bd084 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 bb1c504..6a629190 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 821d954..647610c 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 bac16de..c97fc9e 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 b7a9e02..097d58c 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 bb367d6..4d3c43f 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 28a0def..5d6ff71 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 ce92fd9..8e54781 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 c759f94..d059ded 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 a1c58ab..1c20804 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 137ce06..3b58202 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 c586e47..f7b80fc 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 d8eaaac..90aee39 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 e3873ee..0f2ce7e 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 3739136..cfc75fb 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 dfdd7a9..d95e52a 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 1bae1b9..4b7dc25 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 81c00df..38f6897 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 e5ab870..d6ab3fd 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 0de9bc6..6b2141d 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 0ca74f5..088474c 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 225789a..67ed8ba 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 f475e62..c73cac5 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 6ad4144..9b9db07 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 2e55724..2f5704c 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 bb3049a..65203a3 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 9af3cb7..4c474c5 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 70506d2..0b2b99e 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 1d6becb..b4c313a 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 40d9142..04f1289 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 a2771a1..3b1b699 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 5512185..3c794d7 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 06d3aeb..33eafe4 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 52b29ae..046ca04 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 6e2b628..400e55c 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 97115c6..5421a2e 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 b8ecc0b..f2d7814 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 510fc35..10539e7 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 2402e8b..e151840 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 8ac91c7..a93ae11 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 75f00a1..3c9f73d 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 d8d6e91..2949cc3 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 ec001fa..b54b1ff 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 ee00f65..5bdf60c 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 35b93f5..b543ac5 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 95e0fd2..0362a3c 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 89b94ac..aa631c5 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 5681500..6d0d4c7 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 da6932a..66dd8a1 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 121c26f..826df31 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 37b6767..b4a210b 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 7ca3d03..9a8e5c4 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-pack65.adb b/gcc/ada/libgnat/s-pack65.adb
index c5b7310..33e4dbd 100644
--- a/gcc/ada/libgnat/s-pack65.adb
+++ b/gcc/ada/libgnat/s-pack65.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-pack65.ads b/gcc/ada/libgnat/s-pack65.ads
index 8752c9c..023208d 100644
--- a/gcc/ada/libgnat/s-pack65.ads
+++ b/gcc/ada/libgnat/s-pack65.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-pack66.adb b/gcc/ada/libgnat/s-pack66.adb
index 5e90ceb..80a7ce4 100644
--- a/gcc/ada/libgnat/s-pack66.adb
+++ b/gcc/ada/libgnat/s-pack66.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-pack66.ads b/gcc/ada/libgnat/s-pack66.ads
index b45d317..9ae24a8 100644
--- a/gcc/ada/libgnat/s-pack66.ads
+++ b/gcc/ada/libgnat/s-pack66.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-pack67.adb b/gcc/ada/libgnat/s-pack67.adb
index d7c77e8..c7ec770 100644
--- a/gcc/ada/libgnat/s-pack67.adb
+++ b/gcc/ada/libgnat/s-pack67.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-pack67.ads b/gcc/ada/libgnat/s-pack67.ads
index f77b651..33ecc80 100644
--- a/gcc/ada/libgnat/s-pack67.ads
+++ b/gcc/ada/libgnat/s-pack67.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-pack68.adb b/gcc/ada/libgnat/s-pack68.adb
index 03a0361..d0180ab 100644
--- a/gcc/ada/libgnat/s-pack68.adb
+++ b/gcc/ada/libgnat/s-pack68.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-pack68.ads b/gcc/ada/libgnat/s-pack68.ads
index 5565b32..62eeb61 100644
--- a/gcc/ada/libgnat/s-pack68.ads
+++ b/gcc/ada/libgnat/s-pack68.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-pack69.adb b/gcc/ada/libgnat/s-pack69.adb
index f383029..3342385 100644
--- a/gcc/ada/libgnat/s-pack69.adb
+++ b/gcc/ada/libgnat/s-pack69.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-pack69.ads b/gcc/ada/libgnat/s-pack69.ads
index 76a221d..5819f20 100644
--- a/gcc/ada/libgnat/s-pack69.ads
+++ b/gcc/ada/libgnat/s-pack69.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-pack70.adb b/gcc/ada/libgnat/s-pack70.adb
index 7dab227..6071a50 100644
--- a/gcc/ada/libgnat/s-pack70.adb
+++ b/gcc/ada/libgnat/s-pack70.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-pack70.ads b/gcc/ada/libgnat/s-pack70.ads
index b978d1c..d6cfed9 100644
--- a/gcc/ada/libgnat/s-pack70.ads
+++ b/gcc/ada/libgnat/s-pack70.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-pack71.adb b/gcc/ada/libgnat/s-pack71.adb
index f3560de..017d584 100644
--- a/gcc/ada/libgnat/s-pack71.adb
+++ b/gcc/ada/libgnat/s-pack71.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-pack71.ads b/gcc/ada/libgnat/s-pack71.ads
index 842a232..89147c4 100644
--- a/gcc/ada/libgnat/s-pack71.ads
+++ b/gcc/ada/libgnat/s-pack71.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-pack72.adb b/gcc/ada/libgnat/s-pack72.adb
index 14fbb15..1d60757 100644
--- a/gcc/ada/libgnat/s-pack72.adb
+++ b/gcc/ada/libgnat/s-pack72.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-pack72.ads b/gcc/ada/libgnat/s-pack72.ads
index b1add35..a5f47e3 100644
--- a/gcc/ada/libgnat/s-pack72.ads
+++ b/gcc/ada/libgnat/s-pack72.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-pack73.adb b/gcc/ada/libgnat/s-pack73.adb
index f4853cb..46e9c63 100644
--- a/gcc/ada/libgnat/s-pack73.adb
+++ b/gcc/ada/libgnat/s-pack73.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-pack73.ads b/gcc/ada/libgnat/s-pack73.ads
index 5f103de..a5fb008 100644
--- a/gcc/ada/libgnat/s-pack73.ads
+++ b/gcc/ada/libgnat/s-pack73.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-pack74.adb b/gcc/ada/libgnat/s-pack74.adb
index 984b4c0..4973866 100644
--- a/gcc/ada/libgnat/s-pack74.adb
+++ b/gcc/ada/libgnat/s-pack74.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-pack74.ads b/gcc/ada/libgnat/s-pack74.ads
index 5dde51b..55c394f 100644
--- a/gcc/ada/libgnat/s-pack74.ads
+++ b/gcc/ada/libgnat/s-pack74.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-pack75.adb b/gcc/ada/libgnat/s-pack75.adb
index 6c7c14f..e6b6467 100644
--- a/gcc/ada/libgnat/s-pack75.adb
+++ b/gcc/ada/libgnat/s-pack75.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-pack75.ads b/gcc/ada/libgnat/s-pack75.ads
index 551833a..97249ec 100644
--- a/gcc/ada/libgnat/s-pack75.ads
+++ b/gcc/ada/libgnat/s-pack75.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-pack76.adb b/gcc/ada/libgnat/s-pack76.adb
index 6a7c5fa..b94586a 100644
--- a/gcc/ada/libgnat/s-pack76.adb
+++ b/gcc/ada/libgnat/s-pack76.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-pack76.ads b/gcc/ada/libgnat/s-pack76.ads
index 6a600c9..4cde3f3 100644
--- a/gcc/ada/libgnat/s-pack76.ads
+++ b/gcc/ada/libgnat/s-pack76.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-pack77.adb b/gcc/ada/libgnat/s-pack77.adb
index f29cdf1..6b660ea 100644
--- a/gcc/ada/libgnat/s-pack77.adb
+++ b/gcc/ada/libgnat/s-pack77.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-pack77.ads b/gcc/ada/libgnat/s-pack77.ads
index 9308a78..e5a1277 100644
--- a/gcc/ada/libgnat/s-pack77.ads
+++ b/gcc/ada/libgnat/s-pack77.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-pack78.adb b/gcc/ada/libgnat/s-pack78.adb
index e321c1e..03f6fbd 100644
--- a/gcc/ada/libgnat/s-pack78.adb
+++ b/gcc/ada/libgnat/s-pack78.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-pack78.ads b/gcc/ada/libgnat/s-pack78.ads
index 54fdd95..564f5c8 100644
--- a/gcc/ada/libgnat/s-pack78.ads
+++ b/gcc/ada/libgnat/s-pack78.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-pack79.adb b/gcc/ada/libgnat/s-pack79.adb
index 75fb14c..d2eecb2 100644
--- a/gcc/ada/libgnat/s-pack79.adb
+++ b/gcc/ada/libgnat/s-pack79.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-pack79.ads b/gcc/ada/libgnat/s-pack79.ads
index 337be86..909e992 100644
--- a/gcc/ada/libgnat/s-pack79.ads
+++ b/gcc/ada/libgnat/s-pack79.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-pack80.adb b/gcc/ada/libgnat/s-pack80.adb
index d66588b..f5d98d0 100644
--- a/gcc/ada/libgnat/s-pack80.adb
+++ b/gcc/ada/libgnat/s-pack80.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-pack80.ads b/gcc/ada/libgnat/s-pack80.ads
index c1f0de4..5021045 100644
--- a/gcc/ada/libgnat/s-pack80.ads
+++ b/gcc/ada/libgnat/s-pack80.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-pack81.adb b/gcc/ada/libgnat/s-pack81.adb
index 5157882..8c564d8 100644
--- a/gcc/ada/libgnat/s-pack81.adb
+++ b/gcc/ada/libgnat/s-pack81.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-pack81.ads b/gcc/ada/libgnat/s-pack81.ads
index 9f17734..03009c3 100644
--- a/gcc/ada/libgnat/s-pack81.ads
+++ b/gcc/ada/libgnat/s-pack81.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-pack82.adb b/gcc/ada/libgnat/s-pack82.adb
index 7e409dd..21180b7 100644
--- a/gcc/ada/libgnat/s-pack82.adb
+++ b/gcc/ada/libgnat/s-pack82.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-pack82.ads b/gcc/ada/libgnat/s-pack82.ads
index 96a75bf..445035d 100644
--- a/gcc/ada/libgnat/s-pack82.ads
+++ b/gcc/ada/libgnat/s-pack82.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-pack83.adb b/gcc/ada/libgnat/s-pack83.adb
index 5fe2441..fdea99e 100644
--- a/gcc/ada/libgnat/s-pack83.adb
+++ b/gcc/ada/libgnat/s-pack83.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-pack83.ads b/gcc/ada/libgnat/s-pack83.ads
index 75ccd5b..dfb4887 100644
--- a/gcc/ada/libgnat/s-pack83.ads
+++ b/gcc/ada/libgnat/s-pack83.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-pack84.adb b/gcc/ada/libgnat/s-pack84.adb
index 29b6454..c72b08e 100644
--- a/gcc/ada/libgnat/s-pack84.adb
+++ b/gcc/ada/libgnat/s-pack84.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-pack84.ads b/gcc/ada/libgnat/s-pack84.ads
index c3055f9..77c9c95 100644
--- a/gcc/ada/libgnat/s-pack84.ads
+++ b/gcc/ada/libgnat/s-pack84.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-pack85.adb b/gcc/ada/libgnat/s-pack85.adb
index 6edf9d1..be9a18c 100644
--- a/gcc/ada/libgnat/s-pack85.adb
+++ b/gcc/ada/libgnat/s-pack85.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-pack85.ads b/gcc/ada/libgnat/s-pack85.ads
index 71bb986..5f516d0 100644
--- a/gcc/ada/libgnat/s-pack85.ads
+++ b/gcc/ada/libgnat/s-pack85.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-pack86.adb b/gcc/ada/libgnat/s-pack86.adb
index 39e8bca..1b64c7c 100644
--- a/gcc/ada/libgnat/s-pack86.adb
+++ b/gcc/ada/libgnat/s-pack86.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-pack86.ads b/gcc/ada/libgnat/s-pack86.ads
index 0dee449..def41d3 100644
--- a/gcc/ada/libgnat/s-pack86.ads
+++ b/gcc/ada/libgnat/s-pack86.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-pack87.adb b/gcc/ada/libgnat/s-pack87.adb
index 8bfc7b4..4cc3b61f 100644
--- a/gcc/ada/libgnat/s-pack87.adb
+++ b/gcc/ada/libgnat/s-pack87.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-pack87.ads b/gcc/ada/libgnat/s-pack87.ads
index ad80713..6c0b83c 100644
--- a/gcc/ada/libgnat/s-pack87.ads
+++ b/gcc/ada/libgnat/s-pack87.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-pack88.adb b/gcc/ada/libgnat/s-pack88.adb
index 638581a..a51bd48 100644
--- a/gcc/ada/libgnat/s-pack88.adb
+++ b/gcc/ada/libgnat/s-pack88.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-pack88.ads b/gcc/ada/libgnat/s-pack88.ads
index bd38bd7..f03323b 100644
--- a/gcc/ada/libgnat/s-pack88.ads
+++ b/gcc/ada/libgnat/s-pack88.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-pack89.adb b/gcc/ada/libgnat/s-pack89.adb
index eff29c0..d2bc53d 100644
--- a/gcc/ada/libgnat/s-pack89.adb
+++ b/gcc/ada/libgnat/s-pack89.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-pack89.ads b/gcc/ada/libgnat/s-pack89.ads
index 5ab8102..bdc668b 100644
--- a/gcc/ada/libgnat/s-pack89.ads
+++ b/gcc/ada/libgnat/s-pack89.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-pack90.adb b/gcc/ada/libgnat/s-pack90.adb
index bed4845..19ec737 100644
--- a/gcc/ada/libgnat/s-pack90.adb
+++ b/gcc/ada/libgnat/s-pack90.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-pack90.ads b/gcc/ada/libgnat/s-pack90.ads
index 2960293..bbabf19 100644
--- a/gcc/ada/libgnat/s-pack90.ads
+++ b/gcc/ada/libgnat/s-pack90.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-pack91.adb b/gcc/ada/libgnat/s-pack91.adb
index 25c9f14..fe20def 100644
--- a/gcc/ada/libgnat/s-pack91.adb
+++ b/gcc/ada/libgnat/s-pack91.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-pack91.ads b/gcc/ada/libgnat/s-pack91.ads
index 065c1b5..b35d96c 100644
--- a/gcc/ada/libgnat/s-pack91.ads
+++ b/gcc/ada/libgnat/s-pack91.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-pack92.adb b/gcc/ada/libgnat/s-pack92.adb
index b9ea0a6..147d628 100644
--- a/gcc/ada/libgnat/s-pack92.adb
+++ b/gcc/ada/libgnat/s-pack92.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-pack92.ads b/gcc/ada/libgnat/s-pack92.ads
index 5184bc6..22424db 100644
--- a/gcc/ada/libgnat/s-pack92.ads
+++ b/gcc/ada/libgnat/s-pack92.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-pack93.adb b/gcc/ada/libgnat/s-pack93.adb
index 1fe486c..8db201a 100644
--- a/gcc/ada/libgnat/s-pack93.adb
+++ b/gcc/ada/libgnat/s-pack93.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-pack93.ads b/gcc/ada/libgnat/s-pack93.ads
index 618ab64..eb4359e 100644
--- a/gcc/ada/libgnat/s-pack93.ads
+++ b/gcc/ada/libgnat/s-pack93.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-pack94.adb b/gcc/ada/libgnat/s-pack94.adb
index 5a65908..53c9f89 100644
--- a/gcc/ada/libgnat/s-pack94.adb
+++ b/gcc/ada/libgnat/s-pack94.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-pack94.ads b/gcc/ada/libgnat/s-pack94.ads
index 692a4dc..01efbca 100644
--- a/gcc/ada/libgnat/s-pack94.ads
+++ b/gcc/ada/libgnat/s-pack94.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-pack95.adb b/gcc/ada/libgnat/s-pack95.adb
index f8d6be6..1179506 100644
--- a/gcc/ada/libgnat/s-pack95.adb
+++ b/gcc/ada/libgnat/s-pack95.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-pack95.ads b/gcc/ada/libgnat/s-pack95.ads
index 288a787..38d54b8 100644
--- a/gcc/ada/libgnat/s-pack95.ads
+++ b/gcc/ada/libgnat/s-pack95.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-pack96.adb b/gcc/ada/libgnat/s-pack96.adb
index 1371ee1..617a91f 100644
--- a/gcc/ada/libgnat/s-pack96.adb
+++ b/gcc/ada/libgnat/s-pack96.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-pack96.ads b/gcc/ada/libgnat/s-pack96.ads
index 355f00a..d19b65b 100644
--- a/gcc/ada/libgnat/s-pack96.ads
+++ b/gcc/ada/libgnat/s-pack96.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-pack97.adb b/gcc/ada/libgnat/s-pack97.adb
index 000f8ed..b7ddb81 100644
--- a/gcc/ada/libgnat/s-pack97.adb
+++ b/gcc/ada/libgnat/s-pack97.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-pack97.ads b/gcc/ada/libgnat/s-pack97.ads
index 4c8a936..c04ecbc 100644
--- a/gcc/ada/libgnat/s-pack97.ads
+++ b/gcc/ada/libgnat/s-pack97.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-pack98.adb b/gcc/ada/libgnat/s-pack98.adb
index 1ac4c66..2c3def5 100644
--- a/gcc/ada/libgnat/s-pack98.adb
+++ b/gcc/ada/libgnat/s-pack98.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-pack98.ads b/gcc/ada/libgnat/s-pack98.ads
index 239eca1..23e08ed 100644
--- a/gcc/ada/libgnat/s-pack98.ads
+++ b/gcc/ada/libgnat/s-pack98.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-pack99.adb b/gcc/ada/libgnat/s-pack99.adb
index a8bde88..26485cf 100644
--- a/gcc/ada/libgnat/s-pack99.adb
+++ b/gcc/ada/libgnat/s-pack99.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-pack99.ads b/gcc/ada/libgnat/s-pack99.ads
index fa805c4..4f49623 100644
--- a/gcc/ada/libgnat/s-pack99.ads
+++ b/gcc/ada/libgnat/s-pack99.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 c555a82..9001626 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1995-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 f9bc3d0..0f76a65 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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,13 @@ package System.Parameters is
-- Indicates if secondary stacks can grow and shrink at run-time. If False,
-- the size of a secondary stack is fixed at the point of its creation.
+ ------------------------------------
+ -- Characteristics of time_t type --
+ ------------------------------------
+
+ time_t_bits : constant := Long_Integer'Size;
+ -- Number of bits in type time_t
+
----------------------------------------------
-- Characteristics of types in Interfaces.C --
----------------------------------------------
diff --git a/gcc/ada/libgnat/s-parame__ae653.ads b/gcc/ada/libgnat/s-parame__ae653.ads
index 3e73f5e..f838b41 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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,13 @@ package System.Parameters is
-- Indicates if secondary stacks can grow and shrink at run-time. If False,
-- the size of a secondary stack is fixed at the point of its creation.
+ ------------------------------------
+ -- Characteristics of time_t type --
+ ------------------------------------
+
+ time_t_bits : constant := Long_Integer'Size;
+ -- Number of bits in type time_t
+
----------------------------------------------
-- Characteristics of types in Interfaces.C --
----------------------------------------------
diff --git a/gcc/ada/libgnat/s-parame__hpux.ads b/gcc/ada/libgnat/s-parame__hpux.ads
index e09313f..d6d4e10 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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,6 +98,13 @@ package System.Parameters is
-- Indicates if secondary stacks can grow and shrink at run-time. If False,
-- the size of a secondary stack is fixed at the point of its creation.
+ ------------------------------------
+ -- Characteristics of time_t type --
+ ------------------------------------
+
+ time_t_bits : constant := Long_Integer'Size;
+ -- Number of bits in type time_t
+
----------------------------------------------
-- Characteristics of Types in Interfaces.C --
----------------------------------------------
diff --git a/gcc/ada/libgnat/s-parame__posix2008.ads b/gcc/ada/libgnat/s-parame__posix2008.ads
new file mode 100644
index 0000000..af299ec
--- /dev/null
+++ b/gcc/ada/libgnat/s-parame__posix2008.ads
@@ -0,0 +1,193 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S Y S T E M . P A R A M E T E R S --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
+-- --
+-- GNAT is 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 the Posix 2008 version for 64 bit time_t.
+
+-- This package defines some system dependent parameters for GNAT. These
+-- are values that are referenced by the runtime library and are therefore
+-- relevant to the target machine.
+
+-- The parameters whose value is defined in the spec are not generally
+-- expected to be changed. If they are changed, it will be necessary to
+-- recompile the run-time library.
+
+-- The parameters which are defined by functions can be changed by modifying
+-- the body of System.Parameters in file s-parame.adb. A change to this body
+-- requires only rebinding and relinking of the application.
+
+-- Note: do not introduce any pragma Inline statements into this unit, since
+-- otherwise the relinking and rebinding capability would be deactivated.
+
+pragma Compiler_Unit_Warning;
+
+package System.Parameters is
+ pragma Pure;
+
+ ---------------------------------------
+ -- Task And Stack Allocation Control --
+ ---------------------------------------
+
+ type Size_Type is range
+ -(2 ** (Integer'(Standard'Address_Size) - 1)) ..
+ +(2 ** (Integer'(Standard'Address_Size) - 1)) - 1;
+ -- Type used to provide task stack sizes to the runtime. Sized to permit
+ -- stack sizes of up to half the total addressable memory space. This may
+ -- seem excessively large (even for 32-bit systems), however there are many
+ -- instances of users requiring large stack sizes (for example string
+ -- processing).
+
+ Unspecified_Size : constant Size_Type := Size_Type'First;
+ -- Value used to indicate that no size type is set
+
+ function Default_Stack_Size return Size_Type;
+ -- Default task stack size used if none is specified
+
+ function Minimum_Stack_Size return Size_Type;
+ -- Minimum task stack size permitted
+
+ function Adjust_Storage_Size (Size : Size_Type) return Size_Type;
+ -- Given the storage size stored in the TCB, return the Storage_Size
+ -- value required by the RM for the Storage_Size attribute. The
+ -- required adjustment is as follows:
+ --
+ -- when Size = Unspecified_Size, return Default_Stack_Size
+ -- when Size < Minimum_Stack_Size, return Minimum_Stack_Size
+ -- otherwise return given Size
+
+ Default_Env_Stack_Size : constant Size_Type := 8_192_000;
+ -- Assumed size of the environment task, if no other information is
+ -- available. This value is used when stack checking is enabled and
+ -- no GNAT_STACK_LIMIT environment variable is set.
+
+ Stack_Grows_Down : constant Boolean := True;
+ -- This constant indicates whether the stack grows up (False) or
+ -- down (True) in memory as functions are called. It is used for
+ -- proper implementation of the stack overflow check.
+
+ Runtime_Default_Sec_Stack_Size : constant Size_Type := 10 * 1024;
+ -- The run-time chosen default size for secondary stacks that may be
+ -- 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,
+ -- the size of a secondary stack is fixed at the point of its creation.
+
+ ------------------------------------
+ -- Characteristics of time_t type --
+ ------------------------------------
+
+ time_t_bits : constant := Long_Long_Integer'Size;
+ -- Number of bits in type time_t. Use for targets that are Posix 2008
+ -- compliant (fixes the year 2038 time_t overflow).
+
+ ----------------------------------------------
+ -- Characteristics of types in Interfaces.C --
+ ----------------------------------------------
+
+ long_bits : constant := Long_Integer'Size;
+ -- Number of bits in type long and unsigned_long. The normal convention
+ -- is that this is the same as type Long_Integer, but this may not be true
+ -- of all targets.
+
+ ptr_bits : constant := Standard'Address_Size;
+ subtype C_Address is System.Address;
+ -- Number of bits in Interfaces.C pointers, normally a standard address
+
+ C_Malloc_Linkname : constant String := "__gnat_malloc";
+ -- Name of runtime function used to allocate such a pointer
+
+ ----------------------------------------------
+ -- Behavior of Pragma Finalize_Storage_Only --
+ ----------------------------------------------
+
+ -- Garbage_Collected is a Boolean constant whose value indicates the
+ -- effect of the pragma Finalize_Storage_Entry on a controlled type.
+
+ -- Garbage_Collected = False
+
+ -- The system releases all storage on program termination only,
+ -- but not other garbage collection occurs, so finalization calls
+ -- are omitted only for outer level objects can be omitted if
+ -- pragma Finalize_Storage_Only is used.
+
+ -- Garbage_Collected = True
+
+ -- The system provides full garbage collection, so it is never
+ -- necessary to release storage for controlled objects for which
+ -- a pragma Finalize_Storage_Only is used.
+
+ Garbage_Collected : constant Boolean := False;
+ -- The storage mode for this system (release on program exit)
+
+ ---------------------
+ -- Tasking Profile --
+ ---------------------
+
+ -- In the following sections, constant parameters are defined to
+ -- allow some optimizations and fine tuning within the tasking run time
+ -- based on restrictions on the tasking features.
+
+ -------------------
+ -- Task Abortion --
+ -------------------
+
+ No_Abort : constant Boolean := False;
+ -- This constant indicates whether abort statements and asynchronous
+ -- transfer of control (ATC) are disallowed. If set to True, it is
+ -- assumed that neither construct is used, and the run time does not
+ -- need to defer/undefer abort and check for pending actions at
+ -- completion points. A value of True for No_Abort corresponds to:
+ -- pragma Restrictions (No_Abort_Statements);
+ -- pragma Restrictions (Max_Asynchronous_Select_Nesting => 0);
+
+ ---------------------
+ -- Task Attributes --
+ ---------------------
+
+ Max_Attribute_Count : constant := 32;
+ -- Number of task attributes stored in the task control block
+
+ -----------------------
+ -- Task Image Length --
+ -----------------------
+
+ Max_Task_Image_Length : constant := 256;
+ -- This constant specifies the maximum length of a task's image
+
+ ------------------------------
+ -- Exception Message Length --
+ ------------------------------
+
+ Default_Exception_Msg_Max_Length : constant := 200;
+ -- This constant specifies the default number of characters to allow
+ -- in an exception message (200 is minimum required by RM 11.4.1(18)).
+
+end System.Parameters;
diff --git a/gcc/ada/libgnat/s-parame__rtems.adb b/gcc/ada/libgnat/s-parame__rtems.adb
index f350343..1a6d577 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1997-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 7d0a206..5970eb0 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1995-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 c836444..11b408b 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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,21 @@ package System.Parameters is
-- Indicates if secondary stacks can grow and shrink at run-time. If False,
-- the size of a secondary stack is fixed at the point of its creation.
+ ------------------------------------
+ -- Characteristics of time_t type --
+ ------------------------------------
+
+ -- IMPORTANT NOTE:
+ -- Select the appropriate time_t_bits for the VSB in use, then rebuild
+ -- the runtime using instructions in adainclude/libada.gpr.
+
+ time_t_bits : constant := Long_Integer'Size;
+ -- Number of bits in type time_t for SR0650 and before and SR0660 with
+ -- non-default configuration.
+
+ -- time_t_bits : constant := Long_Long_Integer'Size;
+ -- Number of bits in type time_t for SR0660 with default configuration.
+
----------------------------------------------
-- Characteristics of types in Interfaces.C --
----------------------------------------------
diff --git a/gcc/ada/libgnat/s-parint.adb b/gcc/ada/libgnat/s-parint.adb
index f984a49..24e8d1b 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1995-2021, 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 b037571..f311a09 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1995-2021, 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-pehage.adb b/gcc/ada/libgnat/s-pehage.adb
new file mode 100644
index 0000000..218c1cb
--- /dev/null
+++ b/gcc/ada/libgnat/s-pehage.adb
@@ -0,0 +1,2235 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S Y S T E M . P E R F E C T _ H A S H _ G E N E R A T O R S --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 2002-2021, 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- --
+-- 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 GNAT.Heap_Sort_G;
+with GNAT.Table;
+
+with System.OS_Lib; use System.OS_Lib;
+
+package body System.Perfect_Hash_Generators is
+
+ -- We are using the algorithm of J. Czech as described in Zbigniew J.
+ -- Czech, George Havas, and Bohdan S. Majewski ``An Optimal Algorithm for
+ -- Generating Minimal Perfect Hash Functions'', Information Processing
+ -- Letters, 43(1992) pp.257-264, Oct.1992
+
+ -- This minimal perfect hash function generator is based on random graphs
+ -- and produces a hash function of the form:
+
+ -- h (w) = (g (f1 (w)) + g (f2 (w))) mod m
+
+ -- where f1 and f2 are functions that map strings into integers, and g is
+ -- a function that maps integers into [0, m-1]. h can be order preserving.
+ -- For instance, let W = {w_0, ..., w_i, ..., w_m-1}, h can be defined
+ -- such that h (w_i) = i.
+
+ -- This algorithm defines two possible constructions of f1 and f2. Method
+ -- b) stores the hash function in less memory space at the expense of
+ -- greater CPU time.
+
+ -- a) fk (w) = sum (for i in 1 .. length (w)) (Tk (i, w (i))) mod n
+
+ -- size (Tk) = max (for w in W) (length (w)) * size (used char set)
+
+ -- b) fk (w) = sum (for i in 1 .. length (w)) (Tk (i) * w (i)) mod n
+
+ -- size (Tk) = max (for w in W) (length (w)) but the table lookups are
+ -- replaced by multiplications.
+
+ -- where Tk values are randomly generated. n is defined later on but the
+ -- algorithm recommends to use a value a little bit greater than 2m. Note
+ -- that for large values of m, the main memory space requirements comes
+ -- from the memory space for storing function g (>= 2m entries).
+
+ -- Random graphs are frequently used to solve difficult problems that do
+ -- not have polynomial solutions. This algorithm is based on a weighted
+ -- undirected graph. It comprises two steps: mapping and assignment.
+
+ -- In the mapping step, a graph G = (V, E) is constructed, where = {0, 1,
+ -- ..., n-1} and E = {(for w in W) (f1 (w), f2 (w))}. In order for the
+ -- assignment step to be successful, G has to be acyclic. To have a high
+ -- probability of generating an acyclic graph, n >= 2m. If it is not
+ -- acyclic, Tk have to be regenerated.
+
+ -- In the assignment step, the algorithm builds function g. As G is
+ -- acyclic, there is a vertex v1 with only one neighbor v2. Let w_i be
+ -- the word such that v1 = f1 (w_i) and v2 = f2 (w_i). Let g (v1) = 0 by
+ -- construction and g (v2) = (i - g (v1)) mod n (or h (i) - g (v1) mod n).
+ -- If word w_j is such that v2 = f1 (w_j) and v3 = f2 (w_j), g (v3) = (j -
+ -- g (v2)) mod (or to be general, (h (j) - g (v2)) mod n). If w_i has no
+ -- neighbor, then another vertex is selected. The algorithm traverses G to
+ -- assign values to all the vertices. It cannot assign a value to an
+ -- already assigned vertex as G is acyclic.
+
+ subtype Word_Id is Integer;
+ subtype Key_Id is Integer;
+ subtype Vertex_Id is Integer;
+ subtype Edge_Id is Integer;
+ subtype Table_Id is Integer;
+
+ No_Vertex : constant Vertex_Id := -1;
+ No_Edge : constant Edge_Id := -1;
+ No_Table : constant Table_Id := -1;
+
+ type Word_Type is new String_Access;
+ procedure Free_Word (W : in out Word_Type) renames Free;
+ function New_Word (S : String) return Word_Type;
+
+ procedure Resize_Word (W : in out Word_Type; Len : Natural);
+ -- Resize string W to have a length Len
+
+ type Key_Type is record
+ Edge : Edge_Id;
+ end record;
+ -- A key corresponds to an edge in the algorithm graph
+
+ type Vertex_Type is record
+ First : Edge_Id;
+ Last : Edge_Id;
+ end record;
+ -- A vertex can be involved in several edges. First and Last are the bounds
+ -- of an array of edges stored in a global edge table.
+
+ type Edge_Type is record
+ X : Vertex_Id;
+ Y : Vertex_Id;
+ Key : Key_Id;
+ end record;
+ -- An edge is a peer of vertices. In the algorithm, a key is associated to
+ -- an edge.
+
+ package WT is new GNAT.Table (Word_Type, Word_Id, 0, 32, 32);
+ package IT is new GNAT.Table (Integer, Integer, 0, 32, 32);
+ -- The two main tables. WT is used to store the words in their initial
+ -- version and in their reduced version (that is words reduced to their
+ -- significant characters). As an instance of GNAT.Table, WT does not
+ -- initialize string pointers to null. This initialization has to be done
+ -- manually when the table is allocated. IT is used to store several
+ -- tables of components containing only integers.
+
+ function Image (Int : Integer; W : Natural := 0) return String;
+ function Image (Str : String; W : Natural := 0) return String;
+ -- Return a string which includes string Str or integer Int preceded by
+ -- leading spaces if required by width W.
+
+ function Trim_Trailing_Nuls (Str : String) return String;
+ -- Return Str with trailing NUL characters removed
+
+ Output : File_Descriptor renames System.OS_Lib.Standout;
+ -- Shortcuts
+
+ EOL : constant Character := ASCII.LF;
+
+ Max : constant := 78;
+ Last : Natural := 0;
+ Line : String (1 .. Max);
+ -- Use this line to provide buffered IO
+
+ procedure Add (C : Character);
+ procedure Add (S : String);
+ -- Add a character or a string in Line and update Last
+
+ procedure Put
+ (F : File_Descriptor;
+ S : String;
+ F1 : Natural;
+ L1 : Natural;
+ C1 : Natural;
+ F2 : Natural;
+ L2 : Natural;
+ C2 : Natural);
+ -- Write string S into file F as a element of an array of one or two
+ -- dimensions. Fk (resp. Lk and Ck) indicates the first (resp last and
+ -- current) index in the k-th dimension. If F1 = L1 the array is considered
+ -- as a one dimension array. This dimension is described by F2 and L2. This
+ -- routine takes care of all the parenthesis, spaces and commas needed to
+ -- format correctly the array. Moreover, the array is well indented and is
+ -- wrapped to fit in a 80 col line. When the line is full, the routine
+ -- writes it into file F. When the array is completed, the routine adds
+ -- semi-colon and writes the line into file F.
+
+ procedure New_Line (File : File_Descriptor);
+ -- Simulate Ada.Text_IO.New_Line with GNAT.OS_Lib
+
+ procedure Put (File : File_Descriptor; Str : String);
+ -- Simulate Ada.Text_IO.Put with GNAT.OS_Lib
+
+ procedure Put_Used_Char_Set (File : File_Descriptor; Title : String);
+ -- Output a title and a used character set
+
+ procedure Put_Int_Vector
+ (File : File_Descriptor;
+ Title : String;
+ Vector : Integer;
+ Length : Natural);
+ -- Output a title and a vector
+
+ procedure Put_Int_Matrix
+ (File : File_Descriptor;
+ Title : String;
+ Table : Table_Id;
+ Len_1 : Natural;
+ Len_2 : Natural);
+ -- Output a title and a matrix. When the matrix has only one non-empty
+ -- dimension (Len_2 = 0), output a vector.
+
+ procedure Put_Edges (File : File_Descriptor; Title : String);
+ -- Output a title and an edge table
+
+ procedure Put_Initial_Keys (File : File_Descriptor; Title : String);
+ -- Output a title and a key table
+
+ procedure Put_Reduced_Keys (File : File_Descriptor; Title : String);
+ -- Output a title and a key table
+
+ procedure Put_Vertex_Table (File : File_Descriptor; Title : String);
+ -- Output a title and a vertex table
+
+ ----------------------------------
+ -- Character Position Selection --
+ ----------------------------------
+
+ -- We reduce the maximum key size by selecting representative positions
+ -- in these keys. We build a matrix with one word per line. We fill the
+ -- remaining space of a line with ASCII.NUL. The heuristic selects the
+ -- position that induces the minimum number of collisions. If there are
+ -- collisions, select another position on the reduced key set responsible
+ -- of the collisions. Apply the heuristic until there is no more collision.
+
+ procedure Apply_Position_Selection;
+ -- Apply Position selection and build the reduced key table
+
+ procedure Parse_Position_Selection (Argument : String);
+ -- Parse Argument and compute the position set. Argument is list of
+ -- substrings separated by commas. Each substring represents a position
+ -- or a range of positions (like x-y).
+
+ procedure Select_Character_Set;
+ -- Define an optimized used character set like Character'Pos in order not
+ -- to allocate tables of 256 entries.
+
+ procedure Select_Char_Position;
+ -- Find a min char position set in order to reduce the max key length. The
+ -- heuristic selects the position that induces the minimum number of
+ -- collisions. If there are collisions, select another position on the
+ -- reduced key set responsible of the collisions. Apply the heuristic until
+ -- there is no collision.
+
+ -----------------------------
+ -- Random Graph Generation --
+ -----------------------------
+
+ procedure Random (Seed : in out Natural);
+ -- Simulate Ada.Discrete_Numerics.Random
+
+ procedure Generate_Mapping_Table
+ (Tab : Table_Id;
+ L1 : Natural;
+ L2 : Natural;
+ Seed : in out Natural);
+ -- Random generation of the tables below. T is already allocated
+
+ procedure Generate_Mapping_Tables
+ (Opt : Optimization;
+ Seed : in out Natural);
+ -- Generate the mapping tables T1 and T2. They are used to define fk (w) =
+ -- sum (for i in 1 .. length (w)) (Tk (i, w (i))) mod n. Keys, NK and Chars
+ -- are used to compute the matrix size.
+
+ ---------------------------
+ -- Algorithm Computation --
+ ---------------------------
+
+ procedure Compute_Edges_And_Vertices (Opt : Optimization);
+ -- Compute the edge and vertex tables. These are empty when a self loop is
+ -- detected (f1 (w) = f2 (w)). The edge table is sorted by X value and then
+ -- Y value. Keys is the key table and NK the number of keys. Chars is the
+ -- set of characters really used in Keys. NV is the number of vertices
+ -- recommended by the algorithm. T1 and T2 are the mapping tables needed to
+ -- compute f1 (w) and f2 (w).
+
+ function Acyclic return Boolean;
+ -- Return True when the graph is acyclic. Vertices is the current vertex
+ -- table and Edges the current edge table.
+
+ procedure Assign_Values_To_Vertices;
+ -- Execute the assignment step of the algorithm. Keys is the current key
+ -- table. Vertices and Edges represent the random graph. G is the result of
+ -- the assignment step such that:
+ -- h (w) = (g (f1 (w)) + g (f2 (w))) mod m
+
+ function Sum
+ (Word : Word_Type;
+ Table : Table_Id;
+ Opt : Optimization) return Natural;
+ -- For an optimization of CPU_Time return
+ -- fk (w) = sum (for i in 1 .. length (w)) (Tk (i, w (i))) mod n
+ -- For an optimization of Memory_Space return
+ -- fk (w) = sum (for i in 1 .. length (w)) (Tk (i) * w (i)) mod n
+ -- Here NV = n
+
+ -------------------------------
+ -- Internal Table Management --
+ -------------------------------
+
+ function Allocate (N : Natural; S : Natural := 1) return Table_Id;
+ -- Allocate N * S ints from IT table
+
+ ----------
+ -- Keys --
+ ----------
+
+ Keys : Table_Id := No_Table;
+ NK : Natural := 0;
+ -- NK : Number of Keys
+
+ function Initial (K : Key_Id) return Word_Id;
+ pragma Inline (Initial);
+
+ function Reduced (K : Key_Id) return Word_Id;
+ pragma Inline (Reduced);
+
+ function Get_Key (N : Key_Id) return Key_Type;
+ procedure Set_Key (N : Key_Id; Item : Key_Type);
+ -- Get or Set Nth element of Keys table
+
+ ------------------
+ -- Char_Pos_Set --
+ ------------------
+
+ Char_Pos_Set : Table_Id := No_Table;
+ Char_Pos_Set_Len : Natural;
+ -- Character Selected Position Set
+
+ function Get_Char_Pos (P : Natural) return Natural;
+ procedure Set_Char_Pos (P : Natural; Item : Natural);
+ -- Get or Set the string position of the Pth selected character
+
+ -------------------
+ -- Used_Char_Set --
+ -------------------
+
+ Used_Char_Set : Table_Id := No_Table;
+ Used_Char_Set_Len : Natural;
+ -- Used Character Set : Define a new character mapping. When all the
+ -- characters are not present in the keys, in order to reduce the size
+ -- of some tables, we redefine the character mapping.
+
+ function Get_Used_Char (C : Character) return Natural;
+ procedure Set_Used_Char (C : Character; Item : Natural);
+
+ ------------
+ -- Tables --
+ ------------
+
+ T1 : Table_Id := No_Table;
+ T2 : Table_Id := No_Table;
+ T1_Len : Natural;
+ T2_Len : Natural;
+ -- T1 : Values table to compute F1
+ -- T2 : Values table to compute F2
+
+ function Get_Table (T : Integer; X, Y : Natural) return Natural;
+ procedure Set_Table (T : Integer; X, Y : Natural; Item : Natural);
+
+ -----------
+ -- Graph --
+ -----------
+
+ G : Table_Id := No_Table;
+ G_Len : Natural;
+ -- Values table to compute G
+
+ NT : Natural;
+ -- Number of tries running the algorithm before raising an error
+
+ function Get_Graph (N : Natural) return Integer;
+ procedure Set_Graph (N : Natural; Item : Integer);
+ -- Get or Set Nth element of graph
+
+ -----------
+ -- Edges --
+ -----------
+
+ Edge_Size : constant := 3;
+ Edges : Table_Id := No_Table;
+ Edges_Len : Natural;
+ -- Edges : Edge table of the random graph G
+
+ function Get_Edges (F : Natural) return Edge_Type;
+ procedure Set_Edges (F : Natural; Item : Edge_Type);
+
+ --------------
+ -- Vertices --
+ --------------
+
+ Vertex_Size : constant := 2;
+
+ Vertices : Table_Id := No_Table;
+ -- Vertex table of the random graph G
+
+ NV : Natural;
+ -- Number of Vertices
+
+ function Get_Vertices (F : Natural) return Vertex_Type;
+ procedure Set_Vertices (F : Natural; Item : Vertex_Type);
+ -- Comments needed ???
+
+ Opt : Optimization;
+ -- Optimization mode (memory vs CPU)
+
+ Max_Key_Len : Natural := 0;
+ Min_Key_Len : Natural := 0;
+ -- Maximum and minimum of all the word length
+
+ S : Natural;
+ -- Seed
+
+ function Type_Size (L : Natural) return Natural;
+ -- Given the last L of an unsigned integer type T, return its size
+
+ -------------
+ -- Acyclic --
+ -------------
+
+ function Acyclic return Boolean is
+ Marks : array (0 .. NV - 1) of Vertex_Id := (others => No_Vertex);
+
+ function Traverse (Edge : Edge_Id; Mark : Vertex_Id) return Boolean;
+ -- Propagate Mark from X to Y. X is already marked. Mark Y and propagate
+ -- it to the edges of Y except the one representing the same key. Return
+ -- False when Y is marked with Mark.
+
+ --------------
+ -- Traverse --
+ --------------
+
+ function Traverse (Edge : Edge_Id; Mark : Vertex_Id) return Boolean is
+ E : constant Edge_Type := Get_Edges (Edge);
+ K : constant Key_Id := E.Key;
+ Y : constant Vertex_Id := E.Y;
+ M : constant Vertex_Id := Marks (E.Y);
+ V : Vertex_Type;
+
+ begin
+ if M = Mark then
+ return False;
+
+ elsif M = No_Vertex then
+ Marks (Y) := Mark;
+ V := Get_Vertices (Y);
+
+ for J in V.First .. V.Last loop
+
+ -- Do not propagate to the edge representing the same key
+
+ if Get_Edges (J).Key /= K
+ and then not Traverse (J, Mark)
+ then
+ return False;
+ end if;
+ end loop;
+ end if;
+
+ return True;
+ end Traverse;
+
+ Edge : Edge_Type;
+
+ -- Start of processing for Acyclic
+
+ begin
+ -- Edges valid range is
+
+ for J in 1 .. Edges_Len - 1 loop
+
+ Edge := Get_Edges (J);
+
+ -- Mark X of E when it has not been already done
+
+ if Marks (Edge.X) = No_Vertex then
+ Marks (Edge.X) := Edge.X;
+ end if;
+
+ -- Traverse E when this has not already been done
+
+ if Marks (Edge.Y) = No_Vertex
+ and then not Traverse (J, Edge.X)
+ then
+ return False;
+ end if;
+ end loop;
+
+ return True;
+ end Acyclic;
+
+ ---------
+ -- Add --
+ ---------
+
+ procedure Add (C : Character) is
+ pragma Assert (C /= ASCII.NUL);
+ begin
+ Line (Last + 1) := C;
+ Last := Last + 1;
+ end Add;
+
+ ---------
+ -- Add --
+ ---------
+
+ procedure Add (S : String) is
+ Len : constant Natural := S'Length;
+ begin
+ for J in S'Range loop
+ pragma Assert (S (J) /= ASCII.NUL);
+ null;
+ end loop;
+
+ Line (Last + 1 .. Last + Len) := S;
+ Last := Last + Len;
+ end Add;
+
+ --------------
+ -- Allocate --
+ --------------
+
+ function Allocate (N : Natural; S : Natural := 1) return Table_Id is
+ L : constant Integer := IT.Last;
+ begin
+ IT.Set_Last (L + N * S);
+
+ -- Initialize, so debugging printouts don't trip over uninitialized
+ -- components.
+
+ for J in L + 1 .. IT.Last loop
+ IT.Table (J) := -1;
+ end loop;
+
+ return L + 1;
+ end Allocate;
+
+ ------------------------------
+ -- Apply_Position_Selection --
+ ------------------------------
+
+ procedure Apply_Position_Selection is
+ begin
+ for J in 0 .. NK - 1 loop
+ declare
+ IW : constant String := WT.Table (Initial (J)).all;
+ RW : String (1 .. IW'Length) := (others => ASCII.NUL);
+ N : Natural := IW'First - 1;
+
+ begin
+ -- Select the characters of Word included in the position
+ -- selection.
+
+ for C in 0 .. Char_Pos_Set_Len - 1 loop
+ exit when IW (Get_Char_Pos (C)) = ASCII.NUL;
+ N := N + 1;
+ RW (N) := IW (Get_Char_Pos (C));
+ end loop;
+
+ -- Build the new table with the reduced word. Be careful
+ -- to deallocate the old version to avoid memory leaks.
+
+ Free_Word (WT.Table (Reduced (J)));
+ WT.Table (Reduced (J)) := New_Word (RW);
+ Set_Key (J, (Edge => No_Edge));
+ end;
+ end loop;
+ end Apply_Position_Selection;
+
+ -------------------------------
+ -- Assign_Values_To_Vertices --
+ -------------------------------
+
+ procedure Assign_Values_To_Vertices is
+ X : Vertex_Id;
+
+ procedure Assign (X : Vertex_Id);
+ -- Execute assignment on X's neighbors except the vertex that we are
+ -- coming from which is already assigned.
+
+ ------------
+ -- Assign --
+ ------------
+
+ procedure Assign (X : Vertex_Id) is
+ E : Edge_Type;
+ V : constant Vertex_Type := Get_Vertices (X);
+
+ begin
+ for J in V.First .. V.Last loop
+ 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;
+ end loop;
+ end Assign;
+
+ -- Start of processing for Assign_Values_To_Vertices
+
+ begin
+ -- Value -1 denotes an uninitialized value as it is supposed to
+ -- be in the range 0 .. NK.
+
+ if G = No_Table then
+ G_Len := NV;
+ G := Allocate (G_Len, 1);
+ end if;
+
+ for J in 0 .. G_Len - 1 loop
+ Set_Graph (J, -1);
+ end loop;
+
+ for K in 0 .. NK - 1 loop
+ X := Get_Edges (Get_Key (K).Edge).X;
+
+ if Get_Graph (X) = -1 then
+ Set_Graph (X, 0);
+ Assign (X);
+ end if;
+ end loop;
+
+ for J in 0 .. G_Len - 1 loop
+ if Get_Graph (J) = -1 then
+ Set_Graph (J, 0);
+ end if;
+ end loop;
+
+ if Verbose then
+ Put_Int_Vector (Output, "Assign Values To Vertices", G, G_Len);
+ end if;
+ end Assign_Values_To_Vertices;
+
+ -------------
+ -- Compute --
+ -------------
+
+ procedure Compute (Position : String) is
+ Success : Boolean := False;
+
+ begin
+ if NK = 0 then
+ raise Program_Error with "keywords set cannot be empty";
+ end if;
+
+ if Verbose then
+ Put_Initial_Keys (Output, "Initial Key Table");
+ end if;
+
+ if Position'Length /= 0 then
+ Parse_Position_Selection (Position);
+ else
+ Select_Char_Position;
+ end if;
+
+ if Verbose then
+ Put_Int_Vector
+ (Output, "Char Position Set", Char_Pos_Set, Char_Pos_Set_Len);
+ end if;
+
+ Apply_Position_Selection;
+
+ if Verbose then
+ Put_Reduced_Keys (Output, "Reduced Keys Table");
+ end if;
+
+ Select_Character_Set;
+
+ if Verbose then
+ Put_Used_Char_Set (Output, "Character Position Table");
+ end if;
+
+ -- Perform Czech's algorithm
+
+ for J in 1 .. NT loop
+ Generate_Mapping_Tables (Opt, S);
+ Compute_Edges_And_Vertices (Opt);
+
+ -- When graph is not empty (no self-loop from previous operation) and
+ -- not acyclic.
+
+ if 0 < Edges_Len and then Acyclic then
+ Success := True;
+ exit;
+ end if;
+ end loop;
+
+ if not Success then
+ raise Too_Many_Tries;
+ end if;
+
+ Assign_Values_To_Vertices;
+ end Compute;
+
+ --------------------------------
+ -- Compute_Edges_And_Vertices --
+ --------------------------------
+
+ procedure Compute_Edges_And_Vertices (Opt : Optimization) is
+ X : Natural;
+ Y : Natural;
+ Key : Key_Type;
+ Edge : Edge_Type;
+ Vertex : Vertex_Type;
+ Not_Acyclic : Boolean := False;
+
+ procedure Move (From : Natural; To : Natural);
+ function Lt (L, R : Natural) return Boolean;
+ -- Subprograms needed for GNAT.Heap_Sort_G
+
+ --------
+ -- Lt --
+ --------
+
+ function Lt (L, R : Natural) return Boolean is
+ EL : constant Edge_Type := Get_Edges (L);
+ ER : constant Edge_Type := Get_Edges (R);
+ begin
+ return EL.X < ER.X or else (EL.X = ER.X and then EL.Y < ER.Y);
+ end Lt;
+
+ ----------
+ -- Move --
+ ----------
+
+ procedure Move (From : Natural; To : Natural) is
+ begin
+ Set_Edges (To, Get_Edges (From));
+ end Move;
+
+ package Sorting is new GNAT.Heap_Sort_G (Move, Lt);
+
+ -- Start of processing for Compute_Edges_And_Vertices
+
+ begin
+ -- We store edges from 1 to 2 * NK and leave zero alone in order to use
+ -- GNAT.Heap_Sort_G.
+
+ Edges_Len := 2 * NK + 1;
+
+ if Edges = No_Table then
+ Edges := Allocate (Edges_Len, Edge_Size);
+ end if;
+
+ if Vertices = No_Table then
+ Vertices := Allocate (NV, Vertex_Size);
+ end if;
+
+ for J in 0 .. NV - 1 loop
+ Set_Vertices (J, (No_Vertex, No_Vertex - 1));
+ end loop;
+
+ -- For each w, X = f1 (w) and Y = f2 (w)
+
+ for J in 0 .. NK - 1 loop
+ Key := Get_Key (J);
+ Key.Edge := No_Edge;
+ Set_Key (J, Key);
+
+ X := Sum (WT.Table (Reduced (J)), T1, Opt);
+ Y := Sum (WT.Table (Reduced (J)), T2, Opt);
+
+ -- Discard T1 and T2 as soon as we discover a self loop
+
+ if X = Y then
+ Not_Acyclic := True;
+ exit;
+ end if;
+
+ -- We store (X, Y) and (Y, X) to ease assignment step
+
+ Set_Edges (2 * J + 1, (X, Y, J));
+ Set_Edges (2 * J + 2, (Y, X, J));
+ end loop;
+
+ -- Return an empty graph when self loop detected
+
+ if Not_Acyclic then
+ Edges_Len := 0;
+
+ else
+ if Verbose then
+ Put_Edges (Output, "Unsorted Edge Table");
+ Put_Int_Matrix (Output, "Function Table 1", T1,
+ T1_Len, T2_Len);
+ Put_Int_Matrix (Output, "Function Table 2", T2,
+ T1_Len, T2_Len);
+ end if;
+
+ -- Enforce consistency between edges and keys. Construct Vertices and
+ -- compute the list of neighbors of a vertex First .. Last as Edges
+ -- is sorted by X and then Y. To compute the neighbor list, sort the
+ -- edges.
+
+ Sorting.Sort (Edges_Len - 1);
+
+ if Verbose then
+ Put_Edges (Output, "Sorted Edge Table");
+ Put_Int_Matrix (Output, "Function Table 1", T1,
+ T1_Len, T2_Len);
+ Put_Int_Matrix (Output, "Function Table 2", T2,
+ T1_Len, T2_Len);
+ end if;
+
+ -- Edges valid range is 1 .. 2 * NK
+
+ for E in 1 .. Edges_Len - 1 loop
+ Edge := Get_Edges (E);
+ Key := Get_Key (Edge.Key);
+
+ if Key.Edge = No_Edge then
+ Key.Edge := E;
+ Set_Key (Edge.Key, Key);
+ end if;
+
+ Vertex := Get_Vertices (Edge.X);
+
+ if Vertex.First = No_Edge then
+ Vertex.First := E;
+ end if;
+
+ Vertex.Last := E;
+ Set_Vertices (Edge.X, Vertex);
+ end loop;
+
+ if Verbose then
+ Put_Reduced_Keys (Output, "Key Table");
+ Put_Edges (Output, "Edge Table");
+ Put_Vertex_Table (Output, "Vertex Table");
+ end if;
+ end if;
+ end Compute_Edges_And_Vertices;
+
+ ------------
+ -- Define --
+ ------------
+
+ procedure Define
+ (Name : Table_Name;
+ Item_Size : out Natural;
+ Length_1 : out Natural;
+ Length_2 : out Natural)
+ is
+ begin
+ case Name is
+ when Character_Position =>
+ Item_Size := 31;
+ Length_1 := Char_Pos_Set_Len;
+ Length_2 := 0;
+
+ when Used_Character_Set =>
+ Item_Size := 8;
+ Length_1 := 256;
+ Length_2 := 0;
+
+ when Function_Table_1
+ | Function_Table_2
+ =>
+ Item_Size := Type_Size (NV);
+ Length_1 := T1_Len;
+ Length_2 := T2_Len;
+
+ when Graph_Table =>
+ Item_Size := Type_Size (NK);
+ Length_1 := NV;
+ Length_2 := 0;
+ end case;
+ end Define;
+
+ --------------
+ -- Finalize --
+ --------------
+
+ procedure Finalize is
+ begin
+ if Verbose then
+ Put (Output, "Finalize");
+ New_Line (Output);
+ end if;
+
+ -- Deallocate all the WT components (both initial and reduced ones) to
+ -- avoid memory leaks.
+
+ for W in 0 .. WT.Last loop
+
+ -- Note: WT.Table (NK) is a temporary variable, do not free it since
+ -- this would cause a double free.
+
+ if W /= NK then
+ Free_Word (WT.Table (W));
+ end if;
+ end loop;
+
+ WT.Release;
+ IT.Release;
+
+ -- Reset all variables for next usage
+
+ Keys := No_Table;
+
+ Char_Pos_Set := No_Table;
+ Char_Pos_Set_Len := 0;
+
+ Used_Char_Set := No_Table;
+ Used_Char_Set_Len := 0;
+
+ T1 := No_Table;
+ T2 := No_Table;
+
+ T1_Len := 0;
+ T2_Len := 0;
+
+ G := No_Table;
+ G_Len := 0;
+
+ Edges := No_Table;
+ Edges_Len := 0;
+
+ Vertices := No_Table;
+ NV := 0;
+
+ NK := 0;
+ Max_Key_Len := 0;
+ Min_Key_Len := 0;
+ end Finalize;
+
+ ----------------------------
+ -- Generate_Mapping_Table --
+ ----------------------------
+
+ procedure Generate_Mapping_Table
+ (Tab : Integer;
+ L1 : Natural;
+ L2 : Natural;
+ Seed : in out Natural)
+ is
+ begin
+ for J in 0 .. L1 - 1 loop
+ for K in 0 .. L2 - 1 loop
+ Random (Seed);
+ Set_Table (Tab, J, K, Seed mod NV);
+ end loop;
+ end loop;
+ end Generate_Mapping_Table;
+
+ -----------------------------
+ -- Generate_Mapping_Tables --
+ -----------------------------
+
+ procedure Generate_Mapping_Tables
+ (Opt : Optimization;
+ Seed : in out Natural)
+ is
+ begin
+ -- If T1 and T2 are already allocated no need to do it twice. Reuse them
+ -- as their size has not changed.
+
+ if T1 = No_Table and then T2 = No_Table then
+ declare
+ Used_Char_Last : Natural := 0;
+ Used_Char : Natural;
+
+ begin
+ if Opt = CPU_Time then
+ for P in reverse Character'Range loop
+ Used_Char := Get_Used_Char (P);
+ if Used_Char /= 0 then
+ Used_Char_Last := Used_Char;
+ exit;
+ end if;
+ end loop;
+ end if;
+
+ T1_Len := Char_Pos_Set_Len;
+ T2_Len := Used_Char_Last + 1;
+ T1 := Allocate (T1_Len * T2_Len);
+ T2 := Allocate (T1_Len * T2_Len);
+ end;
+ end if;
+
+ Generate_Mapping_Table (T1, T1_Len, T2_Len, Seed);
+ Generate_Mapping_Table (T2, T1_Len, T2_Len, Seed);
+
+ if Verbose then
+ Put_Used_Char_Set (Output, "Used Character Set");
+ Put_Int_Matrix (Output, "Function Table 1", T1,
+ T1_Len, T2_Len);
+ Put_Int_Matrix (Output, "Function Table 2", T2,
+ T1_Len, T2_Len);
+ end if;
+ end Generate_Mapping_Tables;
+
+ ------------------
+ -- Get_Char_Pos --
+ ------------------
+
+ function Get_Char_Pos (P : Natural) return Natural is
+ N : constant Natural := Char_Pos_Set + P;
+ begin
+ return IT.Table (N);
+ end Get_Char_Pos;
+
+ ---------------
+ -- Get_Edges --
+ ---------------
+
+ function Get_Edges (F : Natural) return Edge_Type is
+ N : constant Natural := Edges + (F * Edge_Size);
+ E : Edge_Type;
+ begin
+ E.X := IT.Table (N);
+ E.Y := IT.Table (N + 1);
+ E.Key := IT.Table (N + 2);
+ return E;
+ end Get_Edges;
+
+ ---------------
+ -- Get_Graph --
+ ---------------
+
+ function Get_Graph (N : Natural) return Integer is
+ begin
+ return IT.Table (G + N);
+ end Get_Graph;
+
+ -------------
+ -- Get_Key --
+ -------------
+
+ function Get_Key (N : Key_Id) return Key_Type is
+ K : Key_Type;
+ begin
+ K.Edge := IT.Table (Keys + N);
+ return K;
+ end Get_Key;
+
+ ---------------
+ -- Get_Table --
+ ---------------
+
+ function Get_Table (T : Integer; X, Y : Natural) return Natural is
+ N : constant Natural := T + (Y * T1_Len) + X;
+ begin
+ return IT.Table (N);
+ end Get_Table;
+
+ -------------------
+ -- Get_Used_Char --
+ -------------------
+
+ function Get_Used_Char (C : Character) return Natural is
+ N : constant Natural := Used_Char_Set + Character'Pos (C);
+ begin
+ return IT.Table (N);
+ end Get_Used_Char;
+
+ ------------------
+ -- Get_Vertices --
+ ------------------
+
+ function Get_Vertices (F : Natural) return Vertex_Type is
+ N : constant Natural := Vertices + (F * Vertex_Size);
+ V : Vertex_Type;
+ begin
+ V.First := IT.Table (N);
+ V.Last := IT.Table (N + 1);
+ return V;
+ end Get_Vertices;
+
+ -----------
+ -- Image --
+ -----------
+
+ function Image (Int : Integer; W : Natural := 0) return String is
+ B : String (1 .. 32);
+ L : Natural := 0;
+
+ procedure Img (V : Natural);
+ -- Compute image of V into B, starting at B (L), incrementing L
+
+ ---------
+ -- Img --
+ ---------
+
+ procedure Img (V : Natural) is
+ begin
+ if V > 9 then
+ Img (V / 10);
+ end if;
+
+ L := L + 1;
+ B (L) := Character'Val ((V mod 10) + Character'Pos ('0'));
+ end Img;
+
+ -- Start of processing for Image
+
+ begin
+ if Int < 0 then
+ L := L + 1;
+ B (L) := '-';
+ Img (-Int);
+ else
+ Img (Int);
+ end if;
+
+ return Image (B (1 .. L), W);
+ end Image;
+
+ -----------
+ -- Image --
+ -----------
+
+ function Image (Str : String; W : Natural := 0) return String is
+ Len : constant Natural := Str'Length;
+ Max : Natural := Len;
+
+ begin
+ if Max < W then
+ Max := W;
+ end if;
+
+ declare
+ Buf : String (1 .. Max) := (1 .. Max => ' ');
+
+ begin
+ for J in 0 .. Len - 1 loop
+ Buf (Max - Len + 1 + J) := Str (Str'First + J);
+ end loop;
+
+ return Buf;
+ end;
+ end Image;
+
+ -------------
+ -- Initial --
+ -------------
+
+ function Initial (K : Key_Id) return Word_Id is
+ begin
+ return K;
+ end Initial;
+
+ ----------------
+ -- Initialize --
+ ----------------
+
+ procedure Initialize
+ (Seed : Natural;
+ V : Positive;
+ Optim : Optimization;
+ Tries : Positive)
+ is
+ begin
+ if Verbose then
+ Put (Output, "Initialize");
+ New_Line (Output);
+ end if;
+
+ -- Deallocate the part of the table concerning the reduced words.
+ -- Initial words are already present in the table. We may have reduced
+ -- words already there because a previous computation failed. We are
+ -- currently retrying and the reduced words have to be deallocated.
+
+ for W in Reduced (0) .. WT.Last loop
+ Free_Word (WT.Table (W));
+ end loop;
+
+ IT.Init;
+
+ -- Initialize of computation variables
+
+ Keys := No_Table;
+
+ Char_Pos_Set := No_Table;
+ Char_Pos_Set_Len := 0;
+
+ Used_Char_Set := No_Table;
+ Used_Char_Set_Len := 0;
+
+ T1 := No_Table;
+ T2 := No_Table;
+
+ T1_Len := 0;
+ T2_Len := 0;
+
+ G := No_Table;
+ G_Len := 0;
+
+ Edges := No_Table;
+ Edges_Len := 0;
+
+ if V <= 2 * NK then
+ raise Program_Error with "K to V ratio cannot be lower than 2";
+ end if;
+
+ Vertices := No_Table;
+ NV := V;
+
+ S := Seed;
+ Opt := Optim;
+ NT := Tries;
+
+ Keys := Allocate (NK);
+
+ -- Resize initial words to have all of them at the same size
+ -- (so the size of the largest one).
+
+ for K in 0 .. NK - 1 loop
+ Resize_Word (WT.Table (Initial (K)), Max_Key_Len);
+ end loop;
+
+ -- Allocated the table to store the reduced words. As WT is a
+ -- GNAT.Table (using C memory management), pointers have to be
+ -- explicitly initialized to null.
+
+ WT.Set_Last (Reduced (NK - 1));
+
+ -- Note: Reduced (0) = NK + 1
+
+ WT.Table (NK) := null;
+
+ for W in 0 .. NK - 1 loop
+ WT.Table (Reduced (W)) := null;
+ end loop;
+ end Initialize;
+
+ ------------
+ -- Insert --
+ ------------
+
+ procedure Insert (Value : String) is
+ Len : constant Natural := Value'Length;
+
+ begin
+ if Verbose then
+ Put (Output, "Inserting """ & Value & """");
+ New_Line (Output);
+ end if;
+
+ for J in Value'Range loop
+ pragma Assert (Value (J) /= ASCII.NUL);
+ null;
+ end loop;
+
+ WT.Set_Last (NK);
+ WT.Table (NK) := New_Word (Value);
+ NK := NK + 1;
+
+ if Max_Key_Len < Len then
+ Max_Key_Len := Len;
+ end if;
+
+ if Min_Key_Len = 0 or else Len < Min_Key_Len then
+ Min_Key_Len := Len;
+ end if;
+ end Insert;
+
+ --------------
+ -- New_Line --
+ --------------
+
+ procedure New_Line (File : File_Descriptor) is
+ begin
+ if Write (File, EOL'Address, 1) /= 1 then
+ raise Program_Error;
+ end if;
+ end New_Line;
+
+ --------------
+ -- New_Word --
+ --------------
+
+ function New_Word (S : String) return Word_Type is
+ begin
+ return new String'(S);
+ end New_Word;
+
+ ------------------------------
+ -- Parse_Position_Selection --
+ ------------------------------
+
+ procedure Parse_Position_Selection (Argument : String) is
+ N : Natural := Argument'First;
+ L : constant Natural := Argument'Last;
+ M : constant Natural := Max_Key_Len;
+
+ T : array (1 .. M) of Boolean := (others => False);
+
+ function Parse_Index return Natural;
+ -- Parse argument starting at index N to find an index
+
+ -----------------
+ -- Parse_Index --
+ -----------------
+
+ function Parse_Index return Natural is
+ C : Character := Argument (N);
+ V : Natural := 0;
+
+ begin
+ if C = '$' then
+ N := N + 1;
+ return M;
+ end if;
+
+ if C not in '0' .. '9' then
+ raise Program_Error with "cannot read position argument";
+ end if;
+
+ while C in '0' .. '9' loop
+ V := V * 10 + (Character'Pos (C) - Character'Pos ('0'));
+ N := N + 1;
+ exit when L < N;
+ C := Argument (N);
+ end loop;
+
+ return V;
+ end Parse_Index;
+
+ -- Start of processing for Parse_Position_Selection
+
+ begin
+ -- Empty specification means all the positions
+
+ if L < N then
+ Char_Pos_Set_Len := M;
+ Char_Pos_Set := Allocate (Char_Pos_Set_Len);
+
+ for C in 0 .. Char_Pos_Set_Len - 1 loop
+ Set_Char_Pos (C, C + 1);
+ end loop;
+
+ else
+ loop
+ declare
+ First, Last : Natural;
+
+ begin
+ First := Parse_Index;
+ Last := First;
+
+ -- Detect a range
+
+ if N <= L and then Argument (N) = '-' then
+ N := N + 1;
+ Last := Parse_Index;
+ end if;
+
+ -- Include the positions in the selection
+
+ for J in First .. Last loop
+ T (J) := True;
+ end loop;
+ end;
+
+ exit when L < N;
+
+ if Argument (N) /= ',' then
+ raise Program_Error with "cannot read position argument";
+ end if;
+
+ N := N + 1;
+ end loop;
+
+ -- Compute position selection length
+
+ N := 0;
+ for J in T'Range loop
+ if T (J) then
+ N := N + 1;
+ end if;
+ end loop;
+
+ -- Fill position selection
+
+ Char_Pos_Set_Len := N;
+ Char_Pos_Set := Allocate (Char_Pos_Set_Len);
+
+ N := 0;
+ for J in T'Range loop
+ if T (J) then
+ Set_Char_Pos (N, J);
+ N := N + 1;
+ end if;
+ end loop;
+ end if;
+ end Parse_Position_Selection;
+
+ ---------
+ -- Put --
+ ---------
+
+ procedure Put (File : File_Descriptor; Str : String) is
+ Len : constant Natural := Str'Length;
+ begin
+ for J in Str'Range loop
+ pragma Assert (Str (J) /= ASCII.NUL);
+ null;
+ end loop;
+
+ if Write (File, Str'Address, Len) /= Len then
+ raise Program_Error;
+ end if;
+ end Put;
+
+ ---------
+ -- Put --
+ ---------
+
+ procedure Put
+ (F : File_Descriptor;
+ S : String;
+ F1 : Natural;
+ L1 : Natural;
+ C1 : Natural;
+ F2 : Natural;
+ L2 : Natural;
+ C2 : Natural)
+ is
+ Len : constant Natural := S'Length;
+
+ procedure Flush;
+ -- Write current line, followed by LF
+
+ -----------
+ -- Flush --
+ -----------
+
+ procedure Flush is
+ begin
+ Put (F, Line (1 .. Last));
+ New_Line (F);
+ Last := 0;
+ end Flush;
+
+ -- Start of processing for Put
+
+ begin
+ if C1 = F1 and then C2 = F2 then
+ Last := 0;
+ end if;
+
+ if Last + Len + 3 >= Max then
+ Flush;
+ end if;
+
+ if Last = 0 then
+ Add (" ");
+
+ if F1 <= L1 then
+ if C1 = F1 and then C2 = F2 then
+ Add ('(');
+
+ if F1 = L1 then
+ Add ("0 .. 0 => ");
+ end if;
+
+ else
+ Add (' ');
+ end if;
+ end if;
+ end if;
+
+ if C2 = F2 then
+ Add ('(');
+
+ if F2 = L2 then
+ Add ("0 .. 0 => ");
+ end if;
+
+ else
+ Add (' ');
+ end if;
+
+ Add (S);
+
+ if C2 = L2 then
+ Add (')');
+
+ if F1 > L1 then
+ Add (';');
+ Flush;
+
+ elsif C1 /= L1 then
+ Add (',');
+ Flush;
+
+ else
+ Add (')');
+ Add (';');
+ Flush;
+ end if;
+
+ else
+ Add (',');
+ end if;
+ end Put;
+
+ ---------------
+ -- Put_Edges --
+ ---------------
+
+ procedure Put_Edges (File : File_Descriptor; Title : String) is
+ E : Edge_Type;
+ F1 : constant Natural := 1;
+ L1 : constant Natural := Edges_Len - 1;
+ M : constant Natural := Max / 5;
+
+ begin
+ Put (File, Title);
+ New_Line (File);
+
+ -- Edges valid range is 1 .. Edge_Len - 1
+
+ for J in F1 .. L1 loop
+ E := Get_Edges (J);
+ Put (File, Image (J, M), F1, L1, J, 1, 4, 1);
+ Put (File, Image (E.X, M), F1, L1, J, 1, 4, 2);
+ Put (File, Image (E.Y, M), F1, L1, J, 1, 4, 3);
+ Put (File, Image (E.Key, M), F1, L1, J, 1, 4, 4);
+ end loop;
+ end Put_Edges;
+
+ ----------------------
+ -- Put_Initial_Keys --
+ ----------------------
+
+ procedure Put_Initial_Keys (File : File_Descriptor; Title : String) is
+ F1 : constant Natural := 0;
+ L1 : constant Natural := NK - 1;
+ M : constant Natural := Max / 5;
+ K : Key_Type;
+
+ begin
+ Put (File, Title);
+ New_Line (File);
+
+ for J in F1 .. L1 loop
+ K := Get_Key (J);
+ Put (File, Image (J, M), F1, L1, J, 1, 3, 1);
+ Put (File, Image (K.Edge, M), F1, L1, J, 1, 3, 2);
+ Put (File, Trim_Trailing_Nuls (WT.Table (Initial (J)).all),
+ F1, L1, J, 1, 3, 3);
+ end loop;
+ end Put_Initial_Keys;
+
+ --------------------
+ -- Put_Int_Matrix --
+ --------------------
+
+ procedure Put_Int_Matrix
+ (File : File_Descriptor;
+ Title : String;
+ Table : Integer;
+ Len_1 : Natural;
+ Len_2 : Natural)
+ is
+ F1 : constant Integer := 0;
+ L1 : constant Integer := Len_1 - 1;
+ F2 : constant Integer := 0;
+ L2 : constant Integer := Len_2 - 1;
+ Ix : Natural;
+
+ begin
+ Put (File, Title);
+ New_Line (File);
+
+ if Len_2 = 0 then
+ for J in F1 .. L1 loop
+ Ix := IT.Table (Table + J);
+ Put (File, Image (Ix), 1, 0, 1, F1, L1, J);
+ end loop;
+
+ else
+ for J in F1 .. L1 loop
+ for K in F2 .. L2 loop
+ Ix := IT.Table (Table + J + K * Len_1);
+ Put (File, Image (Ix), F1, L1, J, F2, L2, K);
+ end loop;
+ end loop;
+ end if;
+ end Put_Int_Matrix;
+
+ --------------------
+ -- Put_Int_Vector --
+ --------------------
+
+ procedure Put_Int_Vector
+ (File : File_Descriptor;
+ Title : String;
+ Vector : Integer;
+ Length : Natural)
+ is
+ F2 : constant Natural := 0;
+ L2 : constant Natural := Length - 1;
+
+ begin
+ Put (File, Title);
+ New_Line (File);
+
+ for J in F2 .. L2 loop
+ Put (File, Image (IT.Table (Vector + J)), 1, 0, 1, F2, L2, J);
+ end loop;
+ end Put_Int_Vector;
+
+ ----------------------
+ -- Put_Reduced_Keys --
+ ----------------------
+
+ procedure Put_Reduced_Keys (File : File_Descriptor; Title : String) is
+ F1 : constant Natural := 0;
+ L1 : constant Natural := NK - 1;
+ M : constant Natural := Max / 5;
+ K : Key_Type;
+
+ begin
+ Put (File, Title);
+ New_Line (File);
+
+ for J in F1 .. L1 loop
+ K := Get_Key (J);
+ Put (File, Image (J, M), F1, L1, J, 1, 3, 1);
+ Put (File, Image (K.Edge, M), F1, L1, J, 1, 3, 2);
+ Put (File, Trim_Trailing_Nuls (WT.Table (Reduced (J)).all),
+ F1, L1, J, 1, 3, 3);
+ end loop;
+ end Put_Reduced_Keys;
+
+ -----------------------
+ -- Put_Used_Char_Set --
+ -----------------------
+
+ procedure Put_Used_Char_Set (File : File_Descriptor; Title : String) is
+ F : constant Natural := Character'Pos (Character'First);
+ L : constant Natural := Character'Pos (Character'Last);
+
+ begin
+ Put (File, Title);
+ New_Line (File);
+
+ for J in Character'Range loop
+ Put
+ (File, Image (Get_Used_Char (J)), 1, 0, 1, F, L, Character'Pos (J));
+ end loop;
+ end Put_Used_Char_Set;
+
+ ----------------------
+ -- Put_Vertex_Table --
+ ----------------------
+
+ procedure Put_Vertex_Table (File : File_Descriptor; Title : String) is
+ F1 : constant Natural := 0;
+ L1 : constant Natural := NV - 1;
+ M : constant Natural := Max / 4;
+ V : Vertex_Type;
+
+ begin
+ Put (File, Title);
+ New_Line (File);
+
+ for J in F1 .. L1 loop
+ V := Get_Vertices (J);
+ Put (File, Image (J, M), F1, L1, J, 1, 3, 1);
+ Put (File, Image (V.First, M), F1, L1, J, 1, 3, 2);
+ Put (File, Image (V.Last, M), F1, L1, J, 1, 3, 3);
+ end loop;
+ end Put_Vertex_Table;
+
+ ------------
+ -- Random --
+ ------------
+
+ procedure Random (Seed : in out Natural) is
+
+ -- Park & Miller Standard Minimal using Schrage's algorithm to avoid
+ -- overflow: Xn+1 = 16807 * Xn mod (2 ** 31 - 1)
+
+ R : Natural;
+ Q : Natural;
+ X : Integer;
+
+ begin
+ R := Seed mod 127773;
+ Q := Seed / 127773;
+ X := 16807 * R - 2836 * Q;
+
+ Seed := (if X < 0 then X + 2147483647 else X);
+ end Random;
+
+ -------------
+ -- Reduced --
+ -------------
+
+ function Reduced (K : Key_Id) return Word_Id is
+ begin
+ return K + NK + 1;
+ end Reduced;
+
+ -----------------
+ -- Resize_Word --
+ -----------------
+
+ procedure Resize_Word (W : in out Word_Type; Len : Natural) is
+ S1 : constant String := W.all;
+ S2 : String (1 .. Len) := (others => ASCII.NUL);
+ L : constant Natural := S1'Length;
+ begin
+ if L /= Len then
+ Free_Word (W);
+ S2 (1 .. L) := S1;
+ W := New_Word (S2);
+ end if;
+ end Resize_Word;
+
+ --------------------------
+ -- Select_Char_Position --
+ --------------------------
+
+ procedure Select_Char_Position is
+
+ type Vertex_Table_Type is array (Natural range <>) of Vertex_Type;
+
+ procedure Build_Identical_Keys_Sets
+ (Table : in out Vertex_Table_Type;
+ Last : in out Natural;
+ Pos : Natural);
+ -- Build a list of keys subsets that are identical with the current
+ -- position selection plus Pos. Once this routine is called, reduced
+ -- words are sorted by subsets and each item (First, Last) in Sets
+ -- defines the range of identical keys.
+ -- Need comment saying exactly what Last is ???
+
+ function Count_Different_Keys
+ (Table : Vertex_Table_Type;
+ Last : Natural;
+ Pos : Natural) return Natural;
+ -- For each subset in Sets, count the number of different keys if we add
+ -- Pos to the current position selection.
+
+ Sel_Position : IT.Table_Type (1 .. Max_Key_Len);
+ Last_Sel_Pos : Natural := 0;
+ Max_Sel_Pos : Natural := 0;
+
+ -------------------------------
+ -- Build_Identical_Keys_Sets --
+ -------------------------------
+
+ procedure Build_Identical_Keys_Sets
+ (Table : in out Vertex_Table_Type;
+ Last : in out Natural;
+ Pos : Natural)
+ is
+ S : constant Vertex_Table_Type := Table (Table'First .. Last);
+ C : constant Natural := Pos;
+ -- Shortcuts (why are these not renames ???)
+
+ F : Integer;
+ L : Integer;
+ -- First and last words of a subset
+
+ Offset : Natural;
+ -- GNAT.Heap_Sort assumes that the first array index is 1. Offset
+ -- defines the translation to operate.
+
+ function Lt (L, R : Natural) return Boolean;
+ procedure Move (From : Natural; To : Natural);
+ -- Subprograms needed by GNAT.Heap_Sort_G
+
+ --------
+ -- Lt --
+ --------
+
+ function Lt (L, R : Natural) return Boolean is
+ C : constant Natural := Pos;
+ Left : Natural;
+ Right : Natural;
+
+ begin
+ if L = 0 then
+ Left := NK;
+ Right := Offset + R;
+ elsif R = 0 then
+ Left := Offset + L;
+ Right := NK;
+ else
+ Left := Offset + L;
+ Right := Offset + R;
+ end if;
+
+ return WT.Table (Left)(C) < WT.Table (Right)(C);
+ end Lt;
+
+ ----------
+ -- Move --
+ ----------
+
+ procedure Move (From : Natural; To : Natural) is
+ Target, Source : Natural;
+
+ begin
+ if From = 0 then
+ Source := NK;
+ Target := Offset + To;
+ elsif To = 0 then
+ Source := Offset + From;
+ Target := NK;
+ else
+ Source := Offset + From;
+ Target := Offset + To;
+ end if;
+
+ WT.Table (Target) := WT.Table (Source);
+ WT.Table (Source) := null;
+ end Move;
+
+ package Sorting is new GNAT.Heap_Sort_G (Move, Lt);
+
+ -- Start of processing for Build_Identical_Key_Sets
+
+ begin
+ Last := 0;
+
+ -- For each subset in S, extract the new subsets we have by adding C
+ -- 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;
+ Last := Last + 1;
+ Table (Last) := (F, L);
+
+ else
+ Offset := Reduced (S (J).First) - 1;
+ Sorting.Sort (S (J).Last - S (J).First + 1);
+
+ F := S (J).First;
+ L := F;
+ for N in S (J).First .. S (J).Last loop
+
+ -- For the last item, close the last subset
+
+ if N = S (J).Last then
+ Last := Last + 1;
+ Table (Last) := (F, N);
+
+ -- Two contiguous words are identical when they have the
+ -- same Cth character.
+
+ elsif WT.Table (Reduced (N))(C) =
+ WT.Table (Reduced (N + 1))(C)
+ then
+ L := N + 1;
+
+ -- Find a new subset of identical keys. Store the current
+ -- one and create a new subset.
+
+ else
+ Last := Last + 1;
+ Table (Last) := (F, L);
+ F := N + 1;
+ L := F;
+ end if;
+ end loop;
+ end if;
+ end loop;
+ end Build_Identical_Keys_Sets;
+
+ --------------------------
+ -- Count_Different_Keys --
+ --------------------------
+
+ function Count_Different_Keys
+ (Table : Vertex_Table_Type;
+ Last : Natural;
+ Pos : Natural) return Natural
+ is
+ N : array (Character) of Natural;
+ C : Character;
+ T : Natural := 0;
+
+ begin
+ -- For each subset, count the number of words that are still
+ -- different when we include Pos in the position selection. Only
+ -- focus on this position as the other positions already produce
+ -- identical keys.
+
+ for S in 1 .. Last loop
+
+ -- Count the occurrences of the different characters
+
+ N := (others => 0);
+ for K in Table (S).First .. Table (S).Last loop
+ C := WT.Table (Reduced (K))(Pos);
+ N (C) := N (C) + 1;
+ end loop;
+
+ -- Update the number of different keys. Each character used
+ -- denotes a different key.
+
+ for J in N'Range loop
+ if N (J) > 0 then
+ T := T + 1;
+ end if;
+ end loop;
+ end loop;
+
+ return T;
+ end Count_Different_Keys;
+
+ -- Start of processing for Select_Char_Position
+
+ begin
+ -- Initialize the reduced words set
+
+ for K in 0 .. NK - 1 loop
+ WT.Table (Reduced (K)) := New_Word (WT.Table (Initial (K)).all);
+ end loop;
+
+ declare
+ Differences : Natural;
+ Max_Differences : Natural := 0;
+ Old_Differences : Natural;
+ Max_Diff_Sel_Pos : Natural := 0; -- init to kill warning
+ Max_Diff_Sel_Pos_Idx : Natural := 0; -- init to kill warning
+ Same_Keys_Sets_Table : Vertex_Table_Type (1 .. NK);
+ Same_Keys_Sets_Last : Natural := 1;
+
+ begin
+ for C in Sel_Position'Range loop
+ Sel_Position (C) := C;
+ end loop;
+
+ Same_Keys_Sets_Table (1) := (0, NK - 1);
+
+ loop
+ -- Preserve maximum number of different keys and check later on
+ -- that this value is strictly incrementing. Otherwise, it means
+ -- that two keys are strictly identical.
+
+ Old_Differences := Max_Differences;
+
+ -- The first position should not exceed the minimum key length.
+ -- Otherwise, we may end up with an empty word once reduced.
+
+ Max_Sel_Pos :=
+ (if Last_Sel_Pos = 0 then Min_Key_Len else Max_Key_Len);
+
+ -- Find which position increases more the number of differences
+
+ for J in Last_Sel_Pos + 1 .. Max_Sel_Pos loop
+ Differences := Count_Different_Keys
+ (Same_Keys_Sets_Table,
+ Same_Keys_Sets_Last,
+ Sel_Position (J));
+
+ if Verbose then
+ Put (Output,
+ "Selecting position" & Sel_Position (J)'Img &
+ " results in" & Differences'Img &
+ " differences");
+ New_Line (Output);
+ end if;
+
+ if Differences > Max_Differences then
+ Max_Differences := Differences;
+ Max_Diff_Sel_Pos := Sel_Position (J);
+ Max_Diff_Sel_Pos_Idx := J;
+ end if;
+ end loop;
+
+ if Old_Differences = Max_Differences then
+ raise Program_Error with "some keys are identical";
+ end if;
+
+ -- Insert selected position and sort Sel_Position table
+
+ Last_Sel_Pos := Last_Sel_Pos + 1;
+ Sel_Position (Last_Sel_Pos + 1 .. Max_Diff_Sel_Pos_Idx) :=
+ Sel_Position (Last_Sel_Pos .. Max_Diff_Sel_Pos_Idx - 1);
+ Sel_Position (Last_Sel_Pos) := Max_Diff_Sel_Pos;
+
+ 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;
+ exit;
+ end if;
+ end loop;
+
+ exit when Max_Differences = NK;
+
+ Build_Identical_Keys_Sets
+ (Same_Keys_Sets_Table,
+ Same_Keys_Sets_Last,
+ Max_Diff_Sel_Pos);
+
+ if Verbose then
+ Put (Output,
+ "Selecting position" & Max_Diff_Sel_Pos'Img &
+ " results in" & Max_Differences'Img &
+ " differences");
+ New_Line (Output);
+ Put (Output, "--");
+ New_Line (Output);
+ for J in 1 .. Same_Keys_Sets_Last loop
+ for K in
+ Same_Keys_Sets_Table (J).First ..
+ Same_Keys_Sets_Table (J).Last
+ loop
+ Put (Output,
+ Trim_Trailing_Nuls (WT.Table (Reduced (K)).all));
+ New_Line (Output);
+ end loop;
+ Put (Output, "--");
+ New_Line (Output);
+ end loop;
+ end if;
+ end loop;
+ end;
+
+ Char_Pos_Set_Len := Last_Sel_Pos;
+ Char_Pos_Set := Allocate (Char_Pos_Set_Len);
+
+ for C in 1 .. Last_Sel_Pos loop
+ Set_Char_Pos (C - 1, Sel_Position (C));
+ end loop;
+ end Select_Char_Position;
+
+ --------------------------
+ -- Select_Character_Set --
+ --------------------------
+
+ procedure Select_Character_Set is
+ Last : Natural := 0;
+ Used : array (Character) of Boolean := (others => False);
+ Char : Character;
+
+ begin
+ for J in 0 .. NK - 1 loop
+ for K in 0 .. Char_Pos_Set_Len - 1 loop
+ Char := WT.Table (Initial (J))(Get_Char_Pos (K));
+ exit when Char = ASCII.NUL;
+ Used (Char) := True;
+ end loop;
+ end loop;
+
+ Used_Char_Set_Len := 256;
+ Used_Char_Set := Allocate (Used_Char_Set_Len);
+
+ for J in Used'Range loop
+ if Used (J) then
+ Set_Used_Char (J, Last);
+ Last := Last + 1;
+ else
+ Set_Used_Char (J, 0);
+ end if;
+ end loop;
+ end Select_Character_Set;
+
+ ------------------
+ -- Set_Char_Pos --
+ ------------------
+
+ procedure Set_Char_Pos (P : Natural; Item : Natural) is
+ N : constant Natural := Char_Pos_Set + P;
+ begin
+ IT.Table (N) := Item;
+ end Set_Char_Pos;
+
+ ---------------
+ -- Set_Edges --
+ ---------------
+
+ procedure Set_Edges (F : Natural; Item : Edge_Type) is
+ N : constant Natural := Edges + (F * Edge_Size);
+ begin
+ IT.Table (N) := Item.X;
+ IT.Table (N + 1) := Item.Y;
+ IT.Table (N + 2) := Item.Key;
+ end Set_Edges;
+
+ ---------------
+ -- Set_Graph --
+ ---------------
+
+ procedure Set_Graph (N : Natural; Item : Integer) is
+ begin
+ IT.Table (G + N) := Item;
+ end Set_Graph;
+
+ -------------
+ -- Set_Key --
+ -------------
+
+ procedure Set_Key (N : Key_Id; Item : Key_Type) is
+ begin
+ IT.Table (Keys + N) := Item.Edge;
+ end Set_Key;
+
+ ---------------
+ -- Set_Table --
+ ---------------
+
+ procedure Set_Table (T : Integer; X, Y : Natural; Item : Natural) is
+ N : constant Natural := T + ((Y * T1_Len) + X);
+ begin
+ IT.Table (N) := Item;
+ end Set_Table;
+
+ -------------------
+ -- Set_Used_Char --
+ -------------------
+
+ procedure Set_Used_Char (C : Character; Item : Natural) is
+ N : constant Natural := Used_Char_Set + Character'Pos (C);
+ begin
+ IT.Table (N) := Item;
+ end Set_Used_Char;
+
+ ------------------
+ -- Set_Vertices --
+ ------------------
+
+ procedure Set_Vertices (F : Natural; Item : Vertex_Type) is
+ N : constant Natural := Vertices + (F * Vertex_Size);
+ begin
+ IT.Table (N) := Item.First;
+ IT.Table (N + 1) := Item.Last;
+ end Set_Vertices;
+
+ ---------
+ -- Sum --
+ ---------
+
+ function Sum
+ (Word : Word_Type;
+ Table : Table_Id;
+ Opt : Optimization) return Natural
+ is
+ S : Natural := 0;
+ R : Natural;
+
+ begin
+ case Opt is
+ when CPU_Time =>
+ 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;
+
+ when Memory_Space =>
+ 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;
+
+ return S;
+ end Sum;
+
+ ------------------------
+ -- Trim_Trailing_Nuls --
+ ------------------------
+
+ function Trim_Trailing_Nuls (Str : String) return String is
+ begin
+ for J in reverse Str'Range loop
+ if Str (J) /= ASCII.NUL then
+ return Str (Str'First .. J);
+ end if;
+ end loop;
+
+ return Str;
+ end Trim_Trailing_Nuls;
+
+ ---------------
+ -- Type_Size --
+ ---------------
+
+ function Type_Size (L : Natural) return Natural is
+ begin
+ if L <= 2 ** 8 then
+ return 8;
+ elsif L <= 2 ** 16 then
+ return 16;
+ else
+ return 32;
+ end if;
+ end Type_Size;
+
+ -----------
+ -- Value --
+ -----------
+
+ function Value
+ (Name : Table_Name;
+ J : Natural;
+ K : Natural := 0) return Natural
+ is
+ begin
+ case Name is
+ when Character_Position =>
+ return Get_Char_Pos (J);
+
+ when Used_Character_Set =>
+ return Get_Used_Char (Character'Val (J));
+
+ when Function_Table_1 =>
+ return Get_Table (T1, J, K);
+
+ when Function_Table_2 =>
+ return Get_Table (T2, J, K);
+
+ when Graph_Table =>
+ return Get_Graph (J);
+ end case;
+ end Value;
+
+end System.Perfect_Hash_Generators;
diff --git a/gcc/ada/libgnat/s-pehage.ads b/gcc/ada/libgnat/s-pehage.ads
new file mode 100644
index 0000000..f8b8129
--- /dev/null
+++ b/gcc/ada/libgnat/s-pehage.ads
@@ -0,0 +1,212 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S Y S T E M . P E R F E C T _ H A S H _ G E N E R A T O R S --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 2002-2021, 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- --
+-- 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 a generator of static minimal perfect hash functions.
+-- To understand what a perfect hash function is, we define several notions.
+-- These definitions are inspired from the following paper:
+
+-- Zbigniew J. Czech, George Havas, and Bohdan S. Majewski ``An Optimal
+-- Algorithm for Generating Minimal Perfect Hash Functions'', Information
+-- Processing Letters, 43(1992) pp.257-264, Oct.1992
+
+-- Let W be a set of m words. A hash function h is a function that maps the
+-- set of words W into some given interval I of integers [0, k-1], where k is
+-- an integer, usually k >= m. h (w) where w is a word in W computes an
+-- address or an integer from I for the storage or the retrieval of that
+-- item. The storage area used to store items is known as a hash table. Words
+-- for which the same address is computed are called synonyms. Due to the
+-- existence of synonyms a situation called collision may arise in which two
+-- items w1 and w2 have the same address. Several schemes for resolving
+-- collisions are known. A perfect hash function is an injection from the word
+-- set W to the integer interval I with k >= m. If k = m, then h is a minimal
+-- perfect hash function. A hash function is order preserving if it puts
+-- entries into the hash table in a prespecified order.
+
+-- A minimal perfect hash function is defined by two properties:
+
+-- Since no collisions occur each item can be retrieved from the table in
+-- *one* probe. This represents the "perfect" property.
+
+-- The hash table size corresponds to the exact size of W and *no larger*.
+-- This represents the "minimal" property.
+
+-- The functions generated by this package require the words to be known in
+-- advance (they are "static" hash functions). The hash functions are also
+-- order preserving. If w2 is inserted after w1 in the generator, then h (w1)
+-- < h (w2). These hashing functions are convenient for use with realtime
+-- applications.
+
+pragma Compiler_Unit_Warning;
+
+package System.Perfect_Hash_Generators is
+
+ type Optimization is (Memory_Space, CPU_Time);
+ -- Optimize either the memory space or the execution time. Note: in
+ -- practice, the optimization mode has little effect on speed. The tables
+ -- are somewhat smaller with Memory_Space.
+
+ Verbose : Boolean := False;
+ -- Output the status of the algorithm. For instance, the tables, the random
+ -- graph (edges, vertices) and selected char positions are output between
+ -- two iterations.
+
+ procedure Initialize
+ (Seed : Natural;
+ V : Positive;
+ Optim : Optimization;
+ Tries : Positive);
+ -- Initialize the generator and its internal structures. Set the number of
+ -- vertices in the random graphs. This value has to be greater than twice
+ -- the number of keys in order for the algorithm to succeed. The word set
+ -- is not modified (in particular when it is already set). For instance, it
+ -- is possible to run several times the generator with different settings
+ -- on the same words.
+ --
+ -- A classical way of doing is to Insert all the words and then to invoke
+ -- Initialize and Compute. If this fails to find a perfect hash function,
+ -- invoke Initialize again with other configuration parameters (probably
+ -- with a greater number of vertices). Once successful, invoke Define and
+ -- Value, and then Finalize.
+
+ procedure Finalize;
+ -- Deallocate the internal structures and the words table
+
+ procedure Insert (Value : String);
+ -- Insert a new word into the table. ASCII.NUL characters are not allowed.
+
+ Too_Many_Tries : exception;
+ -- Raised after Tries unsuccessful runs
+
+ procedure Compute (Position : String);
+ -- Compute the hash function. Position allows the definition of selection
+ -- of character positions used in the word hash function. Positions can be
+ -- separated by commas and ranges like x-y may be used. Character '$'
+ -- represents the final character of a word. With an empty position, the
+ -- generator automatically produces positions to reduce the memory usage.
+ -- Raise Too_Many_Tries if the algorithm does not succeed within Tries
+ -- attempts (see Initialize).
+
+ -- The procedure Define returns the lengths of an internal table and its
+ -- item type size. The function Value returns the value of each item in
+ -- the table. Together they can be used to retrieve the parameters of the
+ -- hash function which has been computed by a call to Compute.
+
+ -- The hash function has the following form:
+
+ -- h (w) = (g (f1 (w)) + g (f2 (w))) mod m
+
+ -- G is a function based on a graph table [0,n-1] -> [0,m-1]. m is the
+ -- number of keys. n is an internally computed value and it can be obtained
+ -- as the length of vector G.
+
+ -- F1 and F2 are two functions based on two function tables T1 and T2.
+ -- Their definition depends on the chosen optimization mode.
+
+ -- Only some character positions are used in the words because they are
+ -- significant. They are listed in a character position table (P in the
+ -- pseudo-code below). For instance, in {"jan", "feb", "mar", "apr", "jun",
+ -- "jul", "aug", "sep", "oct", "nov", "dec"}, only positions 2 and 3 are
+ -- significant (the first character can be ignored). In this example, P =
+ -- {2, 3}
+
+ -- When Optimization is CPU_Time, the first dimension of T1 and T2
+ -- corresponds to the character position in the word and the second to the
+ -- character set. As all the character set is not used, we define a used
+ -- character table which associates a distinct index to each used character
+ -- (unused characters are mapped to zero). In this case, the second
+ -- dimension of T1 and T2 is reduced to the used character set (C in the
+ -- pseudo-code below). Therefore, the hash function has the following:
+
+ -- function Hash (S : String) return Natural is
+ -- F : constant Natural := S'First - 1;
+ -- L : constant Natural := S'Length;
+ -- F1, F2 : Natural := 0;
+ -- J : <t>;
+
+ -- begin
+ -- for K in P'Range loop
+ -- exit when L < P (K);
+ -- J := C (S (P (K) + F));
+ -- F1 := (F1 + Natural (T1 (K, J))) mod <n>;
+ -- F2 := (F2 + Natural (T2 (K, J))) mod <n>;
+ -- end loop;
+
+ -- return (Natural (G (F1)) + Natural (G (F2))) mod <m>;
+ -- end Hash;
+
+ -- When Optimization is Memory_Space, the first dimension of T1 and T2
+ -- corresponds to the character position in the word and the second
+ -- dimension is ignored. T1 and T2 are no longer matrices but vectors.
+ -- Therefore, the used character table is not available. The hash function
+ -- has the following form:
+
+ -- function Hash (S : String) return Natural is
+ -- F : constant Natural := S'First - 1;
+ -- L : constant Natural := S'Length;
+ -- F1, F2 : Natural := 0;
+ -- J : <t>;
+
+ -- begin
+ -- for K in P'Range loop
+ -- exit when L < P (K);
+ -- J := Character'Pos (S (P (K) + F));
+ -- F1 := (F1 + Natural (T1 (K) * J)) mod <n>;
+ -- F2 := (F2 + Natural (T2 (K) * J)) mod <n>;
+ -- end loop;
+
+ -- return (Natural (G (F1)) + Natural (G (F2))) mod <m>;
+ -- end Hash;
+
+ type Table_Name is
+ (Character_Position,
+ Used_Character_Set,
+ Function_Table_1,
+ Function_Table_2,
+ Graph_Table);
+
+ procedure Define
+ (Name : Table_Name;
+ Item_Size : out Natural;
+ Length_1 : out Natural;
+ Length_2 : out Natural);
+ -- Return the definition of the table Name. This includes the length of
+ -- dimensions 1 and 2 and the size of an unsigned integer item. When
+ -- Length_2 is zero, the table has only one dimension. All the ranges
+ -- start from zero.
+
+ function Value
+ (Name : Table_Name;
+ J : Natural;
+ K : Natural := 0) return Natural;
+ -- Return the value of the component (J, K) of the table Name. When the
+ -- table has only one dimension, K is ignored.
+
+end System.Perfect_Hash_Generators;
diff --git a/gcc/ada/libgnat/s-pooglo.adb b/gcc/ada/libgnat/s-pooglo.adb
index d1eaf53..b957eff 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 8c19837..67518c2 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 04a0532..5592348 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 6ba152a..6e33260 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 bc6ae24..fd984bb 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 3921b1c..f52593f 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-powflt.ads b/gcc/ada/libgnat/s-powflt.ads
index 9d58967..0967403 100644
--- a/gcc/ada/libgnat/s-powflt.ads
+++ b/gcc/ada/libgnat/s-powflt.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2020-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -34,52 +34,34 @@
package System.Powten_Flt is
pragma Pure;
- Maxpow : constant := 38;
- -- Largest power of ten representable with Float
-
Maxpow_Exact : constant := 10;
-- Largest power of ten exactly representable with Float. It is equal to
-- floor (M * log 2 / log 5), when M is the size of the mantissa (24).
- Powten : constant array (0 .. Maxpow) of Float :=
- (00 => 1.0E+00,
- 01 => 1.0E+01,
- 02 => 1.0E+02,
- 03 => 1.0E+03,
- 04 => 1.0E+04,
- 05 => 1.0E+05,
- 06 => 1.0E+06,
- 07 => 1.0E+07,
- 08 => 1.0E+08,
- 09 => 1.0E+09,
- 10 => 1.0E+10,
- 11 => 1.0E+11,
- 12 => 1.0E+12,
- 13 => 1.0E+13,
- 14 => 1.0E+14,
- 15 => 1.0E+15,
- 16 => 1.0E+16,
- 17 => 1.0E+17,
- 18 => 1.0E+18,
- 19 => 1.0E+19,
- 20 => 1.0E+20,
- 21 => 1.0E+21,
- 22 => 1.0E+22,
- 23 => 1.0E+23,
- 24 => 1.0E+24,
- 25 => 1.0E+25,
- 26 => 1.0E+26,
- 27 => 1.0E+27,
- 28 => 1.0E+28,
- 29 => 1.0E+29,
- 30 => 1.0E+30,
- 31 => 1.0E+31,
- 32 => 1.0E+32,
- 33 => 1.0E+33,
- 34 => 1.0E+34,
- 35 => 1.0E+35,
- 36 => 1.0E+36,
- 37 => 1.0E+37,
- 38 => 1.0E+38);
+ Maxpow : constant := Maxpow_Exact * 2;
+ -- Largest power of ten exactly representable with a double Float
+
+ Powten : constant array (0 .. Maxpow, 1 .. 2) of Float :=
+ (00 => (1.0E+00, 0.0),
+ 01 => (1.0E+01, 0.0),
+ 02 => (1.0E+02, 0.0),
+ 03 => (1.0E+03, 0.0),
+ 04 => (1.0E+04, 0.0),
+ 05 => (1.0E+05, 0.0),
+ 06 => (1.0E+06, 0.0),
+ 07 => (1.0E+07, 0.0),
+ 08 => (1.0E+08, 0.0),
+ 09 => (1.0E+09, 0.0),
+ 10 => (1.0E+10, 0.0),
+ 11 => (1.0E+11, 1.0E+11 - Float'Machine (1.0E+11)),
+ 12 => (1.0E+12, 1.0E+12 - Float'Machine (1.0E+12)),
+ 13 => (1.0E+13, 1.0E+13 - Float'Machine (1.0E+13)),
+ 14 => (1.0E+14, 1.0E+14 - Float'Machine (1.0E+14)),
+ 15 => (1.0E+15, 1.0E+15 - Float'Machine (1.0E+15)),
+ 16 => (1.0E+16, 1.0E+16 - Float'Machine (1.0E+16)),
+ 17 => (1.0E+17, 1.0E+17 - Float'Machine (1.0E+17)),
+ 18 => (1.0E+18, 1.0E+18 - Float'Machine (1.0E+18)),
+ 19 => (1.0E+19, 1.0E+19 - Float'Machine (1.0E+19)),
+ 20 => (1.0E+20, 1.0E+20 - Float'Machine (1.0E+20)));
end System.Powten_Flt;
diff --git a/gcc/ada/libgnat/s-powlfl.ads b/gcc/ada/libgnat/s-powlfl.ads
index d191eff..7800f2f 100644
--- a/gcc/ada/libgnat/s-powlfl.ads
+++ b/gcc/ada/libgnat/s-powlfl.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2020-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -34,322 +34,58 @@
package System.Powten_LFlt is
pragma Pure;
- Maxpow : constant := 308;
- -- Largest power of ten representable with Long_Float
-
Maxpow_Exact : constant := 22;
-- Largest power of ten exactly representable with Long_Float. It is equal
-- to floor (M * log 2 / log 5), when M is the size of the mantissa (53).
- Powten : constant array (0 .. Maxpow) of Long_Float :=
- (00 => 1.0E+00,
- 01 => 1.0E+01,
- 02 => 1.0E+02,
- 03 => 1.0E+03,
- 04 => 1.0E+04,
- 05 => 1.0E+05,
- 06 => 1.0E+06,
- 07 => 1.0E+07,
- 08 => 1.0E+08,
- 09 => 1.0E+09,
- 10 => 1.0E+10,
- 11 => 1.0E+11,
- 12 => 1.0E+12,
- 13 => 1.0E+13,
- 14 => 1.0E+14,
- 15 => 1.0E+15,
- 16 => 1.0E+16,
- 17 => 1.0E+17,
- 18 => 1.0E+18,
- 19 => 1.0E+19,
- 20 => 1.0E+20,
- 21 => 1.0E+21,
- 22 => 1.0E+22,
- 23 => 1.0E+23,
- 24 => 1.0E+24,
- 25 => 1.0E+25,
- 26 => 1.0E+26,
- 27 => 1.0E+27,
- 28 => 1.0E+28,
- 29 => 1.0E+29,
- 30 => 1.0E+30,
- 31 => 1.0E+31,
- 32 => 1.0E+32,
- 33 => 1.0E+33,
- 34 => 1.0E+34,
- 35 => 1.0E+35,
- 36 => 1.0E+36,
- 37 => 1.0E+37,
- 38 => 1.0E+38,
- 39 => 1.0E+39,
- 40 => 1.0E+40,
- 41 => 1.0E+41,
- 42 => 1.0E+42,
- 43 => 1.0E+43,
- 44 => 1.0E+44,
- 45 => 1.0E+45,
- 46 => 1.0E+46,
- 47 => 1.0E+47,
- 48 => 1.0E+48,
- 49 => 1.0E+49,
- 50 => 1.0E+50,
- 51 => 1.0E+51,
- 52 => 1.0E+52,
- 53 => 1.0E+53,
- 54 => 1.0E+54,
- 55 => 1.0E+55,
- 56 => 1.0E+56,
- 57 => 1.0E+57,
- 58 => 1.0E+58,
- 59 => 1.0E+59,
- 60 => 1.0E+60,
- 61 => 1.0E+61,
- 62 => 1.0E+62,
- 63 => 1.0E+63,
- 64 => 1.0E+64,
- 65 => 1.0E+65,
- 66 => 1.0E+66,
- 67 => 1.0E+67,
- 68 => 1.0E+68,
- 69 => 1.0E+69,
- 70 => 1.0E+70,
- 71 => 1.0E+71,
- 72 => 1.0E+72,
- 73 => 1.0E+73,
- 74 => 1.0E+74,
- 75 => 1.0E+75,
- 76 => 1.0E+76,
- 77 => 1.0E+77,
- 78 => 1.0E+78,
- 79 => 1.0E+79,
- 80 => 1.0E+80,
- 81 => 1.0E+81,
- 82 => 1.0E+82,
- 83 => 1.0E+83,
- 84 => 1.0E+84,
- 85 => 1.0E+85,
- 86 => 1.0E+86,
- 87 => 1.0E+87,
- 88 => 1.0E+88,
- 89 => 1.0E+89,
- 90 => 1.0E+90,
- 91 => 1.0E+91,
- 92 => 1.0E+92,
- 93 => 1.0E+93,
- 94 => 1.0E+94,
- 95 => 1.0E+95,
- 96 => 1.0E+96,
- 97 => 1.0E+97,
- 98 => 1.0E+98,
- 99 => 1.0E+99,
- 100 => 1.0E+100,
- 101 => 1.0E+101,
- 102 => 1.0E+102,
- 103 => 1.0E+103,
- 104 => 1.0E+104,
- 105 => 1.0E+105,
- 106 => 1.0E+106,
- 107 => 1.0E+107,
- 108 => 1.0E+108,
- 109 => 1.0E+109,
- 110 => 1.0E+110,
- 111 => 1.0E+111,
- 112 => 1.0E+112,
- 113 => 1.0E+113,
- 114 => 1.0E+114,
- 115 => 1.0E+115,
- 116 => 1.0E+116,
- 117 => 1.0E+117,
- 118 => 1.0E+118,
- 119 => 1.0E+119,
- 120 => 1.0E+120,
- 121 => 1.0E+121,
- 122 => 1.0E+122,
- 123 => 1.0E+123,
- 124 => 1.0E+124,
- 125 => 1.0E+125,
- 126 => 1.0E+126,
- 127 => 1.0E+127,
- 128 => 1.0E+128,
- 129 => 1.0E+129,
- 130 => 1.0E+130,
- 131 => 1.0E+131,
- 132 => 1.0E+132,
- 133 => 1.0E+133,
- 134 => 1.0E+134,
- 135 => 1.0E+135,
- 136 => 1.0E+136,
- 137 => 1.0E+137,
- 138 => 1.0E+138,
- 139 => 1.0E+139,
- 140 => 1.0E+140,
- 141 => 1.0E+141,
- 142 => 1.0E+142,
- 143 => 1.0E+143,
- 144 => 1.0E+144,
- 145 => 1.0E+145,
- 146 => 1.0E+146,
- 147 => 1.0E+147,
- 148 => 1.0E+148,
- 149 => 1.0E+149,
- 150 => 1.0E+150,
- 151 => 1.0E+151,
- 152 => 1.0E+152,
- 153 => 1.0E+153,
- 154 => 1.0E+154,
- 155 => 1.0E+155,
- 156 => 1.0E+156,
- 157 => 1.0E+157,
- 158 => 1.0E+158,
- 159 => 1.0E+159,
- 160 => 1.0E+160,
- 161 => 1.0E+161,
- 162 => 1.0E+162,
- 163 => 1.0E+163,
- 164 => 1.0E+164,
- 165 => 1.0E+165,
- 166 => 1.0E+166,
- 167 => 1.0E+167,
- 168 => 1.0E+168,
- 169 => 1.0E+169,
- 170 => 1.0E+170,
- 171 => 1.0E+171,
- 172 => 1.0E+172,
- 173 => 1.0E+173,
- 174 => 1.0E+174,
- 175 => 1.0E+175,
- 176 => 1.0E+176,
- 177 => 1.0E+177,
- 178 => 1.0E+178,
- 179 => 1.0E+179,
- 180 => 1.0E+180,
- 181 => 1.0E+181,
- 182 => 1.0E+182,
- 183 => 1.0E+183,
- 184 => 1.0E+184,
- 185 => 1.0E+185,
- 186 => 1.0E+186,
- 187 => 1.0E+187,
- 188 => 1.0E+188,
- 189 => 1.0E+189,
- 190 => 1.0E+190,
- 191 => 1.0E+191,
- 192 => 1.0E+192,
- 193 => 1.0E+193,
- 194 => 1.0E+194,
- 195 => 1.0E+195,
- 196 => 1.0E+196,
- 197 => 1.0E+197,
- 198 => 1.0E+198,
- 199 => 1.0E+199,
- 200 => 1.0E+200,
- 201 => 1.0E+201,
- 202 => 1.0E+202,
- 203 => 1.0E+203,
- 204 => 1.0E+204,
- 205 => 1.0E+205,
- 206 => 1.0E+206,
- 207 => 1.0E+207,
- 208 => 1.0E+208,
- 209 => 1.0E+209,
- 210 => 1.0E+210,
- 211 => 1.0E+211,
- 212 => 1.0E+212,
- 213 => 1.0E+213,
- 214 => 1.0E+214,
- 215 => 1.0E+215,
- 216 => 1.0E+216,
- 217 => 1.0E+217,
- 218 => 1.0E+218,
- 219 => 1.0E+219,
- 220 => 1.0E+220,
- 221 => 1.0E+221,
- 222 => 1.0E+222,
- 223 => 1.0E+223,
- 224 => 1.0E+224,
- 225 => 1.0E+225,
- 226 => 1.0E+226,
- 227 => 1.0E+227,
- 228 => 1.0E+228,
- 229 => 1.0E+229,
- 230 => 1.0E+230,
- 231 => 1.0E+231,
- 232 => 1.0E+232,
- 233 => 1.0E+233,
- 234 => 1.0E+234,
- 235 => 1.0E+235,
- 236 => 1.0E+236,
- 237 => 1.0E+237,
- 238 => 1.0E+238,
- 239 => 1.0E+239,
- 240 => 1.0E+240,
- 241 => 1.0E+241,
- 242 => 1.0E+242,
- 243 => 1.0E+243,
- 244 => 1.0E+244,
- 245 => 1.0E+245,
- 246 => 1.0E+246,
- 247 => 1.0E+247,
- 248 => 1.0E+248,
- 249 => 1.0E+249,
- 250 => 1.0E+250,
- 251 => 1.0E+251,
- 252 => 1.0E+252,
- 253 => 1.0E+253,
- 254 => 1.0E+254,
- 255 => 1.0E+255,
- 256 => 1.0E+256,
- 257 => 1.0E+257,
- 258 => 1.0E+258,
- 259 => 1.0E+259,
- 260 => 1.0E+260,
- 261 => 1.0E+261,
- 262 => 1.0E+262,
- 263 => 1.0E+263,
- 264 => 1.0E+264,
- 265 => 1.0E+265,
- 266 => 1.0E+266,
- 267 => 1.0E+267,
- 268 => 1.0E+268,
- 269 => 1.0E+269,
- 270 => 1.0E+270,
- 271 => 1.0E+271,
- 272 => 1.0E+272,
- 273 => 1.0E+273,
- 274 => 1.0E+274,
- 275 => 1.0E+275,
- 276 => 1.0E+276,
- 277 => 1.0E+277,
- 278 => 1.0E+278,
- 279 => 1.0E+279,
- 280 => 1.0E+280,
- 281 => 1.0E+281,
- 282 => 1.0E+282,
- 283 => 1.0E+283,
- 284 => 1.0E+284,
- 285 => 1.0E+285,
- 286 => 1.0E+286,
- 287 => 1.0E+287,
- 288 => 1.0E+288,
- 289 => 1.0E+289,
- 290 => 1.0E+290,
- 291 => 1.0E+291,
- 292 => 1.0E+292,
- 293 => 1.0E+293,
- 294 => 1.0E+294,
- 295 => 1.0E+295,
- 296 => 1.0E+296,
- 297 => 1.0E+297,
- 298 => 1.0E+298,
- 299 => 1.0E+299,
- 300 => 1.0E+300,
- 301 => 1.0E+301,
- 302 => 1.0E+302,
- 303 => 1.0E+303,
- 304 => 1.0E+304,
- 305 => 1.0E+305,
- 306 => 1.0E+306,
- 307 => 1.0E+307,
- 308 => 1.0E+308);
+ Maxpow : constant := Maxpow_Exact * 2;
+ -- Largest power of ten exactly representable with a double Long_Float
+
+ Powten : constant array (0 .. Maxpow, 1 .. 2) of Long_Float :=
+ (00 => (1.0E+00, 0.0),
+ 01 => (1.0E+01, 0.0),
+ 02 => (1.0E+02, 0.0),
+ 03 => (1.0E+03, 0.0),
+ 04 => (1.0E+04, 0.0),
+ 05 => (1.0E+05, 0.0),
+ 06 => (1.0E+06, 0.0),
+ 07 => (1.0E+07, 0.0),
+ 08 => (1.0E+08, 0.0),
+ 09 => (1.0E+09, 0.0),
+ 10 => (1.0E+10, 0.0),
+ 11 => (1.0E+11, 0.0),
+ 12 => (1.0E+12, 0.0),
+ 13 => (1.0E+13, 0.0),
+ 14 => (1.0E+14, 0.0),
+ 15 => (1.0E+15, 0.0),
+ 16 => (1.0E+16, 0.0),
+ 17 => (1.0E+17, 0.0),
+ 18 => (1.0E+18, 0.0),
+ 19 => (1.0E+19, 0.0),
+ 20 => (1.0E+20, 0.0),
+ 21 => (1.0E+21, 0.0),
+ 22 => (1.0E+22, 0.0),
+ 23 => (1.0E+23, 1.0E+23 - Long_Float'Machine (1.0E+23)),
+ 24 => (1.0E+24, 1.0E+24 - Long_Float'Machine (1.0E+24)),
+ 25 => (1.0E+25, 1.0E+25 - Long_Float'Machine (1.0E+25)),
+ 26 => (1.0E+26, 1.0E+26 - Long_Float'Machine (1.0E+26)),
+ 27 => (1.0E+27, 1.0E+27 - Long_Float'Machine (1.0E+27)),
+ 28 => (1.0E+28, 1.0E+28 - Long_Float'Machine (1.0E+28)),
+ 29 => (1.0E+29, 1.0E+29 - Long_Float'Machine (1.0E+29)),
+ 30 => (1.0E+30, 1.0E+30 - Long_Float'Machine (1.0E+30)),
+ 31 => (1.0E+31, 1.0E+31 - Long_Float'Machine (1.0E+31)),
+ 32 => (1.0E+32, 1.0E+32 - Long_Float'Machine (1.0E+32)),
+ 33 => (1.0E+33, 1.0E+33 - Long_Float'Machine (1.0E+33)),
+ 34 => (1.0E+34, 1.0E+34 - Long_Float'Machine (1.0E+34)),
+ 35 => (1.0E+35, 1.0E+35 - Long_Float'Machine (1.0E+35)),
+ 36 => (1.0E+36, 1.0E+36 - Long_Float'Machine (1.0E+36)),
+ 37 => (1.0E+37, 1.0E+37 - Long_Float'Machine (1.0E+37)),
+ 38 => (1.0E+38, 1.0E+38 - Long_Float'Machine (1.0E+38)),
+ 39 => (1.0E+39, 1.0E+39 - Long_Float'Machine (1.0E+39)),
+ 40 => (1.0E+40, 1.0E+40 - Long_Float'Machine (1.0E+40)),
+ 41 => (1.0E+41, 1.0E+41 - Long_Float'Machine (1.0E+41)),
+ 42 => (1.0E+42, 1.0E+42 - Long_Float'Machine (1.0E+42)),
+ 43 => (1.0E+43, 1.0E+43 - Long_Float'Machine (1.0E+43)),
+ 44 => (1.0E+44, 1.0E+44 - Long_Float'Machine (1.0E+44)));
end System.Powten_LFlt;
diff --git a/gcc/ada/libgnat/s-powllf.ads b/gcc/ada/libgnat/s-powllf.ads
index c5c42a1..b1f8ae9 100644
--- a/gcc/ada/libgnat/s-powllf.ads
+++ b/gcc/ada/libgnat/s-powllf.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -34,37 +34,70 @@
package System.Powten_LLF is
pragma Pure;
- Maxpow : constant := 22;
- -- The number of entries in this table is chosen to include powers of ten
- -- that are exactly representable with Long_Long_Float. Assuming that on
- -- all targets we have 53 bits of mantissa for the type, the upper bound
- -- is given by 53 * log 2 / log 5. If the scaling factor is greater than
- -- Maxpow, it can be obtained by several multiplications, which is less
- -- efficient than with a bigger table, but avoids anomalies at end points.
+ Maxpow_Exact : constant :=
+ (if Long_Long_Float'Machine_Mantissa = 64 then 27 else 22);
+ -- Largest power of ten exactly representable with Long_Long_Float. It is
+ -- equal to floor (M * log 2 / log 5), when M is the size of the mantissa
+ -- assumed to be either 64 for IEEE Extended or 53 for IEEE Double.
- Powten : constant array (0 .. Maxpow) of Long_Long_Float :=
- (00 => 1.0E+00,
- 01 => 1.0E+01,
- 02 => 1.0E+02,
- 03 => 1.0E+03,
- 04 => 1.0E+04,
- 05 => 1.0E+05,
- 06 => 1.0E+06,
- 07 => 1.0E+07,
- 08 => 1.0E+08,
- 09 => 1.0E+09,
- 10 => 1.0E+10,
- 11 => 1.0E+11,
- 12 => 1.0E+12,
- 13 => 1.0E+13,
- 14 => 1.0E+14,
- 15 => 1.0E+15,
- 16 => 1.0E+16,
- 17 => 1.0E+17,
- 18 => 1.0E+18,
- 19 => 1.0E+19,
- 20 => 1.0E+20,
- 21 => 1.0E+21,
- 22 => 1.0E+22);
+ Maxpow : constant := Maxpow_Exact * 2;
+ -- Largest power of ten exactly representable with a double Long_Long_Float
+
+ Powten : constant array (0 .. 54, 1 .. 2) of Long_Long_Float :=
+ (00 => (1.0E+00, 0.0),
+ 01 => (1.0E+01, 0.0),
+ 02 => (1.0E+02, 0.0),
+ 03 => (1.0E+03, 0.0),
+ 04 => (1.0E+04, 0.0),
+ 05 => (1.0E+05, 0.0),
+ 06 => (1.0E+06, 0.0),
+ 07 => (1.0E+07, 0.0),
+ 08 => (1.0E+08, 0.0),
+ 09 => (1.0E+09, 0.0),
+ 10 => (1.0E+10, 0.0),
+ 11 => (1.0E+11, 0.0),
+ 12 => (1.0E+12, 0.0),
+ 13 => (1.0E+13, 0.0),
+ 14 => (1.0E+14, 0.0),
+ 15 => (1.0E+15, 0.0),
+ 16 => (1.0E+16, 0.0),
+ 17 => (1.0E+17, 0.0),
+ 18 => (1.0E+18, 0.0),
+ 19 => (1.0E+19, 0.0),
+ 20 => (1.0E+20, 0.0),
+ 21 => (1.0E+21, 0.0),
+ 22 => (1.0E+22, 0.0),
+ 23 => (1.0E+23, 1.0E+23 - Long_Long_Float'Machine (1.0E+23)),
+ 24 => (1.0E+24, 1.0E+24 - Long_Long_Float'Machine (1.0E+24)),
+ 25 => (1.0E+25, 1.0E+25 - Long_Long_Float'Machine (1.0E+25)),
+ 26 => (1.0E+26, 1.0E+26 - Long_Long_Float'Machine (1.0E+26)),
+ 27 => (1.0E+27, 1.0E+27 - Long_Long_Float'Machine (1.0E+27)),
+ 28 => (1.0E+28, 1.0E+28 - Long_Long_Float'Machine (1.0E+28)),
+ 29 => (1.0E+29, 1.0E+29 - Long_Long_Float'Machine (1.0E+29)),
+ 30 => (1.0E+30, 1.0E+30 - Long_Long_Float'Machine (1.0E+30)),
+ 31 => (1.0E+31, 1.0E+31 - Long_Long_Float'Machine (1.0E+31)),
+ 32 => (1.0E+32, 1.0E+32 - Long_Long_Float'Machine (1.0E+32)),
+ 33 => (1.0E+33, 1.0E+33 - Long_Long_Float'Machine (1.0E+33)),
+ 34 => (1.0E+34, 1.0E+34 - Long_Long_Float'Machine (1.0E+34)),
+ 35 => (1.0E+35, 1.0E+35 - Long_Long_Float'Machine (1.0E+35)),
+ 36 => (1.0E+36, 1.0E+36 - Long_Long_Float'Machine (1.0E+36)),
+ 37 => (1.0E+37, 1.0E+37 - Long_Long_Float'Machine (1.0E+37)),
+ 38 => (1.0E+38, 1.0E+38 - Long_Long_Float'Machine (1.0E+38)),
+ 39 => (1.0E+39, 1.0E+39 - Long_Long_Float'Machine (1.0E+39)),
+ 40 => (1.0E+40, 1.0E+40 - Long_Long_Float'Machine (1.0E+40)),
+ 41 => (1.0E+41, 1.0E+41 - Long_Long_Float'Machine (1.0E+41)),
+ 42 => (1.0E+42, 1.0E+42 - Long_Long_Float'Machine (1.0E+42)),
+ 43 => (1.0E+43, 1.0E+43 - Long_Long_Float'Machine (1.0E+43)),
+ 44 => (1.0E+44, 1.0E+44 - Long_Long_Float'Machine (1.0E+44)),
+ 45 => (1.0E+45, 1.0E+45 - Long_Long_Float'Machine (1.0E+45)),
+ 46 => (1.0E+46, 1.0E+46 - Long_Long_Float'Machine (1.0E+46)),
+ 47 => (1.0E+47, 1.0E+47 - Long_Long_Float'Machine (1.0E+47)),
+ 48 => (1.0E+48, 1.0E+48 - Long_Long_Float'Machine (1.0E+48)),
+ 49 => (1.0E+49, 1.0E+49 - Long_Long_Float'Machine (1.0E+49)),
+ 50 => (1.0E+50, 1.0E+50 - Long_Long_Float'Machine (1.0E+50)),
+ 51 => (1.0E+51, 1.0E+51 - Long_Long_Float'Machine (1.0E+51)),
+ 52 => (1.0E+52, 1.0E+52 - Long_Long_Float'Machine (1.0E+52)),
+ 53 => (1.0E+53, 1.0E+53 - Long_Long_Float'Machine (1.0E+53)),
+ 54 => (1.0E+54, 1.0E+54 - Long_Long_Float'Machine (1.0E+54)));
end System.Powten_LLF;
diff --git a/gcc/ada/libgnat/s-purexc.ads b/gcc/ada/libgnat/s-purexc.ads
index 4c727d7..6346f4f 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2000-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-putima.adb b/gcc/ada/libgnat/s-putima.adb
index 925c3b9..33960a4 100644
--- a/gcc/ada/libgnat/s-putima.adb
+++ b/gcc/ada/libgnat/s-putima.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2020-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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,10 +29,10 @@
-- --
------------------------------------------------------------------------------
+with Ada.Strings.Text_Buffers.Utils;
+use Ada.Strings.Text_Buffers;
+use Ada.Strings.Text_Buffers.Utils;
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
@@ -215,7 +215,7 @@ package body System.Put_Images is
begin
New_Line (S);
Put_7bit (S, '[');
- Indent (S, 1);
+ Increase_Indent (S, 1);
end Array_Before;
procedure Array_Between (S : in out Sink'Class) is
@@ -226,7 +226,7 @@ package body System.Put_Images is
procedure Array_After (S : in out Sink'Class) is
begin
- Outdent (S, 1);
+ Decrease_Indent (S, 1);
Put_7bit (S, ']');
end Array_After;
@@ -244,7 +244,7 @@ package body System.Put_Images is
begin
New_Line (S);
Put_7bit (S, '(');
- Indent (S, 1);
+ Increase_Indent (S, 1);
end Record_Before;
procedure Record_Between (S : in out Sink'Class) is
@@ -255,7 +255,7 @@ package body System.Put_Images is
procedure Record_After (S : in out Sink'Class) is
begin
- Outdent (S, 1);
+ Decrease_Indent (S, 1);
Put_7bit (S, ')');
end Record_After;
@@ -267,7 +267,7 @@ package body System.Put_Images is
procedure Put_Image_Unknown (S : in out Sink'Class; Type_Name : String) is
begin
Put_UTF_8 (S, "{");
- Put_String (S, Type_Name);
+ Put (S, Type_Name);
Put_UTF_8 (S, " object}");
end Put_Image_Unknown;
diff --git a/gcc/ada/libgnat/s-putima.ads b/gcc/ada/libgnat/s-putima.ads
index 1d2a11d..4a33e79 100644
--- a/gcc/ada/libgnat/s-putima.ads
+++ b/gcc/ada/libgnat/s-putima.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2020-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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,7 @@
-- --
------------------------------------------------------------------------------
-with Ada.Strings.Text_Output;
+with Ada.Strings.Text_Buffers;
with System.Unsigned_Types;
package System.Put_Images with Pure is
@@ -50,7 +50,7 @@ package System.Put_Images with Pure is
pragma Preelaborate;
- subtype Sink is Ada.Strings.Text_Output.Sink;
+ subtype Sink is Ada.Strings.Text_Buffers.Root_Buffer_Type;
procedure Put_Image_Integer (S : in out Sink'Class; X : Integer);
procedure Put_Image_Long_Long_Integer
diff --git a/gcc/ada/libgnat/s-rannum.adb b/gcc/ada/libgnat/s-rannum.adb
index ab6428f..92a91a6 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2007-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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,7 +86,6 @@
-- --
------------------------------------------------------------------------------
-with Ada.Strings.Text_Output.Utils;
with Ada.Unchecked_Conversion;
with System.Random_Seed;
@@ -178,7 +177,10 @@ is
function Random (Gen : Generator) return Unsigned_32 is
G : Generator renames Gen.Writable.Self.all;
Y : State_Val;
- I : Integer; -- should avoid use of identifier I ???
+ I : Integer;
+ -- Naming exception: I is fine to use here as it is the name used in
+ -- the original paper describing the Mersenne Twister and in common
+ -- descriptions of the algorithm.
begin
I := G.I;
@@ -686,9 +688,9 @@ is
---------------
procedure Put_Image
- (S : in out Strings.Text_Output.Sink'Class; V : State) is
+ (S : in out Strings.Text_Buffers.Root_Buffer_Type'Class; V : State) is
begin
- Strings.Text_Output.Utils.Put_String (S, Image (V));
+ Strings.Text_Buffers.Put (S, Image (V));
end Put_Image;
-----------
diff --git a/gcc/ada/libgnat/s-rannum.ads b/gcc/ada/libgnat/s-rannum.ads
index 6cbba3e..99ed57d 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2007-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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,7 @@
with Interfaces;
-private with Ada.Strings.Text_Output;
+private with Ada.Strings.Text_Buffers;
package System.Random_Numbers with
SPARK_Mode => Off
@@ -148,7 +148,7 @@ private
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);
+ (S : in out Ada.Strings.Text_Buffers.Root_Buffer_Type'Class; V : State);
type Writable_Access (Self : access Generator) is limited null record;
-- Auxiliary type to make Generator a self-referential type
@@ -162,7 +162,9 @@ private
I : Integer := N;
-- Current starting position in shift register S (N means uninitialized)
- -- We should avoid using the identifier I here ???
+ -- Naming exception: I is fine to use here as it is the name used in the
+ -- original paper describing the Mersenne Twister and in common
+ -- descriptions of the algorithm.
end record;
end System.Random_Numbers;
diff --git a/gcc/ada/libgnat/s-ransee.adb b/gcc/ada/libgnat/s-ransee.adb
index 0c168df..b12ed0b 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2011-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 559eaa0..9deef1a 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2011-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 f8adc4a..51ff39c 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-2020, AdaCore --
+-- Copyright (C) 1999-2021, 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 243da67..3c57d99 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-2020, AdaCore --
+-- Copyright (C) 1998-2021, 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-regpat.adb b/gcc/ada/libgnat/s-regpat.adb
index 2e60ba8..7e33067 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-2020, AdaCore --
+-- Copyright (C) 1999-2021, 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-regpat.ads b/gcc/ada/libgnat/s-regpat.ads
index 0a591fd..b1a1366f 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-2020, AdaCore --
+-- Copyright (C) 1996-2021, 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 145aeb0..e37db4a 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2007-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 369f2f4..63437ae 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2007-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 5c91d13..d1f261b 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 221b83a..b46ae46 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 c6c3d3d..10d374e 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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,7 @@ package System.Rident is
No_Direct_Boolean_Operators, -- GNAT
No_Dispatch, -- (RM H.4(19))
No_Dispatching_Calls, -- GNAT
+ No_Dynamic_Accessibility_Checks, -- 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))
diff --git a/gcc/ada/libgnat/s-rpc.adb b/gcc/ada/libgnat/s-rpc.adb
index f4c719f..1f501fe 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 7695b8f..e8927bd 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, 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 5a88111..81394af 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2003-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -60,26 +60,17 @@ package body System.Scalar_Values is
EFloat : constant Boolean := Long_Long_Float'Size > Long_Float'Size;
-- Set True if we are on an x86 with 96-bit floats for extended
- AFloat : constant Boolean :=
- Long_Float'Size = 48 and then Long_Long_Float'Size = 48;
- -- Set True if we are on an AAMP with 48-bit extended floating point
-
- type ByteLF is array (0 .. 7 - 2 * Boolean'Pos (AFloat)) of Byte1;
+ type ByteLF is array (0 .. 7) of Byte1;
for ByteLF'Component_Size use 8;
- -- Type used to hold Long_Float values on all targets and to initialize
- -- 48-bit Long_Float values used on AAMP. On AAMP, this type is 6 bytes.
- -- On other targets the type is 8 bytes, and type Byte8 is used for
- -- values that are then converted to ByteLF.
+ -- Type used to hold Long_Float values on all targets. On most targets
+ -- the type is 8 bytes, and type Byte8 is used for values that are then
+ -- converted to ByteLF.
- pragma Warnings (Off); -- why ???
function To_ByteLF is new Ada.Unchecked_Conversion (Byte8, ByteLF);
- pragma Warnings (On);
- type ByteLLF is
- array (0 .. 7 + 4 * Boolean'Pos (EFloat) - 2 * Boolean'Pos (AFloat))
- of Byte1;
+ type ByteLLF is array (0 .. 7 + 4 * Boolean'Pos (EFloat)) of Byte1;
for ByteLLF'Component_Size use 8;
@@ -186,16 +177,9 @@ package body System.Scalar_Values is
IS_Iz4 := 16#0000_0000#;
IS_Iz8 := 16#0000_0000_0000_0000#;
- if AFloat then
- IV_Isf := 16#FFFF_FF00#;
- IV_Ifl := 16#FFFF_FF00#;
- IV_Ilf := (0, 16#FF#, 16#FF#, 16#FF#, 16#FF#, 16#FF#);
-
- else
- IV_Isf := IS_Iu4;
- IV_Ifl := IS_Iu4;
- IV_Ilf := To_ByteLF (IS_Iu8);
- end if;
+ IV_Isf := IS_Iu4;
+ IV_Ifl := IS_Iu4;
+ IV_Ilf := To_ByteLF (IS_Iu8);
if EFloat then
IV_Ill := (0, 0, 0, 0, 0, 0, 0, 16#C0#, 16#FF#, 16#FF#, 0, 0);
@@ -219,16 +203,9 @@ package body System.Scalar_Values is
IS_Iz4 := 16#0000_0000#;
IS_Iz8 := 16#0000_0000_0000_0000#;
- if AFloat then
- IV_Isf := 16#0000_0001#;
- IV_Ifl := 16#0000_0001#;
- IV_Ilf := (1, 0, 0, 0, 0, 0);
-
- else
- IV_Isf := 16#FF80_0000#;
- IV_Ifl := 16#FF80_0000#;
- IV_Ilf := To_ByteLF (16#FFF0_0000_0000_0000#);
- end if;
+ IV_Isf := 16#FF80_0000#;
+ IV_Ifl := 16#FF80_0000#;
+ IV_Ilf := To_ByteLF (16#FFF0_0000_0000_0000#);
if EFloat then
IV_Ill := (0, 0, 0, 0, 0, 0, 0, 16#80#, 16#FF#, 16#FF#, 0, 0);
@@ -252,16 +229,9 @@ package body System.Scalar_Values is
IS_Iz4 := 16#FFFF_FFFF#;
IS_Iz8 := 16#FFFF_FFFF_FFFF_FFFF#;
- if AFloat then
- IV_Isf := 16#7FFF_FFFF#;
- IV_Ifl := 16#7FFF_FFFF#;
- IV_Ilf := (16#FF#, 16#FF#, 16#FF#, 16#FF#, 16#FF#, 16#7F#);
-
- else
- IV_Isf := 16#7F80_0000#;
- IV_Ifl := 16#7F80_0000#;
- IV_Ilf := To_ByteLF (16#7FF0_0000_0000_0000#);
- end if;
+ IV_Isf := 16#7F80_0000#;
+ IV_Ifl := 16#7F80_0000#;
+ IV_Ilf := To_ByteLF (16#7FF0_0000_0000_0000#);
if EFloat then
IV_Ill := (0, 0, 0, 0, 0, 0, 0, 16#80#, 16#FF#, 16#7F#, 0, 0);
@@ -301,11 +271,7 @@ package body System.Scalar_Values is
IV_Isf := IS_Is4;
IV_Ifl := IS_Is4;
- if AFloat then
- IV_Ill := (B, B, B, B, B, B);
- else
- IV_Ilf := To_ByteLF (IS_Is8);
- end if;
+ IV_Ilf := To_ByteLF (IS_Is8);
if EFloat then
IV_Ill := (B, B, B, B, B, B, B, B, B, B, B, B);
@@ -317,7 +283,7 @@ package body System.Scalar_Values is
if not EFloat then
declare
- pragma Warnings (Off); -- why???
+ pragma Warnings (Off); -- because sizes don't match
function To_ByteLLF is
new Ada.Unchecked_Conversion (ByteLF, ByteLLF);
pragma Warnings (On);
diff --git a/gcc/ada/libgnat/s-scaval.ads b/gcc/ada/libgnat/s-scaval.ads
index 6d13262..47de115 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2001-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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__128.adb b/gcc/ada/libgnat/s-scaval__128.adb
index 53110c2..7bb5696 100644
--- a/gcc/ada/libgnat/s-scaval__128.adb
+++ b/gcc/ada/libgnat/s-scaval__128.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2003-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2003-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -60,26 +60,12 @@ package body System.Scalar_Values is
EFloat : constant Boolean := Long_Long_Float'Size > Long_Float'Size;
-- Set True if we are on an x86 with 96-bit floats for extended
- AFloat : constant Boolean :=
- Long_Float'Size = 48 and then Long_Long_Float'Size = 48;
- -- Set True if we are on an AAMP with 48-bit extended floating point
-
- type ByteLF is array (0 .. 7 - 2 * Boolean'Pos (AFloat)) of Byte1;
+ type ByteLF is array (0 .. 7) of Byte1;
for ByteLF'Component_Size use 8;
-
- -- Type used to hold Long_Float values on all targets and to initialize
- -- 48-bit Long_Float values used on AAMP. On AAMP, this type is 6 bytes.
- -- On other targets the type is 8 bytes, and type Byte8 is used for
- -- values that are then converted to ByteLF.
-
- pragma Warnings (Off); -- why ???
function To_ByteLF is new Ada.Unchecked_Conversion (Byte8, ByteLF);
- pragma Warnings (On);
- type ByteLLF is
- array (0 .. 7 + 4 * Boolean'Pos (EFloat) - 2 * Boolean'Pos (AFloat))
- of Byte1;
+ type ByteLLF is array (0 .. 7 + 4 * Boolean'Pos (EFloat)) of Byte1;
for ByteLLF'Component_Size use 8;
@@ -189,16 +175,9 @@ package body System.Scalar_Values is
IS_Iz8 := 16#0000_0000_0000_0000#;
IS_Iz16 := 16#0000_0000_0000_0000_0000_0000_0000_0000#;
- if AFloat then
- IV_Isf := 16#FFFF_FF00#;
- IV_Ifl := 16#FFFF_FF00#;
- IV_Ilf := (0, 16#FF#, 16#FF#, 16#FF#, 16#FF#, 16#FF#);
-
- else
- IV_Isf := IS_Iu4;
- IV_Ifl := IS_Iu4;
- IV_Ilf := To_ByteLF (IS_Iu8);
- end if;
+ IV_Isf := IS_Iu4;
+ IV_Ifl := IS_Iu4;
+ IV_Ilf := To_ByteLF (IS_Iu8);
if EFloat then
IV_Ill := (0, 0, 0, 0, 0, 0, 0, 16#C0#, 16#FF#, 16#FF#, 0, 0);
@@ -225,16 +204,9 @@ package body System.Scalar_Values is
IS_Iz8 := 16#0000_0000_0000_0000#;
IS_Iz16 := 16#0000_0000_0000_0000_0000_0000_0000_0000#;
- if AFloat then
- IV_Isf := 16#0000_0001#;
- IV_Ifl := 16#0000_0001#;
- IV_Ilf := (1, 0, 0, 0, 0, 0);
-
- else
- IV_Isf := 16#FF80_0000#;
- IV_Ifl := 16#FF80_0000#;
- IV_Ilf := To_ByteLF (16#FFF0_0000_0000_0000#);
- end if;
+ IV_Isf := 16#FF80_0000#;
+ IV_Ifl := 16#FF80_0000#;
+ IV_Ilf := To_ByteLF (16#FFF0_0000_0000_0000#);
if EFloat then
IV_Ill := (0, 0, 0, 0, 0, 0, 0, 16#80#, 16#FF#, 16#FF#, 0, 0);
@@ -261,16 +233,9 @@ package body System.Scalar_Values is
IS_Iz8 := 16#FFFF_FFFF_FFFF_FFFF#;
IS_Iz16 := 16#FFFF_FFFF_FFFF_FFFF_FFFF_FFFF_FFFF_FFFF#;
- if AFloat then
- IV_Isf := 16#7FFF_FFFF#;
- IV_Ifl := 16#7FFF_FFFF#;
- IV_Ilf := (16#FF#, 16#FF#, 16#FF#, 16#FF#, 16#FF#, 16#7F#);
-
- else
- IV_Isf := 16#7F80_0000#;
- IV_Ifl := 16#7F80_0000#;
- IV_Ilf := To_ByteLF (16#7FF0_0000_0000_0000#);
- end if;
+ IV_Isf := 16#7F80_0000#;
+ IV_Ifl := 16#7F80_0000#;
+ IV_Ilf := To_ByteLF (16#7FF0_0000_0000_0000#);
if EFloat then
IV_Ill := (0, 0, 0, 0, 0, 0, 0, 16#80#, 16#FF#, 16#7F#, 0, 0);
@@ -313,11 +278,7 @@ package body System.Scalar_Values is
IV_Isf := IS_Is4;
IV_Ifl := IS_Is4;
- if AFloat then
- IV_Ill := (B, B, B, B, B, B);
- else
- IV_Ilf := To_ByteLF (IS_Is8);
- end if;
+ IV_Ilf := To_ByteLF (IS_Is8);
if EFloat then
IV_Ill := (B, B, B, B, B, B, B, B, B, B, B, B);
@@ -329,7 +290,7 @@ package body System.Scalar_Values is
if not EFloat then
declare
- pragma Warnings (Off); -- why???
+ pragma Warnings (Off); -- because sizes don't match
function To_ByteLLF is
new Ada.Unchecked_Conversion (ByteLF, ByteLLF);
pragma Warnings (On);
diff --git a/gcc/ada/libgnat/s-scaval__128.ads b/gcc/ada/libgnat/s-scaval__128.ads
index 8eb1b65..e96122b 100644
--- a/gcc/ada/libgnat/s-scaval__128.ads
+++ b/gcc/ada/libgnat/s-scaval__128.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2001-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2001-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 f2d264d..db64c52 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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.ads b/gcc/ada/libgnat/s-secsta.ads
index 504c891..7d6b1b9 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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.adb b/gcc/ada/libgnat/s-sequio.adb
index 03610e3..e314db4 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 17ed929..e497760 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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
index c4f6944..c1a7a3f 100644
--- a/gcc/ada/libgnat/s-shabig.ads
+++ b/gcc/ada/libgnat/s-shabig.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2012-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2012-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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.adb b/gcc/ada/libgnat/s-shasto.adb
index 0117344..a1f5a95 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1998-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 189b5e1..a76d3d9 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1998-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 48d1338..119bea1 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 d0caa79..4786262 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 f5e4ba7..4fd335f 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2017-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 2726702..4159a3a 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2017-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 5953c06..94e2d38 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 9743938..92cdffb 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 5dae861..a8d0dd8 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 0e0f3a3..899c9f7 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 0acbf3b..e3ee0dc 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 df233fc..5b032d1 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 6702ed1..ad34ff2 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2011-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 d8143ef..03d9639 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2011-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 7f55f17..e3ac368 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1999-2021, 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 45d2da0..3e0662e 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1999-2021, 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 7c60013..ae62377 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1995-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 b6258ed..fb6e992 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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,44 +86,46 @@ package System.Standard_Library is
-- The following record defines the underlying representation of exceptions
- -- WARNING: Any changes to this may need to be reflected in the following
+ -- WARNING: Any change to the record needs to be reflected in the following
-- locations in the compiler and runtime code:
- -- 1. The Internal_Exception routine in s-exctab.adb
- -- 2. The processing in gigi that tests Not_Handled_By_Others
- -- 3. Expand_N_Exception_Declaration in Exp_Ch11
- -- 4. The construction of the exception type in Cstand
+ -- 1. The construction of the exception type in Cstand
+ -- 2. Expand_N_Exception_Declaration in Exp_Ch11
+ -- 3. Expand_Pragma_Import_Or_Interface in Exp_Prag
+ -- 4. The processing in gigi that tests Not_Handled_By_Others
+ -- 5. The Internal_Exception routine in s-exctab.adb
+ -- 6. The declaration of the corresponding C type in raise.h
type Exception_Data is record
- Not_Handled_By_Others : Boolean;
+ Not_Handled_By_Others : aliased Boolean;
-- Normally set False, indicating that the exception is handled in the
-- usual way by others (i.e. an others handler handles the exception).
-- Set True to indicate that this exception is not caught by others
-- handlers, but must be explicitly named in a handler. This latter
-- setting is currently used by the Abort_Signal.
- Lang : Character;
+ Lang : aliased Character;
-- A character indicating the language raising the exception.
-- Set to "A" for exceptions defined by an Ada program.
-- Set to "C" for imported C++ exceptions.
- Name_Length : Natural;
+ Name_Length : aliased Natural;
-- Length of fully expanded name of exception
- Full_Name : System.Address;
+ Full_Name : aliased System.Address;
-- Fully expanded name of exception, null terminated
-- You can use To_Ptr to convert this to a string.
- HTable_Ptr : Exception_Data_Ptr;
+ HTable_Ptr : aliased Exception_Data_Ptr;
-- Hash table pointer used to link entries together in the hash table
-- built (by Register_Exception in s-exctab.adb) for converting between
-- identities and names.
- Foreign_Data : Address;
+ Foreign_Data : aliased System.Address;
-- Data for imported exceptions. Not used in the Ada case. This
-- represents the address of the RTTI for the C++ case.
- Raise_Hook : Raise_Action;
+ Raise_Hook : aliased Raise_Action;
-- This field can be used to place a "hook" on an exception. If the
-- value is non-null, then it points to a procedure which is called
-- whenever the exception is raised. This call occurs immediately,
diff --git a/gcc/ada/libgnat/s-statxd.adb b/gcc/ada/libgnat/s-statxd.adb
index fcefae7..af88f7d 100644
--- a/gcc/ada/libgnat/s-statxd.adb
+++ b/gcc/ada/libgnat/s-statxd.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1996-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1996-2021, 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- --
diff --git a/gcc/ada/libgnat/s-statxd.ads b/gcc/ada/libgnat/s-statxd.ads
index cca5e54..e47eec1 100644
--- a/gcc/ada/libgnat/s-statxd.ads
+++ b/gcc/ada/libgnat/s-statxd.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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.adb b/gcc/ada/libgnat/s-stausa.adb
index e96dc7a..8bd6c5b 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2021, 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 8803237..2d7feee 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2021, 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 340d27b..16b8d26 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1999-2021, 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 185301c..2b8acee 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1999-2021, 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 7330676..28d6802 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1999-2021, 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 56b1747..f273f29 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1999-2021, 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 f277426..4146522 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1999-2021, 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 69cb832..87c6d49 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 4abac8e..62e9ca8 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2002-2021, 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 --
@@ -56,8 +56,7 @@ package System.Storage_Elements is
+(2 ** (Integer'(Standard'Address_Size) - 1)) - Long_Long_Integer'(1);
-- Note: the reason for the Long_Long_Integer qualification here is to
-- avoid a bogus ambiguity when this unit is analyzed in an rtsfind
- -- context. It may be possible to remove this in the future, but it is
- -- certainly harmless in any case ???
+ -- context.
subtype Storage_Count is Storage_Offset range 0 .. Storage_Offset'Last;
diff --git a/gcc/ada/libgnat/s-stopoo.adb b/gcc/ada/libgnat/s-stopoo.adb
index a9590d4..0e38413 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2009-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 b79a038f..5bfdca2 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, 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-stposu.adb b/gcc/ada/libgnat/s-stposu.adb
index ff61cfb..141d32b 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2011-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-stposu.ads b/gcc/ada/libgnat/s-stposu.ads
index 2653f3d..1441b24 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2011-2021, 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-stratt.adb b/gcc/ada/libgnat/s-stratt.adb
index 8fe2721..5f04153 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-stratt.ads b/gcc/ada/libgnat/s-stratt.ads
index 965dff6..9e6d001 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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.adb b/gcc/ada/libgnat/s-strcom.adb
index e3167b4..5f0f9d2 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2002-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 b77d442..d4271ec 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2002-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 05c56ae..7974b02 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2009-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 07a5928..d81ce50 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2009-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 f26f8d6..13a7d08 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1995-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 c93e4e62..3f5ebf4 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1995-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 6458060..1644d85 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 9b6028a..f72baff 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 cc2a352..c1f832a 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2008-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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.ads b/gcc/ada/libgnat/s-ststop.ads
index 5f35fed..a19cdc8 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2009-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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.adb b/gcc/ada/libgnat/s-tasloc.adb
index 17fc3ce..b451d2c 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-2020, AdaCore --
+-- Copyright (C) 1997-2021, 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 1820107..d9a7de5 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-2020, AdaCore --
+-- Copyright (C) 1998-2021, 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 a13e806..5d0a3c1 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 fcf1304..ecbd415 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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.adb b/gcc/ada/libgnat/s-traceb.adb
index b2cb6d8..d43d757 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1999-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 094218c..21e8af2 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1999-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 2d6b715..e5af76d 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2009-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 e24ec1b..e50bfdc 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-2020, AdaCore --
+-- Copyright (C) 1999-2021, 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 23d174f..a471ede 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2003-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 83ef569..a534dd8 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2003-2021, 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 bfc3a98..5ed1816 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-2020, AdaCore --
+-- Copyright (C) 1999-2021, 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 fbeec8d..e24d109 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-2020, AdaCore --
+-- Copyright (C) 1999-2021, 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 78cbcc2..61e7a1c 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-2020, AdaCore --
+-- Copyright (C) 1999-2021, 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.adb b/gcc/ada/libgnat/s-tsmona.adb
index 64db59a..f8134ff 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-2020, AdaCore --
+-- Copyright (C) 2012-2021, 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 98c9992..400b7ad 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-2020, AdaCore --
+-- Copyright (C) 2012-2021, 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 b79a3fc..42ec175 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-2020, AdaCore --
+-- Copyright (C) 2012-2021, 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 86c5d7f..197fd24 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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,9 +48,6 @@ package System.Unsigned_Types is
type Long_Long_Unsigned is mod 2 ** Long_Long_Integer'Size;
type Long_Long_Long_Unsigned is mod Max_Binary_Modulus;
- type Float_Unsigned is mod 2 ** Float'Size;
- -- Used in the implementation of Is_Negative intrinsic (see Exp_Intr)
-
type Packed_Byte is mod 2 ** 8;
for Packed_Byte'Size use 8;
pragma Universal_Aliasing (Packed_Byte);
diff --git a/gcc/ada/libgnat/s-utf_32.adb b/gcc/ada/libgnat/s-utf_32.adb
index a1346f3..4f5c749 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2005-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-utf_32.ads b/gcc/ada/libgnat/s-utf_32.ads
index e3f0e00..def16be 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2005-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-vade128.ads b/gcc/ada/libgnat/s-vade128.ads
index 8edc742..e96fa0d 100644
--- a/gcc/ada/libgnat/s-vade128.ads
+++ b/gcc/ada/libgnat/s-vade128.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2020-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-vade32.ads b/gcc/ada/libgnat/s-vade32.ads
index b86ae52..22888ad 100644
--- a/gcc/ada/libgnat/s-vade32.ads
+++ b/gcc/ada/libgnat/s-vade32.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2020-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-vade64.ads b/gcc/ada/libgnat/s-vade64.ads
index d3a5b4f..d52c139 100644
--- a/gcc/ada/libgnat/s-vade64.ads
+++ b/gcc/ada/libgnat/s-vade64.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2020-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-vaen16.ads b/gcc/ada/libgnat/s-vaen16.ads
new file mode 100644
index 0000000..6ea6071
--- /dev/null
+++ b/gcc/ada/libgnat/s-vaen16.ads
@@ -0,0 +1,61 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- S Y S T E M . V A L _ E N U M _ 1 6 --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 2021, Free Software Foundation, Inc. --
+-- --
+-- GNAT is 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. --
+-- --
+------------------------------------------------------------------------------
+
+-- Instantiation of System.Value_N for enumeration types whose names table
+-- has a length that fits in a 16-bit but not an 8-bit integer.
+
+with Interfaces;
+with System.Value_N;
+
+package System.Val_Enum_16 is
+ pragma Preelaborate;
+
+ package Impl is new Value_N (Interfaces.Integer_16);
+
+ function Value_Enumeration_16
+ (Names : String;
+ Indexes : System.Address;
+ Hash : Impl.Hash_Function_Ptr;
+ Num : Natural;
+ Str : String)
+ return Natural
+ renames Impl.Value_Enumeration;
+
+ function Valid_Value_Enumeration_16
+ (Names : String;
+ Indexes : System.Address;
+ Hash : Impl.Hash_Function_Ptr;
+ Num : Natural;
+ Str : String)
+ return Boolean
+ renames Impl.Valid_Value_Enumeration;
+
+end System.Val_Enum_16;
diff --git a/gcc/ada/libgnat/s-vaen32.ads b/gcc/ada/libgnat/s-vaen32.ads
new file mode 100644
index 0000000..e1a7644
--- /dev/null
+++ b/gcc/ada/libgnat/s-vaen32.ads
@@ -0,0 +1,61 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- S Y S T E M . V A L _ E N U M _ 3 2 --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 2021, Free Software Foundation, Inc. --
+-- --
+-- GNAT is 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. --
+-- --
+------------------------------------------------------------------------------
+
+-- Instantiation of System.Value_N for enumeration types whose names table
+-- has a length that fits in a 32-bit but not a 16-bit integer.
+
+with Interfaces;
+with System.Value_N;
+
+package System.Val_Enum_32 is
+ pragma Preelaborate;
+
+ package Impl is new Value_N (Interfaces.Integer_32);
+
+ function Value_Enumeration_32
+ (Names : String;
+ Indexes : System.Address;
+ Hash : Impl.Hash_Function_Ptr;
+ Num : Natural;
+ Str : String)
+ return Natural
+ renames Impl.Value_Enumeration;
+
+ function Valid_Value_Enumeration_32
+ (Names : String;
+ Indexes : System.Address;
+ Hash : Impl.Hash_Function_Ptr;
+ Num : Natural;
+ Str : String)
+ return Boolean
+ renames Impl.Valid_Value_Enumeration;
+
+end System.Val_Enum_32;
diff --git a/gcc/ada/libgnat/s-vaenu8.ads b/gcc/ada/libgnat/s-vaenu8.ads
new file mode 100644
index 0000000..395a969
--- /dev/null
+++ b/gcc/ada/libgnat/s-vaenu8.ads
@@ -0,0 +1,61 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- S Y S T E M . V A L _ E N U M _ 8 --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 2021, Free Software Foundation, Inc. --
+-- --
+-- GNAT is 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. --
+-- --
+------------------------------------------------------------------------------
+
+-- Instantiation of System.Value_N for enumeration types whose names table
+-- has a length that fits in an 8-bit integer.
+
+with Interfaces;
+with System.Value_N;
+
+package System.Val_Enum_8 is
+ pragma Preelaborate;
+
+ package Impl is new Value_N (Interfaces.Integer_8);
+
+ function Value_Enumeration_8
+ (Names : String;
+ Indexes : System.Address;
+ Hash : Impl.Hash_Function_Ptr;
+ Num : Natural;
+ Str : String)
+ return Natural
+ renames Impl.Value_Enumeration;
+
+ function Valid_Value_Enumeration_8
+ (Names : String;
+ Indexes : System.Address;
+ Hash : Impl.Hash_Function_Ptr;
+ Num : Natural;
+ Str : String)
+ return Boolean
+ renames Impl.Valid_Value_Enumeration;
+
+end System.Val_Enum_8;
diff --git a/gcc/ada/libgnat/s-vafi128.ads b/gcc/ada/libgnat/s-vafi128.ads
index 03fbe80..4961b96 100644
--- a/gcc/ada/libgnat/s-vafi128.ads
+++ b/gcc/ada/libgnat/s-vafi128.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2020-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-vafi32.ads b/gcc/ada/libgnat/s-vafi32.ads
index 6235a82..3a9c4ff 100644
--- a/gcc/ada/libgnat/s-vafi32.ads
+++ b/gcc/ada/libgnat/s-vafi32.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2020-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-vafi64.ads b/gcc/ada/libgnat/s-vafi64.ads
index 9f98df4..c5250db 100644
--- a/gcc/ada/libgnat/s-vafi64.ads
+++ b/gcc/ada/libgnat/s-vafi64.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2020-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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.adb b/gcc/ada/libgnat/s-valboo.adb
index e31d2bf..4ec1e19 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 94b81f9..2129c5ac 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 70deb33..587cdbb 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 a33c032..ee3b037 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-valflt.ads b/gcc/ada/libgnat/s-valflt.ads
index 5806d58..04ffb71 100644
--- a/gcc/ada/libgnat/s-valflt.ads
+++ b/gcc/ada/libgnat/s-valflt.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2020-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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,8 +32,8 @@
-- This package contains routines for scanning real values for floating point
-- type Float, for use in Text_IO.Float_IO and the Value attribute.
-with Interfaces;
with System.Powten_Flt;
+with System.Unsigned_Types;
with System.Val_Real;
package System.Val_Flt is
@@ -41,9 +41,9 @@ package System.Val_Flt is
package Impl is new Val_Real
(Float,
- Interfaces.Unsigned_32,
System.Powten_Flt.Maxpow,
- System.Powten_Flt.Powten'Address);
+ System.Powten_Flt.Powten'Address,
+ Unsigned_Types.Unsigned);
function Scan_Float
(Str : String;
diff --git a/gcc/ada/libgnat/s-valint.adb b/gcc/ada/libgnat/s-valint.adb
index 983d2d1..b3f0e29 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 8a3c55e..702f7442 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-vallfl.ads b/gcc/ada/libgnat/s-vallfl.ads
index c612f75..71da12a 100644
--- a/gcc/ada/libgnat/s-vallfl.ads
+++ b/gcc/ada/libgnat/s-vallfl.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2020-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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,8 +32,8 @@
-- This package contains routines for scanning real values for floating point
-- type Long_Float, for use in Text_IO.Float_IO and the Value attribute.
-with Interfaces;
with System.Powten_LFlt;
+with System.Unsigned_Types;
with System.Val_Real;
package System.Val_LFlt is
@@ -41,9 +41,9 @@ package System.Val_LFlt is
package Impl is new Val_Real
(Long_Float,
- Interfaces.Unsigned_64,
System.Powten_LFlt.Maxpow,
- System.Powten_LFlt.Powten'Address);
+ System.Powten_LFlt.Powten'Address,
+ Unsigned_Types.Long_Long_Unsigned);
function Scan_Long_Float
(Str : String;
diff --git a/gcc/ada/libgnat/s-valllf.ads b/gcc/ada/libgnat/s-valllf.ads
index 46a311b..477ed4e 100644
--- a/gcc/ada/libgnat/s-valllf.ads
+++ b/gcc/ada/libgnat/s-valllf.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2020-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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,8 +32,8 @@
-- This package contains routines for scanning real values for floating point
-- type Long_Long_Float, for use in Text_IO.Float_IO and the Value attribute.
-with Interfaces;
with System.Powten_LLF;
+with System.Unsigned_Types;
with System.Val_Real;
package System.Val_LLF is
@@ -41,9 +41,9 @@ package System.Val_LLF is
package Impl is new Val_Real
(Long_Long_Float,
- Interfaces.Unsigned_64,
System.Powten_LLF.Maxpow,
- System.Powten_LLF.Powten'Address);
+ System.Powten_LLF.Powten'Address,
+ System.Unsigned_Types.Long_Long_Unsigned);
function Scan_Long_Long_Float
(Str : String;
diff --git a/gcc/ada/libgnat/s-vallli.adb b/gcc/ada/libgnat/s-vallli.adb
index eadab12..4963c11 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 e53873e..f6527c2 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-valllli.ads b/gcc/ada/libgnat/s-valllli.ads
index 9ab7161..88aedaf 100644
--- a/gcc/ada/libgnat/s-valllli.ads
+++ b/gcc/ada/libgnat/s-valllli.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-vallllu.ads b/gcc/ada/libgnat/s-vallllu.ads
index 34ce282..2a1957a 100644
--- a/gcc/ada/libgnat/s-vallllu.ads
+++ b/gcc/ada/libgnat/s-vallllu.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 1afb632..67b6258 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 5c0300c..c282bc3 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 0ac3846..bc5465c 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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 System.Double_Real;
with System.Float_Control;
with System.Unsigned_Types; use System.Unsigned_Types;
with System.Val_Util; use System.Val_Util;
@@ -46,7 +47,7 @@ package body System.Val_Real is
-- If the mantissa of the floating-point type is almost as large as the
-- unsigned type, we do not have enough space for an extra digit in the
-- unsigned type so we handle the extra digit separately, at the cost of
- -- a potential roundoff error.
+ -- a bit more work in Integer_to_Real.
Precision_Limit : constant Uns :=
(if Need_Extra then 2**Num'Machine_Mantissa - 1 else 2**Uns'Size - 1);
@@ -76,6 +77,12 @@ package body System.Val_Real is
7 => 5836, 8 => 5461, 9 => 5168, 10 => 4932, 11 => 4736,
12 => 4570, 13 => 4427, 14 => 4303, 15 => 4193, 16 => 4095);
+ package Double_Real is new System.Double_Real (Num);
+ use type Double_Real.Double_T;
+
+ subtype Double_T is Double_Real.Double_T;
+ -- The double floating-point type
+
function Integer_to_Real
(Str : String;
Val : Uns;
@@ -85,6 +92,9 @@ package body System.Val_Real is
Minus : Boolean) return Num;
-- Convert the real value from integer to real representation
+ function Large_Powten (Exp : Natural) return Double_T;
+ -- Return 10.0**Exp as a double number, where Exp > Maxpow
+
---------------------
-- Integer_to_Real --
---------------------
@@ -110,9 +120,8 @@ package body System.Val_Real is
else raise Program_Error);
-- Maximum exponent of the base that can fit in Num
- B : constant Num := Num (Base);
-
R_Val : Num;
+ D_Val : Double_T;
S : Integer := Scale;
begin
@@ -125,75 +134,151 @@ package body System.Val_Real is
System.Float_Control.Reset;
end if;
- -- Do the conversion
+ -- Take into account the extra digit, i.e. do the two computations
- R_Val := Num (Val);
+ -- (1) R_Val := R_Val * Num (B) + Num (Extra)
+ -- (2) S := S - 1
- -- Take into account the extra digit, if need be. In this case, the
- -- three operands are exact, so using an FMA would be ideal.
+ -- In the first, the three operands are exact, so using an FMA would
+ -- be ideal, but we are most likely running on the x87 FPU, hence we
+ -- may not have one. That is why we turn the multiplication into an
+ -- iterated addition with exact error handling, so that we can do a
+ -- single rounding at the end.
if Need_Extra and then Extra > 0 then
- R_Val := R_Val * B + Num (Extra);
- S := S - 1;
+ declare
+ B : Unsigned := Base;
+ Acc : Num := 0.0;
+ Err : Num := 0.0;
+ Fac : Num := Num (Val);
+ DS : Double_T;
+
+ begin
+ loop
+ -- If B is odd, add one factor. Note that the accumulator is
+ -- never larger than the factor at this point (it is in fact
+ -- never larger than the factor minus the initial value).
+
+ if B rem 2 /= 0 then
+ if Acc = 0.0 then
+ Acc := Fac;
+ else
+ DS := Double_Real.Quick_Two_Sum (Fac, Acc);
+ Acc := DS.Hi;
+ Err := Err + DS.Lo;
+ end if;
+ exit when B = 1;
+ end if;
+
+ -- Now B is (morally) even, halve it and double the factor,
+ -- which is always an exact operation.
+
+ B := B / 2;
+ Fac := Fac * 2.0;
+ end loop;
+
+ -- Add Extra to the error, which are both small integers
+
+ D_Val := Double_Real.Quick_Two_Sum (Acc, Err + Num (Extra));
+
+ S := S - 1;
+ end;
+
+ -- Or else, if the Extra digit is zero, do the exact conversion
+
+ elsif Need_Extra then
+ D_Val := Double_Real.To_Double (Num (Val));
+
+ -- Otherwise, the value contains more bits than the mantissa so do the
+ -- conversion in two steps.
+
+ else
+ declare
+ Mask : constant Uns := 2**(Uns'Size - Num'Machine_Mantissa) - 1;
+ Hi : constant Uns := Val and not Mask;
+ Lo : constant Uns := Val and Mask;
+
+ begin
+ if Hi = 0 then
+ D_Val := Double_Real.To_Double (Num (Lo));
+ else
+ D_Val := Double_Real.Quick_Two_Sum (Num (Hi), Num (Lo));
+ end if;
+ end;
end if;
- -- Compute the final value
+ -- Compute the final value by applying the scaling, if any
+
+ if Val = 0 or else S = 0 then
+ R_Val := Double_Real.To_Single (D_Val);
- if R_Val /= 0.0 and then S /= 0 then
+ else
case Base is
-- If the base is a power of two, we use the efficient Scaling
-- attribute with an overflow check, if it is not 2, to catch
-- ludicrous exponents that would result in an infinity or zero.
when 2 =>
- R_Val := Num'Scaling (R_Val, S);
+ R_Val := Num'Scaling (Double_Real.To_Single (D_Val), S);
when 4 =>
if Integer'First / 2 <= S and then S <= Integer'Last / 2 then
S := S * 2;
end if;
- R_Val := Num'Scaling (R_Val, S);
+ R_Val := Num'Scaling (Double_Real.To_Single (D_Val), S);
when 8 =>
if Integer'First / 3 <= S and then S <= Integer'Last / 3 then
S := S * 3;
end if;
- R_Val := Num'Scaling (R_Val, S);
+ R_Val := Num'Scaling (Double_Real.To_Single (D_Val), S);
when 16 =>
if Integer'First / 4 <= S and then S <= Integer'Last / 4 then
S := S * 4;
end if;
- R_Val := Num'Scaling (R_Val, S);
+ R_Val := Num'Scaling (Double_Real.To_Single (D_Val), S);
- -- If the base is 10, we use a table of powers for accuracy's sake
+ -- If the base is 10, use a double implementation for the sake
+ -- of accuracy, to be removed when exponentiation is improved.
+
+ -- When the exponent is positive, we can do the computation
+ -- directly because, if the exponentiation overflows, then
+ -- the final value overflows as well. But when the exponent
+ -- is negative, we may need to do it in two steps to avoid
+ -- an artificial underflow.
when 10 =>
declare
- Powten : constant array (0 .. Maxpow) of Num;
+ Powten : constant array (0 .. Maxpow) of Double_T;
pragma Import (Ada, Powten);
for Powten'Address use Powten_Address;
begin
if S > 0 then
- while S > Maxpow loop
- R_Val := R_Val * Powten (Maxpow);
- S := S - Maxpow;
- end loop;
-
- R_Val := R_Val * Powten (S);
+ if S <= Maxpow then
+ D_Val := D_Val * Powten (S);
+ else
+ D_Val := D_Val * Large_Powten (S);
+ end if;
else
- while S < -Maxpow loop
- R_Val := R_Val / Powten (Maxpow);
- S := S + Maxpow;
- end loop;
-
- R_Val := R_Val / Powten (-S);
+ if S < -Maxexp then
+ D_Val := D_Val / Large_Powten (Maxexp);
+ S := S + Maxexp;
+ end if;
+
+ if S >= -Maxpow then
+ D_Val := D_Val / Powten (-S);
+ else
+ D_Val := D_Val / Large_Powten (-S);
+ end if;
end if;
+
+ R_Val := Double_Real.To_Single (D_Val);
end;
-- Implementation for other bases with exponentiation
@@ -205,17 +290,24 @@ package body System.Val_Real is
-- an artificial underflow.
when others =>
- if S > 0 then
- R_Val := R_Val * B ** S;
+ declare
+ B : constant Num := Num (Base);
- else
- if S < -Maxexp then
- R_Val := R_Val / B ** Maxexp;
- S := S + Maxexp;
- end if;
+ begin
+ R_Val := Double_Real.To_Single (D_Val);
- R_Val := R_Val / B ** (-S);
- end if;
+ if S > 0 then
+ R_Val := R_Val * B ** S;
+
+ else
+ if S < -Maxexp then
+ R_Val := R_Val / B ** Maxexp;
+ S := S + Maxexp;
+ end if;
+
+ R_Val := R_Val / B ** (-S);
+ end if;
+ end;
end case;
end if;
@@ -228,6 +320,34 @@ package body System.Val_Real is
when Constraint_Error => Bad_Value (Str);
end Integer_to_Real;
+ ------------------
+ -- Large_Powten --
+ ------------------
+
+ function Large_Powten (Exp : Natural) return Double_T is
+ Powten : constant array (0 .. Maxpow) of Double_T;
+ pragma Import (Ada, Powten);
+ for Powten'Address use Powten_Address;
+
+ R : Double_T;
+ E : Natural;
+
+ begin
+ pragma Assert (Exp > Maxpow);
+
+ R := Powten (Maxpow);
+ E := Exp - Maxpow;
+
+ while E > Maxpow loop
+ R := R * Powten (Maxpow);
+ E := E - Maxpow;
+ end loop;
+
+ R := R * Powten (E);
+
+ return R;
+ end Large_Powten;
+
---------------
-- Scan_Real --
---------------
diff --git a/gcc/ada/libgnat/s-valrea.ads b/gcc/ada/libgnat/s-valrea.ads
index d6ade80..e2613e0 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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,12 +36,12 @@ generic
type Num is digits <>;
- type Uns is mod <>;
-
Maxpow : Positive;
Powten_Address : System.Address;
+ type Uns is mod <>;
+
package System.Val_Real is
pragma Preelaborate;
diff --git a/gcc/ada/libgnat/s-valued.adb b/gcc/ada/libgnat/s-valued.adb
index 8930752..100d870 100644
--- a/gcc/ada/libgnat/s-valued.adb
+++ b/gcc/ada/libgnat/s-valued.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2020-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-valued.ads b/gcc/ada/libgnat/s-valued.ads
index e27e171..54c34d1 100644
--- a/gcc/ada/libgnat/s-valued.ads
+++ b/gcc/ada/libgnat/s-valued.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2020-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-valuef.adb b/gcc/ada/libgnat/s-valuef.adb
index d13111a..5ac5ff6 100644
--- a/gcc/ada/libgnat/s-valuef.adb
+++ b/gcc/ada/libgnat/s-valuef.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2020-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-valuef.ads b/gcc/ada/libgnat/s-valuef.ads
index abd4817..968d0cd 100644
--- a/gcc/ada/libgnat/s-valuef.ads
+++ b/gcc/ada/libgnat/s-valuef.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2020-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-valuei.adb b/gcc/ada/libgnat/s-valuei.adb
index ac5a776..0ad66de 100644
--- a/gcc/ada/libgnat/s-valuei.adb
+++ b/gcc/ada/libgnat/s-valuei.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-valuei.ads b/gcc/ada/libgnat/s-valuei.ads
index 13f4f8c..23dc8a8 100644
--- a/gcc/ada/libgnat/s-valuei.ads
+++ b/gcc/ada/libgnat/s-valuei.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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-valuen.adb
index daa9b43..ef613a2 100644
--- a/gcc/ada/libgnat/s-valenu.adb
+++ b/gcc/ada/libgnat/s-valuen.adb
@@ -2,11 +2,11 @@
-- --
-- GNAT COMPILER COMPONENTS --
-- --
--- S Y S T E M . V A L _ E N U M --
+-- S Y S T E M . V A L U E _ N --
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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,25 +33,39 @@ with Ada.Unchecked_Conversion;
with System.Val_Util; use System.Val_Util;
-package body System.Val_Enum is
+package body System.Value_N is
- -------------------------
- -- Value_Enumeration_8 --
- -------------------------
+ function Value_Enumeration_Pos
+ (Names : String;
+ Indexes : System.Address;
+ Hash : Hash_Function_Ptr;
+ Num : Natural;
+ Str : String)
+ return Integer with Pure_Function;
+ -- Same as Value_Enumeration, except returns negative if Value_Enumeration
+ -- would raise Constraint_Error.
- function Value_Enumeration_8
+ ---------------------------
+ -- Value_Enumeration_Pos --
+ ---------------------------
+
+ function Value_Enumeration_Pos
(Names : String;
Indexes : System.Address;
+ Hash : Hash_Function_Ptr;
Num : Natural;
Str : String)
- return Natural
+ return Integer
is
- F : Natural;
- L : Natural;
- S : String (Str'Range) := Str;
-
- type Natural_8 is range 0 .. 2 ** 7 - 1;
- type Index_Table is array (Natural) of Natural_8;
+ F, L : Integer;
+ H : Natural;
+ S : String (Str'Range) := Str;
+
+ subtype Names_Index is
+ Index_Type range Index_Type (Names'First)
+ .. Index_Type (Names'Last) + 1;
+ subtype Index is Natural range Natural'First .. Names'Length;
+ type Index_Table is array (Index) of Names_Index;
type Index_Table_Ptr is access Index_Table;
function To_Index_Table_Ptr is
@@ -59,97 +73,83 @@ package body System.Val_Enum is
IndexesT : constant Index_Table_Ptr := To_Index_Table_Ptr (Indexes);
+ pragma Assert (Num + 1 in IndexesT'Range);
+
begin
Normalize_String (S, F, L);
- for J in 0 .. Num loop
- if Names
- (Natural (IndexesT (J)) ..
- Natural (IndexesT (J + 1)) - 1) = S (F .. L)
- then
- return J;
+ declare
+ Normal : String renames S (F .. L);
+
+ begin
+ -- If we have a valid hash value, do a single lookup
+
+ H := (if Hash /= null then Hash.all (Normal) else Natural'Last);
+
+ if H /= Natural'Last then
+ if Names
+ (Natural (IndexesT (H)) ..
+ Natural (IndexesT (H + 1)) - 1) = Normal
+ then
+ return H;
+ end if;
+
+ -- Otherwise do a linear search
+
+ else
+ for J in 0 .. Num loop
+ if Names
+ (Natural (IndexesT (J)) ..
+ Natural (IndexesT (J + 1)) - 1) = Normal
+ then
+ return J;
+ end if;
+ end loop;
end if;
- end loop;
+ end;
- Bad_Value (Str);
- end Value_Enumeration_8;
+ return -1;
+ end Value_Enumeration_Pos;
- --------------------------
- -- Value_Enumeration_16 --
- --------------------------
+ -----------------------------
+ -- Valid_Value_Enumeration --
+ -----------------------------
- function Value_Enumeration_16
+ function Valid_Value_Enumeration
(Names : String;
Indexes : System.Address;
+ Hash : Hash_Function_Ptr;
Num : Natural;
Str : String)
- return Natural
+ return Boolean
is
- F : Natural;
- L : Natural;
- S : String (Str'Range) := Str;
-
- type Natural_16 is range 0 .. 2 ** 15 - 1;
- type Index_Table is array (Natural) of Natural_16;
- type Index_Table_Ptr is access Index_Table;
-
- function To_Index_Table_Ptr is
- new Ada.Unchecked_Conversion (System.Address, Index_Table_Ptr);
-
- IndexesT : constant Index_Table_Ptr := To_Index_Table_Ptr (Indexes);
-
begin
- Normalize_String (S, F, L);
-
- for J in 0 .. Num loop
- if Names
- (Natural (IndexesT (J)) ..
- Natural (IndexesT (J + 1)) - 1) = S (F .. L)
- then
- return J;
- end if;
- end loop;
+ return Value_Enumeration_Pos (Names, Indexes, Hash, Num, Str) >= 0;
+ end Valid_Value_Enumeration;
- Bad_Value (Str);
- end Value_Enumeration_16;
+ -----------------------
+ -- Value_Enumeration --
+ -----------------------
- --------------------------
- -- Value_Enumeration_32 --
- --------------------------
-
- function Value_Enumeration_32
+ function Value_Enumeration
(Names : String;
Indexes : System.Address;
+ Hash : Hash_Function_Ptr;
Num : Natural;
Str : String)
return Natural
is
- F : Natural;
- L : Natural;
- S : String (Str'Range) := Str;
-
- type Natural_32 is range 0 .. 2 ** 31 - 1;
- type Index_Table is array (Natural) of Natural_32;
- type Index_Table_Ptr is access Index_Table;
-
- function To_Index_Table_Ptr is
- new Ada.Unchecked_Conversion (System.Address, Index_Table_Ptr);
-
- IndexesT : constant Index_Table_Ptr := To_Index_Table_Ptr (Indexes);
+ Result : constant Integer :=
+ Value_Enumeration_Pos (Names, Indexes, Hash, Num, Str);
begin
- Normalize_String (S, F, L);
-
- for J in 0 .. Num loop
- if Names
- (Natural (IndexesT (J)) ..
- Natural (IndexesT (J + 1)) - 1) = S (F .. L)
- then
- return J;
- end if;
- end loop;
+ -- The comparison eliminates the need for a range check on return
- Bad_Value (Str);
- end Value_Enumeration_32;
+ if Result < 0 then
+ Bad_Value (Str);
+ else
+ return Result;
+ end if;
+ end Value_Enumeration;
-end System.Val_Enum;
+end System.Value_N;
diff --git a/gcc/ada/libgnat/s-valenu.ads b/gcc/ada/libgnat/s-valuen.ads
index 97c197f..db8ad1d 100644
--- a/gcc/ada/libgnat/s-valenu.ads
+++ b/gcc/ada/libgnat/s-valuen.ads
@@ -2,11 +2,11 @@
-- --
-- GNAT COMPILER COMPONENTS --
-- --
--- S Y S T E M . V A L _ E N U M --
+-- S Y S T E M . V A L U E _ N --
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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,23 +33,31 @@
-- other than those in packages Standard and System. See unit Exp_Imgv for
-- details of the format of constructed image tables.
-package System.Val_Enum is
+generic
+
+ type Index_Type is range <>;
+
+package System.Value_N is
pragma Preelaborate;
- function Value_Enumeration_8
+ type Hash_Function_Ptr is access function (S : String) return Natural;
+
+ function Value_Enumeration
(Names : String;
Indexes : System.Address;
+ Hash : Hash_Function_Ptr;
Num : Natural;
Str : String)
- return Natural;
+ return Natural with Inline;
-- Used to compute Enum'Value (Str) where Enum is some enumeration type
-- other than those defined in package Standard. Names is a string with
-- a lower bound of 1 containing the characters of all the enumeration
-- literals concatenated together in sequence. Indexes is the address
- -- of an array of type array (0 .. N) of Natural_8, where N is the
+ -- of an array of type array (0 .. N) of Index_Type, where N is the
-- number of enumeration literals in the type. The Indexes values are
-- the starting subscript of each enumeration literal, indexed by Pos
-- values, with an extra entry at the end containing Names'Length + 1.
+ -- The parameter Hash is a (perfect) hash function for Names and Indexes.
-- The parameter Num is the value N - 1 (i.e. Enum'Pos (Enum'Last)).
-- The reason that Indexes is passed by address is that the actual type
-- is created on the fly by the expander.
@@ -59,22 +67,16 @@ package System.Val_Enum is
-- If the image is found in Names, then the corresponding Pos value is
-- returned. If not, Constraint_Error is raised.
- function Value_Enumeration_16
- (Names : String;
- Indexes : System.Address;
- Num : Natural;
- Str : String)
- return Natural;
- -- Identical to Value_Enumeration_8 except that it handles types
- -- using array (0 .. Num) of Natural_16 for the Indexes table.
-
- function Value_Enumeration_32
+ function Valid_Value_Enumeration
(Names : String;
Indexes : System.Address;
+ Hash : Hash_Function_Ptr;
Num : Natural;
Str : String)
- return Natural;
- -- Identical to Value_Enumeration_8 except that it handles types
- -- using array (0 .. Num) of Natural_32 for the Indexes table.
+ return Boolean with Inline;
+ -- Returns True if Str is a valid Image of some enumeration literal, False
+ -- otherwise. That is, returns False if and only if Value_Enumeration would
+ -- raise Constraint_Error. The parameters have the same meaning as for
+ -- Value_Enumeration.
-end System.Val_Enum;
+end System.Value_N;
diff --git a/gcc/ada/libgnat/s-valuer.adb b/gcc/ada/libgnat/s-valuer.adb
index 9e4de3e..ff78c4b 100644
--- a/gcc/ada/libgnat/s-valuer.adb
+++ b/gcc/ada/libgnat/s-valuer.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2020-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -128,6 +128,8 @@ package body System.Value_R is
Extra : in out Char_As_Digit;
Base : Unsigned)
is
+ pragma Assert (Base in 2 .. 16);
+
B : constant Uns := Uns (Base);
begin
@@ -259,7 +261,11 @@ package body System.Value_R is
Scale := Scale - 1;
else
+ Extra := 0;
Precision_Limit_Reached := True;
+ if Round and then J = Trailing_Zeros then
+ Round_Extra (Digit, Value, Scale, Extra, Base);
+ end if;
exit;
end if;
end loop;
@@ -272,11 +278,16 @@ package body System.Value_R is
Temp := Value * Uns (Base) + Uns (Digit);
+ -- Precision_Limit_Reached may have been set above
+
+ if Precision_Limit_Reached then
+ null;
+
-- Check if Temp is larger than Precision_Limit, taking into
-- account that Temp may wrap around when Precision_Limit is
-- equal to the largest integer.
- if Value <= Umax
+ elsif Value <= Umax
or else (Value <= UmaxB
and then ((Precision_Limit < Uns'Last
and then Temp <= Precision_Limit)
diff --git a/gcc/ada/libgnat/s-valuer.ads b/gcc/ada/libgnat/s-valuer.ads
index a933859..a0103b8 100644
--- a/gcc/ada/libgnat/s-valuer.ads
+++ b/gcc/ada/libgnat/s-valuer.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2020-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-valueu.adb b/gcc/ada/libgnat/s-valueu.adb
index 75bef07..b385a9b 100644
--- a/gcc/ada/libgnat/s-valueu.adb
+++ b/gcc/ada/libgnat/s-valueu.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-valueu.ads b/gcc/ada/libgnat/s-valueu.ads
index ad8256c..5dd8cd4 100644
--- a/gcc/ada/libgnat/s-valueu.ads
+++ b/gcc/ada/libgnat/s-valueu.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 b710a9b..0d96d7b 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 84b7a7d..fb20913 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 29042f7..31edc40 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -68,10 +68,10 @@ package body System.Val_Util is
F := F + 1;
end loop;
- -- Check for case when the string contained no characters
+ -- Case of no nonspace characters found
if F > L then
- Bad_Value (S);
+ return;
end if;
-- Scan for trailing spaces
diff --git a/gcc/ada/libgnat/s-valuti.ads b/gcc/ada/libgnat/s-valuti.ads
index a453272..3d426d9 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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,9 +45,7 @@ package System.Val_Util is
-- non-blank character of S and L to be the index of the last non-blank
-- character of S. Any lower case characters present in S will be folded to
-- their upper case equivalent except for character literals. If S consists
- -- of entirely blanks then Constraint_Error is raised.
- --
- -- Note: if S is the null string, F is set to S'First, L to S'Last
+ -- of entirely blanks (including when S = "") then we return with F > L.
procedure Scan_Sign
(Str : String;
diff --git a/gcc/ada/libgnat/s-valwch.adb b/gcc/ada/libgnat/s-valwch.adb
index 791171a..dd8e8ed 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 a98d048..7a625e0 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 ed43ef2..da71bd2 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2002-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 3570b65..6b41307 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2002-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 2fb1004..0e19651 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2002-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 ab22726..1de56a7 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 b3ea028..e454d55 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 4cc1ff9..8d95c6f 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 a99eef8..1521692 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 228aa45..e16b8b5 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2005-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 897ab4e..3e82260 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 977e3042..3eede0a 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 ba904d8..7470181 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 9803b35..bef1040 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 4ec34ce..55e3c37 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 9bb9979..6afcb3f 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 2b6b8c1..4ac4657 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 0c549f9..dd3bafb 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 4bef902..bc509e1 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 710e60b..d2298b9 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 eda2451..d4913a9 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 20b7596..14096f3 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 487485c..d969309 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-widint.ads b/gcc/ada/libgnat/s-widint.ads
index 6306277..f9b5eda 100644
--- a/gcc/ada/libgnat/s-widint.ads
+++ b/gcc/ada/libgnat/s-widint.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 65b1ab4..ea24ca5 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 a67050e..708dbdc 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-widllli.ads b/gcc/ada/libgnat/s-widllli.ads
index 80ab9d1..82a7e3d 100644
--- a/gcc/ada/libgnat/s-widllli.ads
+++ b/gcc/ada/libgnat/s-widllli.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-widlllu.ads b/gcc/ada/libgnat/s-widlllu.ads
index 6f84837..018e740 100644
--- a/gcc/ada/libgnat/s-widlllu.ads
+++ b/gcc/ada/libgnat/s-widlllu.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 840f0a0..101eff2 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 e77eb55..ab7ec58 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-widthi.adb b/gcc/ada/libgnat/s-widthi.adb
index dee6068..2f2d5e0 100644
--- a/gcc/ada/libgnat/s-widthi.adb
+++ b/gcc/ada/libgnat/s-widthi.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-widthi.ads b/gcc/ada/libgnat/s-widthi.ads
index 570ac20..37865b89 100644
--- a/gcc/ada/libgnat/s-widthi.ads
+++ b/gcc/ada/libgnat/s-widthi.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-widthu.adb b/gcc/ada/libgnat/s-widthu.adb
index 2469e30..a91baec 100644
--- a/gcc/ada/libgnat/s-widthu.adb
+++ b/gcc/ada/libgnat/s-widthu.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-widthu.ads b/gcc/ada/libgnat/s-widthu.ads
index 2861738..7b71119 100644
--- a/gcc/ada/libgnat/s-widthu.ads
+++ b/gcc/ada/libgnat/s-widthu.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/libgnat/s-widuns.ads b/gcc/ada/libgnat/s-widuns.ads
index d93d3e2..0528456 100644
--- a/gcc/ada/libgnat/s-widuns.ads
+++ b/gcc/ada/libgnat/s-widuns.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 ed633d9..372650c 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 2ea340f..9db3fbf 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 0fcc6d6..9d1a7ef 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2008-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 3eff109..bfd5f38 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2009-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 fde2280..e9eaaf7 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 4d8668d..c01402b 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 49c3101..6e3a458 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 ecc6389..e59366e 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 34f9133..2339566 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/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 e2af399..32a2a35 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it 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 db4579f..e9475c6 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, 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 b306920..f5b1360 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, 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 bc0b147..3a8bd13 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, 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 c175224..527794f 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, 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 52e4a88..beecf72 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, 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 0cc0dab..14f3525 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, 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 ce1835c..e7ec01d 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, 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 202bcac..160eb7e 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, 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 34f2752..e809334 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, 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 2c638e5..f5deb2a 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, 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 9020c79..26e61d8 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, 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 dccf444..9a1429f 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, 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 14b6bb3..4ccb45c 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, 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 db7f9e7..ade6c7c 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2014-2021, 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 d44bf1b..5170964 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, 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 917b949..2ffab24 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, 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 9e93e5e..fc25470 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, 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 0ceeb96..be8fb5c 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, 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 fd0e0c7..6ee142a 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, 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 29a650a..9e7fae1 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, 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 73c99c3..893536e 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, 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 e2d9765..1002342 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2009-2021, 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 3131895..b4e7f12 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2009-2021, 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 3729e44..71d54ec 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, 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-qnx-aarch64.ads b/gcc/ada/libgnat/system-qnx-aarch64.ads
index a6336a9..57e30bf 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, 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 dca09dd..c083cb5 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, 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 1efc78f..5810a28 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, 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 8dc46ed..e0ac9c5 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, 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 592e25b..fe963d7 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, 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 ac025ce..f95efd7 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, 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 483881f..a51cfa8 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, 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 ac674bd..3cd5902 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, 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 45a99f3..4f3b544 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, 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 27f7707..b0ac2f8 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, 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 f60fbcd..0857c67 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, 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 ec3de26..3e15ddc 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, 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 e38ff3b..b918c18 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, 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 b4277e2..0fc52d0 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, 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 eeeca9b..dd31dad 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, 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 05d27d6..64f1303 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, 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 9862f42..8f384e9 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, 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 b6eebb5..959a3b9 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, 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 e6d31de..8c35743 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, 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 960a7ed..0274581 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, 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 f3f4037..3b78e7e 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, 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 55bc3f6..6f952a2 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, 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 0624ffa..cf1b138 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, 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 1491332..82ebc60 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, 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 d7da53d..3642075 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, 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 483881f..a51cfa8 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, 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 e697629..37fa0ef 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, 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 6388628..2402795 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, 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 69a0a66..4378e28 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, 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 82c5d3a..2a9a2d7 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, 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 d34d632..d8fbbee 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, 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 404da85..6a2c35a 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, 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 05a51d9..b71a3a9 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, 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 e55de8c..429bbd2 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, 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 b3659a3..883a749 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, 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 8c2d527..c010ae9 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, 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 f6528ba..8a36aa1 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, 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 fc4655f..0225112 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, 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 2bc8e6a..3be0ffb 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, 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 5cd5ef6..eac18d9 100644
--- a/gcc/ada/link.c
+++ b/gcc/ada/link.c
@@ -6,7 +6,7 @@
* *
* C Implementation File *
* *
- * Copyright (C) 1992-2020, Free Software Foundation, Inc. *
+ * Copyright (C) 1992-2021, Free Software Foundation, Inc. *
* *
* GNAT is free software; you can redistribute 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 bca9cf8..5a74f8b 100644
--- a/gcc/ada/live.adb
+++ b/gcc/ada/live.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2000-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2000-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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,14 +23,18 @@
-- --
------------------------------------------------------------------------------
-with Atree; use Atree;
-with Einfo; use Einfo;
-with Lib; use Lib;
-with Nlists; use Nlists;
-with Sem_Aux; use Sem_Aux;
-with Sem_Util; use Sem_Util;
-with Sinfo; use Sinfo;
-with Types; use Types;
+with Atree; use Atree;
+with Einfo; use Einfo;
+with Einfo.Entities; use Einfo.Entities;
+with Einfo.Utils; use Einfo.Utils;
+with Lib; use Lib;
+with Nlists; use Nlists;
+with Sem_Aux; use Sem_Aux;
+with Sem_Util; use Sem_Util;
+with Sinfo; use Sinfo;
+with Sinfo.Nodes; use Sinfo.Nodes;
+with Sinfo.Utils; use Sinfo.Utils;
+with Types; use Types;
package body Live is
@@ -82,9 +86,6 @@ package body Live is
function Spec_Of (N : Node_Id) return Entity_Id;
-- Given a subprogram body N, return defining identifier of its declaration
- -- ??? the body of this package contains no comments at all, this
- -- should be fixed.
-
-------------
-- Body_Of --
-------------
diff --git a/gcc/ada/live.ads b/gcc/ada/live.ads
index a11224b..6c22e90 100644
--- a/gcc/ada/live.ads
+++ b/gcc/ada/live.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2000-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2000-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute 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 c083c8b..59d1a79 100644
--- a/gcc/ada/locales.c
+++ b/gcc/ada/locales.c
@@ -6,7 +6,7 @@
* *
* C Implementation File *
* *
- * Copyright (C) 2010-2020, Free Software Foundation, Inc. *
+ * Copyright (C) 2010-2021, Free Software Foundation, Inc. *
* *
* GNAT is free software; you can redistribute 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 ede4c5a..6e74e90 100644
--- a/gcc/ada/make.adb
+++ b/gcc/ada/make.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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,7 @@ with Ada.Directories;
with Ada.Exceptions; use Ada.Exceptions;
with GNAT.Command_Line; use GNAT.Command_Line;
+with GNAT.Ctrl_C;
with GNAT.Directory_Operations; use GNAT.Directory_Operations;
with GNAT.OS_Lib; use GNAT.OS_Lib;
@@ -76,15 +77,7 @@ package body Make is
-- is not always explicit and considering it is important when -f and -a
-- are used.
- type Sigint_Handler is access procedure;
- pragma Convention (C, Sigint_Handler);
-
- procedure Install_Int_Handler (Handler : Sigint_Handler);
- pragma Import (C, Install_Int_Handler, "__gnat_install_int_handler");
- -- Called by Gnatmake to install the SIGINT handler below
-
procedure Sigint_Intercepted;
- pragma Convention (C, Sigint_Intercepted);
pragma No_Return (Sigint_Intercepted);
-- Called when the program is interrupted by Ctrl-C to delete the
-- temporary mapping files and configuration pragmas files.
@@ -406,7 +399,10 @@ package body Make is
Non_Std_Executable : out Boolean);
-- Parse the linker switches and project file to compute the name of the
-- executable to generate.
- -- ??? What is the meaning of Non_Std_Executable
+ --
+ -- When the platform expects a specific extension for the generated binary,
+ -- there is a chance that the linker might not use the right name for the
+ -- it. Non_Std_Executable is set to True in this case.
procedure Compilation_Phase
(Main_Source_File : File_Name_Type;
@@ -2368,7 +2364,7 @@ package body Make is
Osint.Full_Source_Name
(Source.File,
Full_File => Full_Source_File,
- Attr => Source_File_Attr'Access);
+ Attr => Source_File_Attr'Unchecked_Access);
Lib_File := Osint.Lib_File_Name (Source.File, Source.Index);
@@ -2396,7 +2392,7 @@ package body Make is
Get_Name_String (Full_Lib_File);
Name_Buffer (Name_Len + 1) := ASCII.NUL;
Read_Only := not Is_Writable_File
- (Name_Buffer'Address, Lib_File_Attr'Access);
+ (Name_Buffer'Address, Lib_File_Attr'Unchecked_Access);
else
Read_Only := False;
end if;
@@ -2464,7 +2460,7 @@ package body Make is
The_Args => Args,
Lib_File => Lib_File,
Full_Lib_File => Full_Lib_File,
- Lib_File_Attr => Lib_File_Attr'Access,
+ Lib_File_Attr => Lib_File_Attr'Unchecked_Access,
Read_Only => Read_Only,
ALI => ALI,
O_File => Obj_File,
@@ -2634,7 +2630,8 @@ package body Make is
Text :=
Read_Library_Info_From_Full
- (Data.Full_Lib_File, Data.Lib_File_Attr'Access);
+ (Data.Full_Lib_File,
+ Data.Lib_File_Attr'Unchecked_Access);
-- Restore Check_Object_Consistency to its initial value
@@ -3322,7 +3319,7 @@ package body Make is
pragma Warnings (Off, Discard);
begin
- Install_Int_Handler (Sigint_Intercepted'Access);
+ GNAT.Ctrl_C.Install_Handler (Sigint_Intercepted'Access);
Do_Compile_Step := True;
Do_Bind_Step := True;
@@ -4598,18 +4595,6 @@ package body Make is
Add_Switch
("-aO" & Argv (4 .. Argv'Last), Binder);
- -- -aamp_target=...
-
- elsif Argv'Length >= 13 and then Argv (2 .. 13) = "aamp_target=" then
- Add_Switch (Argv, Compiler);
-
- -- Set the aamp_target environment variable so that the binder and
- -- linker will use the proper target library. This is consistent
- -- with how things work when -aamp_target is passed on the command
- -- line to gnaampmake.
-
- Setenv ("aamp_target", Argv (14 .. Argv'Last));
-
-- -Adir (to gnatbind this is like a -aO switch, to gcc like a -I)
elsif Argv (2) = 'A' then
diff --git a/gcc/ada/make.ads b/gcc/ada/make.ads
index d4e54cc..5de1335 100644
--- a/gcc/ada/make.ads
+++ b/gcc/ada/make.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute 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 0ba957e..ff7012e 100644
--- a/gcc/ada/make_util.adb
+++ b/gcc/ada/make_util.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2004-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute 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 fab4c74..4027142 100644
--- a/gcc/ada/make_util.ads
+++ b/gcc/ada/make_util.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2004-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute 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 4cc50b1..68a5c89 100644
--- a/gcc/ada/makeusg.adb
+++ b/gcc/ada/makeusg.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute 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 4ac7147..cfba872e 100644
--- a/gcc/ada/makeusg.ads
+++ b/gcc/ada/makeusg.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute 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 ce51ff0..d55053a 100644
--- a/gcc/ada/mdll-fil.adb
+++ b/gcc/ada/mdll-fil.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute 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 5036b0c..4aa4c81 100644
--- a/gcc/ada/mdll-fil.ads
+++ b/gcc/ada/mdll-fil.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute 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 632b930..48e32da 100644
--- a/gcc/ada/mdll-utl.adb
+++ b/gcc/ada/mdll-utl.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute 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 883500f..cf0384b 100644
--- a/gcc/ada/mdll-utl.ads
+++ b/gcc/ada/mdll-utl.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute 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 3319e94..632dd70 100644
--- a/gcc/ada/mdll.adb
+++ b/gcc/ada/mdll.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute 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 755de4e..a134ae4 100644
--- a/gcc/ada/mdll.ads
+++ b/gcc/ada/mdll.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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 @@
-- to build Windows DLL
with GNAT.OS_Lib;
--- Should have USE here ???
package MDLL is
diff --git a/gcc/ada/mingw32.h b/gcc/ada/mingw32.h
index c902d04..eed4712 100644
--- a/gcc/ada/mingw32.h
+++ b/gcc/ada/mingw32.h
@@ -6,7 +6,7 @@
* *
* C Header File *
* *
- * Copyright (C) 2002-2020, Free Software Foundation, Inc. *
+ * Copyright (C) 2002-2021, Free Software Foundation, Inc. *
* *
* GNAT is free software; you can redistribute 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 a11b1e5..e644c4c 100644
--- a/gcc/ada/mkdir.c
+++ b/gcc/ada/mkdir.c
@@ -6,7 +6,7 @@
* *
* C Implementation File *
* *
- * Copyright (C) 2002-2020, Free Software Foundation, Inc. *
+ * Copyright (C) 2002-2021, Free Software Foundation, Inc. *
* *
* GNAT is free software; you can redistribute 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 b64a1f1..bc145ff 100644
--- a/gcc/ada/namet-sp.adb
+++ b/gcc/ada/namet-sp.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2008-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2008-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute 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 3d75460..2953aa7 100644
--- a/gcc/ada/namet-sp.ads
+++ b/gcc/ada/namet-sp.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute 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 557232d..3a4755d 100644
--- a/gcc/ada/namet.adb
+++ b/gcc/ada/namet.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -1133,11 +1133,12 @@ package body Namet is
Name_Len => Short (Buf.Length),
Byte_Info => 0,
Int_Info => 0,
+ Hash_Link => No_Name,
+ Name_Has_No_Encodings => False,
Boolean1_Info => False,
Boolean2_Info => False,
Boolean3_Info => False,
- Name_Has_No_Encodings => False,
- Hash_Link => No_Name));
+ Spare => False));
-- Set corresponding string entry in the Name_Chars table
@@ -1239,12 +1240,13 @@ package body Namet is
((Name_Chars_Index => Name_Chars.Last,
Name_Len => Short (Buf.Length),
Hash_Link => No_Name,
- Name_Has_No_Encodings => False,
Int_Info => 0,
Byte_Info => 0,
+ Name_Has_No_Encodings => False,
Boolean1_Info => False,
Boolean2_Info => False,
- Boolean3_Info => False));
+ Boolean3_Info => False,
+ Spare => False));
-- Set corresponding string entry in the Name_Chars table
@@ -1324,11 +1326,12 @@ package body Namet is
Name_Len => 1,
Byte_Info => 0,
Int_Info => 0,
+ Hash_Link => No_Name,
+ Name_Has_No_Encodings => True,
Boolean1_Info => False,
Boolean2_Info => False,
Boolean3_Info => False,
- Name_Has_No_Encodings => True,
- Hash_Link => No_Name));
+ Spare => False));
Name_Chars.Append (C);
Name_Chars.Append (ASCII.NUL);
diff --git a/gcc/ada/namet.ads b/gcc/ada/namet.ads
index f3c7c5b4..e5d219f 100644
--- a/gcc/ada/namet.ads
+++ b/gcc/ada/namet.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -442,7 +442,7 @@ package Namet is
-- The following routines operate on Global_Name_Buffer. New code should
-- use the routines above, and declare Bounded_Strings as local
-- variables. Existing code can be improved incrementally by removing calls
- -- to the following. ???If we eliminate all of these, we can remove
+ -- to the following. If we eliminate all of these, we can remove
-- Global_Name_Buffer. But be sure to look at namet.h first.
-- To see what these do, look at the bodies. They are all trivially defined
@@ -570,33 +570,36 @@ private
Table_Name => "Name_Chars");
type Name_Entry is record
- Name_Chars_Index : Int;
+ Name_Chars_Index : aliased Int;
-- Starting location of characters in the Name_Chars table minus one
-- (i.e. pointer to character just before first character). The reason
-- for the bias of one is that indexes in Name_Buffer are one's origin,
-- so this avoids unnecessary adds and subtracts of 1.
- Name_Len : Short;
+ Name_Len : aliased Short;
-- Length of this name in characters
- Byte_Info : Byte;
+ Byte_Info : aliased Byte;
-- Byte value associated with this name
- Boolean1_Info : Boolean;
- Boolean2_Info : Boolean;
- Boolean3_Info : Boolean;
- -- Boolean values associated with the name
-
Name_Has_No_Encodings : Boolean;
-- This flag is set True if the name entry is known not to contain any
-- special character encodings. This is used to speed up repeated calls
-- to Append_Decoded. A value of False means that it is not known
-- whether the name contains any such encodings.
- Hash_Link : Name_Id;
+ Boolean1_Info : Boolean;
+ Boolean2_Info : Boolean;
+ Boolean3_Info : Boolean;
+ -- Boolean values associated with the name
+
+ Spare : Boolean;
+ -- Four remaining bits in the current byte
+
+ Hash_Link : aliased Name_Id;
-- Link to next entry in names table for same hash code
- Int_Info : Int;
+ Int_Info : aliased Int;
-- Int Value associated with this name
end record;
@@ -605,10 +608,11 @@ private
Name_Chars_Index at 0 range 0 .. 31;
Name_Len at 4 range 0 .. 15;
Byte_Info at 6 range 0 .. 7;
- Boolean1_Info at 7 range 0 .. 0;
- Boolean2_Info at 7 range 1 .. 1;
- Boolean3_Info at 7 range 2 .. 2;
- Name_Has_No_Encodings at 7 range 3 .. 7;
+ Name_Has_No_Encodings at 7 range 0 .. 0;
+ Boolean1_Info at 7 range 1 .. 1;
+ Boolean2_Info at 7 range 2 .. 2;
+ Boolean3_Info at 7 range 3 .. 3;
+ Spare at 7 range 4 .. 7;
Hash_Link at 8 range 0 .. 31;
Int_Info at 12 range 0 .. 31;
end record;
diff --git a/gcc/ada/namet.h b/gcc/ada/namet.h
index 1bc20c0..09fa264 100644
--- a/gcc/ada/namet.h
+++ b/gcc/ada/namet.h
@@ -6,7 +6,7 @@
* *
* C Header File *
* *
- * Copyright (C) 1992-2020, Free Software Foundation, Inc. *
+ * Copyright (C) 1992-2021, Free Software Foundation, Inc. *
* *
* GNAT is 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,26 +32,28 @@
extern "C" {
#endif
-/* Structure defining a names table entry. */
-
+/* Structure defining a name table entry. */
struct Name_Entry
{
- Int Name_Chars_Index; /* Starting location of char in Name_Chars table. */
- Short Name_Len; /* Length of this name in characters. */
- Byte Byte_Info; /* Byte value associated with this name */
- Byte Spare; /* Unused */
- Name_Id Hash_Link; /* Link to next entry in names table for same hash
- code. Not accessed by C routines. */
- Int Int_Info; /* Int value associated with this name */
+ Int Name_Chars_Index;
+ Short Name_Len;
+ Byte Byte_Info;
+ Byte Name_Has_No_Encodings : 1;
+ Byte Boolean1_Info : 1;
+ Byte Boolean2_Info : 1;
+ Byte Boolean3_Info : 1;
+ Byte Spare : 4;
+ Name_Id Hash_Link;
+ Int Int_Info;
};
-/* Pointer to names table vector. */
+/* Pointer to the name table. */
#define Names_Ptr namet__name_entries__table
-extern struct Name_Entry *Names_Ptr;
+extern struct Name_Entry (*Names_Ptr)[];
-/* Pointer to name characters table. */
+/* Pointer to the name character table. */
#define Name_Chars_Ptr namet__name_chars__table
-extern char *Name_Chars_Ptr;
+extern char (*Name_Chars_Ptr)[];
/* This is Hostparm.Max_Line_Length. */
#define Max_Line_Length (32767 - 1)
@@ -75,12 +77,13 @@ extern struct Bounded_String Global_Name_Buffer;
strings we want are sitting in the name strings table in exactly the form
we need them (NUL terminated), we just point to the name directly. */
-static char *Get_Name_String (Name_Id);
+INLINE char *Get_Name_String (Name_Id);
INLINE char *
Get_Name_String (Name_Id Id)
{
- return Name_Chars_Ptr + Names_Ptr[Id - First_Name_Id].Name_Chars_Index + 1;
+ return
+ &(*Name_Chars_Ptr)[(*Names_Ptr)[Id - First_Name_Id].Name_Chars_Index + 1];
}
#define Name_Equals namet__name_equals
diff --git a/gcc/ada/nlists.adb b/gcc/ada/nlists.adb
index 02859c7..7339c17 100644
--- a/gcc/ada/nlists.adb
+++ b/gcc/ada/nlists.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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,10 +27,11 @@
-- file must be properly reflected in the corresponding C header a-nlists.h
with Alloc;
-with Atree; use Atree;
-with Debug; use Debug;
-with Output; use Output;
-with Sinfo; use Sinfo;
+with Atree; use Atree;
+with Debug; use Debug;
+with Output; use Output;
+with Sinfo; use Sinfo;
+with Sinfo.Nodes; use Sinfo.Nodes;
with Table;
package body Nlists is
@@ -39,9 +40,6 @@ package body Nlists is
-- permitted only when this switch is set to False; compiling without
-- assertions this lock has no effect.
- use Atree_Private_Part;
- -- Get access to Nodes table
-
----------------------------------
-- Implementation of Node Lists --
----------------------------------
@@ -86,17 +84,16 @@ package body Nlists is
Table_Component_Type => Node_Or_Entity_Id,
Table_Index_Type => Node_Or_Entity_Id'Base,
Table_Low_Bound => First_Node_Id,
- Table_Initial => Alloc.Nodes_Initial,
- Table_Increment => Alloc.Nodes_Increment,
- Release_Threshold => Alloc.Nodes_Release_Threshold,
+ Table_Initial => Alloc.Node_Offsets_Initial,
+ Table_Increment => Alloc.Node_Offsets_Increment,
Table_Name => "Next_Node");
package Prev_Node is new Table.Table (
Table_Component_Type => Node_Or_Entity_Id,
Table_Index_Type => Node_Or_Entity_Id'Base,
Table_Low_Bound => First_Node_Id,
- Table_Initial => Alloc.Nodes_Initial,
- Table_Increment => Alloc.Nodes_Increment,
+ Table_Initial => Alloc.Node_Offsets_Initial,
+ Table_Increment => Alloc.Node_Offsets_Increment,
Table_Name => "Prev_Node");
-----------------------
@@ -188,7 +185,7 @@ package body Nlists is
Set_Last (To, Node);
- Nodes.Table (Node).In_List := True;
+ Set_In_List (Node, True);
Set_Next (Node, Empty);
Set_Prev (Node, L);
@@ -406,7 +403,7 @@ package body Nlists is
Set_Next (After, Node);
- Nodes.Table (Node).In_List := True;
+ Set_In_List (Node, True);
Set_Prev (Node, After);
Set_Next (Node, Before);
@@ -466,7 +463,7 @@ package body Nlists is
Set_Prev (Before, Node);
- Nodes.Table (Node).In_List := True;
+ Set_In_List (Node, True);
Set_Prev (Node, After);
Set_Next (Node, Before);
@@ -623,7 +620,7 @@ package body Nlists is
function Is_List_Member (Node : Node_Or_Entity_Id) return Boolean is
begin
- return Nodes.Table (Node).In_List;
+ return In_List (Node);
end Is_List_Member;
-----------------------
@@ -675,7 +672,7 @@ package body Nlists is
function List_Containing (Node : Node_Or_Entity_Id) return List_Id is
begin
pragma Assert (Is_List_Member (Node));
- return List_Id (Nodes.Table (Node).Link);
+ return List_Id (Link (Node));
end List_Containing;
-----------------
@@ -866,7 +863,7 @@ package body Nlists is
Set_First (List, Node);
Set_Last (List, Node);
- Nodes.Table (Node).In_List := True;
+ Set_In_List (Node, True);
Set_List_Link (Node, List);
Set_Prev (Node, Empty);
Set_Next (Node, Empty);
@@ -1018,6 +1015,7 @@ package body Nlists is
function Parent (List : List_Id) return Node_Or_Entity_Id is
begin
+ pragma Assert (Present (List));
pragma Assert (List <= Lists.Last);
return Lists.Table (List).Parent;
end Parent;
@@ -1083,7 +1081,7 @@ package body Nlists is
Set_First (To, Node);
- Nodes.Table (Node).In_List := True;
+ Set_In_List (Node, True);
Set_Next (Node, F);
Set_Prev (Node, Empty);
@@ -1292,7 +1290,7 @@ package body Nlists is
Set_Prev (Nxt, Prv);
end if;
- Nodes.Table (Node).In_List := False;
+ Set_In_List (Node, False);
Set_Parent (Node, Empty);
end Remove;
@@ -1341,7 +1339,7 @@ package body Nlists is
Set_Prev (Nxt, Empty);
end if;
- Nodes.Table (Frst).In_List := False;
+ Set_In_List (Frst, False);
Set_Parent (Frst, Empty);
return Frst;
end;
@@ -1392,7 +1390,7 @@ package body Nlists is
Set_Prev (Nxt2, Node);
end if;
- Nodes.Table (Nxt).In_List := False;
+ Set_In_List (Nxt, False);
Set_Parent (Nxt, Empty);
end;
end if;
@@ -1427,7 +1425,7 @@ package body Nlists is
procedure Set_List_Link (Node : Node_Or_Entity_Id; To : List_Id) is
begin
pragma Assert (not Locked);
- Nodes.Table (Node).Link := Union_Id (To);
+ Set_Link (Node, Union_Id (To));
end Set_List_Link;
--------------
diff --git a/gcc/ada/nlists.ads b/gcc/ada/nlists.ads
index 169c8e5..9f5774a 100644
--- a/gcc/ada/nlists.ads
+++ b/gcc/ada/nlists.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -146,9 +146,9 @@ package Nlists is
-- No_List. (No_List is not considered to be the same as an empty list).
function List_Length (List : List_Id) return Nat;
- -- Returns number of items in the given list. It is an error to call
- -- this function with No_List (No_List is not considered to be the same
- -- as an empty list).
+ -- Returns number of items in the given list. If called on No_List it
+ -- returns 0, even though No_List is not considered to be the same as an
+ -- empty list.
function Next (Node : Node_Or_Entity_Id) return Node_Or_Entity_Id;
pragma Inline (Next);
diff --git a/gcc/ada/nlists.h b/gcc/ada/nlists.h
index 3fa2906..2cd5cf3 100644
--- a/gcc/ada/nlists.h
+++ b/gcc/ada/nlists.h
@@ -6,7 +6,7 @@
* *
* C Header File *
* *
- * Copyright (C) 1992-2020, Free Software Foundation, Inc. *
+ * Copyright (C) 1992-2021, Free Software Foundation, Inc. *
* *
* GNAT is free software; you can redistribute it and/or modify it under *
* terms of the GNU General Public License as published by the Free Soft- *
@@ -105,9 +105,6 @@ Prev (Node_Id Node)
extern Node_Id Prev_Non_Pragma (Node_Id);
static Boolean Is_Empty_List (List_Id);
-static Boolean Is_Non_Empty_List (List_Id);
-static Boolean Is_List_Member (Node_Id);
-static List_Id List_Containing (Node_Id);
INLINE Boolean
Is_Empty_List (List_Id Id)
@@ -115,24 +112,6 @@ Is_Empty_List (List_Id Id)
return (First (Id) == Empty);
}
-INLINE Boolean
-Is_Non_Empty_List (List_Id Id)
-{
- return (Present (Id) && First (Id) != Empty);
-}
-
-INLINE Boolean
-Is_List_Member (Node_Id Node)
-{
- return Nodes_Ptr[Node - First_Node_Id].U.K.in_list;
-}
-
-INLINE List_Id
-List_Containing (Node_Id Node)
-{
- return Nodes_Ptr[Node - First_Node_Id].V.NX.link;
-}
-
#ifdef __cplusplus
}
#endif
diff --git a/gcc/ada/nmake.adt b/gcc/ada/nmake.adt
deleted file mode 100644
index 8fd5684..0000000
--- a/gcc/ada/nmake.adt
+++ /dev/null
@@ -1,80 +0,0 @@
-------------------------------------------------------------------------------
--- --
--- GNAT COMPILER COMPONENTS --
--- --
--- N M A K E --
--- --
--- T e m p l a t e --
--- --
--- Copyright (C) 1992-2007, Free Software Foundation, Inc. --
--- --
--- GNAT is 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 file is a template used as input to the utility program XNmake,
--- which reads this template, and the spec of Sinfo (sinfo.ads) and
--- generates the body and/or the spec for the Nmake package (files
--- nmake.ads and nmake.adb)
-
-pragma Style_Checks (All_Checks);
--- Turn off subprogram order checking, since the routines here are
--- generated automatically in order.
-
-with Atree; use Atree; -- body only
-with Namet; use Namet; -- spec only
-with Nlists; use Nlists; -- spec only
-with Sinfo; use Sinfo; -- body only
-with Snames; use Snames; -- body only
-with Stand; use Stand; -- body only
-with Types; use Types; -- spec only
-with Uintp; use Uintp; -- spec only
-with Urealp; use Urealp; -- spec only
-
-package Nmake is
-
--- This package contains a set of routines used to construct tree nodes
--- using a functional style. There is one routine for each node type defined
--- in Sinfo with the general interface:
-
--- function Make_xxx (Sloc : Source_Ptr,
--- Field_Name_1 : Field_Name_1_Type [:= default]
--- Field_Name_2 : Field_Name_2_Type [:= default]
--- ...)
--- return Node_Id
-
--- Only syntactic fields are included (i.e. fields marked as "-Sem" or "-Lib"
--- in the Sinfo spec are excluded). In addition, the following four syntactic
--- fields are excluded:
-
--- Prev_Ids
--- More_Ids
--- Comes_From_Source
--- Paren_Count
-
--- since they are very rarely set in expanded code. If they need to be set,
--- to other than the default values (False, False, False, zero), then the
--- appropriate Set_xxx procedures must be used on the returned value.
-
--- Default values are provided only for flag fields (where the default is
--- False), and for optional fields. An optional field is one where the
--- comment line describing the field contains the string "(set to xxx if".
--- For such fields, a default value of xxx is provided."
-
--- Warning: since calls to Make_xxx routines are normal function calls, the
--- arguments can be evaluated in any order. This means that at most one such
--- argument can have side effects (e.g. be a call to a parse routine).
-
-!!TEMPLATE INSERTION POINT
-
-end Nmake;
diff --git a/gcc/ada/opt.adb b/gcc/ada/opt.adb
index 8ad6d3a..cd909495 100644
--- a/gcc/ada/opt.adb
+++ b/gcc/ada/opt.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -84,7 +84,6 @@ package body Opt is
Default_SSO_Config := Default_SSO;
Dynamic_Elaboration_Checks_Config := Dynamic_Elaboration_Checks;
Exception_Locations_Suppressed_Config := Exception_Locations_Suppressed;
- Extensions_Allowed_Config := Extensions_Allowed;
External_Name_Exp_Casing_Config := External_Name_Exp_Casing;
External_Name_Imp_Casing_Config := External_Name_Imp_Casing;
Fast_Math_Config := Fast_Math;
@@ -123,7 +122,6 @@ package body Opt is
Default_SSO := Save.Default_SSO;
Dynamic_Elaboration_Checks := Save.Dynamic_Elaboration_Checks;
Exception_Locations_Suppressed := Save.Exception_Locations_Suppressed;
- Extensions_Allowed := Save.Extensions_Allowed;
External_Name_Exp_Casing := Save.External_Name_Exp_Casing;
External_Name_Imp_Casing := Save.External_Name_Imp_Casing;
Fast_Math := Save.Fast_Math;
@@ -165,7 +163,6 @@ package body Opt is
Default_SSO => Default_SSO,
Dynamic_Elaboration_Checks => Dynamic_Elaboration_Checks,
Exception_Locations_Suppressed => Exception_Locations_Suppressed,
- Extensions_Allowed => Extensions_Allowed,
External_Name_Exp_Casing => External_Name_Exp_Casing,
External_Name_Imp_Casing => External_Name_Imp_Casing,
Fast_Math => Fast_Math,
@@ -204,7 +201,6 @@ package body Opt is
Ada_Version_Pragma := Empty;
Default_SSO := ' ';
Dynamic_Elaboration_Checks := False;
- Extensions_Allowed := True;
External_Name_Exp_Casing := As_Is;
External_Name_Imp_Casing := Lowercase;
No_Component_Reordering := False;
@@ -263,7 +259,6 @@ package body Opt is
Check_Policy_List := Check_Policy_List_Config;
Default_SSO := Default_SSO_Config;
Dynamic_Elaboration_Checks := Dynamic_Elaboration_Checks_Config;
- Extensions_Allowed := Extensions_Allowed_Config;
External_Name_Exp_Casing := External_Name_Exp_Casing_Config;
External_Name_Imp_Casing := External_Name_Imp_Casing_Config;
Fast_Math := Fast_Math_Config;
diff --git a/gcc/ada/opt.ads b/gcc/ada/opt.ads
index 6b32a96..3786d2c 100644
--- a/gcc/ada/opt.ads
+++ b/gcc/ada/opt.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -68,17 +68,20 @@ package Opt is
-- the default values.
Latest_Ada_Only : Boolean := False;
- -- If True, the only value valid for Ada_Version is Ada_Version_Type'Last,
- -- trying to specify other values will be ignored (in case of pragma
+ -- If True, the only value valid for Ada_Version is Ada_2012 or later.
+ -- Trying to specify other values will be ignored (in case of pragma
-- Ada_xxx) or generate an error (in case of -gnat83/95/xx switches).
- type Ada_Version_Type is (Ada_83, Ada_95, Ada_2005, Ada_2012, Ada_2020);
+ type Ada_Version_Type is
+ (Ada_83, Ada_95, Ada_2005, Ada_2012, Ada_2022, Ada_With_Extensions);
pragma Ordered (Ada_Version_Type);
pragma Convention (C, Ada_Version_Type);
-- Versions of Ada for Ada_Version below. Note that these are ordered,
-- so that tests like Ada_Version >= Ada_95 are legitimate and useful.
-- Think twice before using "="; Ada_Version >= Ada_2012 is more likely
-- what you want, because it will apply to future versions of the language.
+ -- Note that Ada_With_Extensions should always be last since it should
+ -- always be a superset of the latest Ada version.
-- WARNING: There is a matching C declaration of this type in fe.h
@@ -108,7 +111,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_2020;
+ Ada_Version_Runtime : Ada_Version_Type := Ada_With_Extensions;
-- GNAT
-- Ada version used to compile the runtime. Used to set Ada_Version (but
-- not Ada_Version_Explicit) when compiling predefined or internal units.
@@ -188,6 +191,8 @@ package Opt is
-- are valid and in range of their representations. This feature is now
-- fully enabled in the compiler.
+ -- WARNING: There is a matching C declaration of this variable in fe.h
+
Back_Annotate_Rep_Info : Boolean := False;
-- GNAT
-- If set True, enables back annotation of representation information
@@ -623,10 +628,10 @@ package Opt is
-- Set to True to convert nonbinary modular additions into code
-- that relies on the front-end expansion of operator Mod.
- Extensions_Allowed : Boolean := False;
- -- GNAT
- -- Set to True by switch -gnatX if GNAT specific language extensions
- -- are allowed. See GNAT RM for details.
+ function Extensions_Allowed return Boolean is
+ (Ada_Version = Ada_With_Extensions);
+ -- True if GNAT specific language 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
@@ -912,6 +917,11 @@ package Opt is
-- directory if these files already exist or in the source directory
-- if not.
+ JSON_Output : Boolean := False;
+ -- GNAT
+ -- Output error and warning messages in JSON format. Set to true when the
+ -- backend option "-fdiagnostics-format=json" is found on the command line.
+
Keep_Going : Boolean := False;
-- GNATMAKE, GPRBUILD
-- When True signals to ignore compilation errors and keep processing
@@ -1528,7 +1538,7 @@ package Opt is
Table_Factor : Int := 1;
-- GNAT
-- Factor by which all initial table sizes set in Alloc are multiplied.
- -- Used in Table to calculate initial table sizes (the initial table size
+ -- Used in Table to calculate initial table sizes. The initial table size
-- is the value in Alloc, used as the Table_Initial parameter value,
-- multiplied by the factor given here. The default value is used if no
-- -gnatT switch appears.
@@ -1643,7 +1653,8 @@ package Opt is
Unique_Error_Tag : Boolean := Tag_Errors;
-- GNAT
-- Indicates if error messages are to be prefixed by the string error:
- -- Initialized from Tag_Errors, can be forced on with the -gnatU switch.
+ -- Initialized from Tag_Errors, can be forced on with the -gnatU switch and
+ -- disabled with -gnatd_U.
Unnest_Subprogram_Mode : Boolean := False;
-- If true, activates the circuitry for unnesting subprograms (see the spec
@@ -1726,11 +1737,11 @@ package Opt is
-- including warnings on Ada 2012 obsolescent features used in Ada 2012
-- mode. Modified by use of -gnatwy/Y.
- Warn_On_Ada_202X_Compatibility : Boolean := True;
+ Warn_On_Ada_2022_Compatibility : Boolean := True;
-- GNAT
- -- Set to True to generate all warnings on Ada 202X compatibility issues,
- -- including warnings on Ada 202X obsolescent features used in Ada 202X
- -- mode. ???There is no warning switch for this yet.
+ -- Set to True to generate all warnings on Ada 2022 compatibility issues,
+ -- including warnings on Ada 2022 obsolescent features used in Ada 2022
+ -- mode.
Warn_On_All_Unread_Out_Parameters : Boolean := False;
-- GNAT
@@ -1885,8 +1896,9 @@ package Opt is
Warn_On_Suspicious_Modulus_Value : Boolean := True;
-- GNAT
- -- Set to True to generate warnings for suspicious modulus values. The
- -- default is that this warning is enabled. Modified by -gnatw.m/.M.
+ -- Set to True to generate warnings for suspicious modulus values, as well
+ -- as negative literals of a modular type. The default is that this warning
+ -- is enabled. Modified by -gnatw.m/.M.
Warn_On_Unchecked_Conversion : Boolean := True;
-- GNAT
@@ -2039,14 +2051,6 @@ package Opt is
-- GNAT
-- Set True by use of the configuration pragma Suppress_Exception_Messages
- Extensions_Allowed_Config : Boolean;
- -- GNAT
- -- This is the flag that indicates whether extensions are allowed. It can
- -- be set True either by use of the -gnatX switch, or by use of the
- -- configuration pragma Extensions_Allowed (On). It is always set to True
- -- for internal GNAT units, since extensions are always permitted in such
- -- units.
-
External_Name_Exp_Casing_Config : External_Casing_Type;
-- GNAT
-- This is the value of the configuration switch that controls casing of
@@ -2330,7 +2334,6 @@ private
Default_SSO : Character;
Dynamic_Elaboration_Checks : Boolean;
Exception_Locations_Suppressed : Boolean;
- Extensions_Allowed : Boolean;
External_Name_Exp_Casing : External_Casing_Type;
External_Name_Imp_Casing : External_Casing_Type;
Fast_Math : Boolean;
diff --git a/gcc/ada/osint-b.adb b/gcc/ada/osint-b.adb
index b8b45f8..874dfe1 100644
--- a/gcc/ada/osint-b.adb
+++ b/gcc/ada/osint-b.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2001-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2001-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute 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 fc88082..cd604bf 100644
--- a/gcc/ada/osint-b.ads
+++ b/gcc/ada/osint-b.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2001-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2001-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute 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 4fc0998..14c6993 100644
--- a/gcc/ada/osint-c.adb
+++ b/gcc/ada/osint-c.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2001-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2001-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute 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.ads b/gcc/ada/osint-c.ads
index 6862e30..61c6632 100644
--- a/gcc/ada/osint-c.ads
+++ b/gcc/ada/osint-c.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2001-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2001-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute 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.adb b/gcc/ada/osint-l.adb
index ad29e94..cb0d446 100644
--- a/gcc/ada/osint-l.adb
+++ b/gcc/ada/osint-l.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2001-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2001-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute 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 6a5fe03..ca1e1f7 100644
--- a/gcc/ada/osint-l.ads
+++ b/gcc/ada/osint-l.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2001-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2001-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute 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 536adb3..35f67f9 100644
--- a/gcc/ada/osint-m.adb
+++ b/gcc/ada/osint-m.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2001-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2001-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute 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 eff7bdd..e3eba32 100644
--- a/gcc/ada/osint-m.ads
+++ b/gcc/ada/osint-m.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2001-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2001-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute 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 e935c2b..4ee6aa8 100644
--- a/gcc/ada/osint.adb
+++ b/gcc/ada/osint.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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,11 @@ package body Osint is
use type CRTL.size_t;
Running_Program : Program_Type := Unspecified;
- -- comment required here ???
+ -- Set by Set_Program to indicate which of Compiler, Binder, etc is
+ -- running.
Program_Set : Boolean := False;
- -- comment required here ???
+ -- True if Set_Program has been called; used to detect duplicate calls.
Std_Prefix : String_Ptr;
-- Standard prefix, computed dynamically the first time Relocate_Path
@@ -151,9 +152,9 @@ package body Osint is
function To_Path_String_Access
(Path_Addr : Address;
Path_Len : CRTL.size_t) return String_Access;
- -- Converts a C String to an Ada String. Are we doing this to avoid withing
- -- Interfaces.C.Strings ???
- -- Caller must free result.
+ -- Converts a C String to an Ada String. We don't use a more general
+ -- purpose facility, because we are dealing with low-level types like
+ -- Address. Caller must free result.
function Include_Dir_Default_Prefix return String_Access;
-- Same as exported version, except returns a String_Access
@@ -1348,11 +1349,8 @@ package body Osint is
Lib_File : out File_Name_Type;
Attr : out File_Attributes)
is
- A : aliased File_Attributes;
begin
- -- ??? seems we could use Smart_Find_File here
- Find_File (N, Library, Lib_File, A'Access);
- Attr := A;
+ Smart_Find_File (N, Library, Lib_File, Attr);
end Full_Lib_File_Name;
------------------------
@@ -1891,7 +1889,7 @@ package body Osint is
Name_Len := Full_Name'Length - 1;
Name_Buffer (1 .. Name_Len) :=
Full_Name (1 .. Full_Name'Last - 1);
- Found := Name_Find; -- ??? Was Name_Enter, no obvious reason
+ Found := Name_Find;
end if;
end if;
end;
@@ -1917,7 +1915,8 @@ package body Osint is
begin
if Opt.Look_In_Primary_Dir then
Locate_File
- (N, Source, Primary_Directory, File_Name, File, Attr'Access);
+ (N, Source, Primary_Directory, File_Name, File,
+ Attr'Unchecked_Access);
if File /= No_File and then T = File_Stamp (N) then
return File;
@@ -1927,7 +1926,7 @@ package body Osint is
Last_Dir := Src_Search_Directories.Last;
for D in Primary_Directory + 1 .. Last_Dir loop
- Locate_File (N, Source, D, File_Name, File, Attr'Access);
+ Locate_File (N, Source, D, File_Name, File, Attr'Unchecked_Access);
if File /= No_File and then T = File_Stamp (File) then
return File;
@@ -2193,8 +2192,7 @@ package body Osint is
GNAT_Time : Time_Stamp_Type;
type Underlying_OS_Time is
- range -(2 ** (Standard'Address_Size - Integer'(1))) ..
- +(2 ** (Standard'Address_Size - Integer'(1)) - 1);
+ range -(2 ** 63) .. +(2 ** 63 - 1);
-- Underlying_OS_Time is a redeclaration of OS_Time to allow integer
-- manipulation. Remove this in favor of To_Ada/To_C once newer
-- GNAT releases are available with these functions.
@@ -2566,7 +2564,7 @@ package body Osint is
-- Read data from the file
declare
- Actual_Len : Integer := 0;
+ Actual_Len : Integer;
Lo : constant Text_Ptr := 0;
-- Low bound for allocated text buffer
@@ -3164,7 +3162,7 @@ package body Osint is
-- Write_With_Check --
----------------------
- procedure Write_With_Check (A : Address; N : Integer) is
+ procedure Write_With_Check (A : Address; N : Integer) is
Ignore : Boolean;
begin
if N = Write (Output_FD, A, N) then
diff --git a/gcc/ada/osint.ads b/gcc/ada/osint.ads
index 28f90aa..f1a9f84 100644
--- a/gcc/ada/osint.ads
+++ b/gcc/ada/osint.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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,11 +29,11 @@
with Namet; use Namet;
with Types; use Types;
-with System; use System;
+with System; use System;
pragma Warnings (Off);
-- This package is used also by gnatcoll
-with System.OS_Lib; use System.OS_Lib;
+with System.OS_Lib; use System.OS_Lib;
pragma Warnings (On);
with System.Storage_Elements;
@@ -140,14 +140,12 @@ package Osint is
-- path) in Name_Buffer, with the length in Name_Len.
function Program_Name (Nam : String; Prog : String) return String_Access;
- -- In the native compilation case, Create a string containing Nam. In the
+ -- In the native compilation case, creates a string containing Nam. In the
-- cross compilation case, looks at the prefix of the current program being
- -- run and prepend it to Nam. For instance if the program being run is
+ -- run and prepends it to Nam. For instance if the program being run is
-- <target>-gnatmake and Nam is "gcc", the returned value will be a pointer
- -- to "<target>-gcc". In the specific case where AAMP_On_Target is set, the
- -- name "gcc" is mapped to "gnaamp", and names of the form "gnat*" are
- -- mapped to "gnaamp*". This function clobbers Name_Buffer and Name_Len.
- -- Also look at any suffix, e.g. gnatmake-4.1 -> "gcc-4.1". Prog is the
+ -- to "<target>-gcc". This function clobbers Name_Buffer and Name_Len.
+ -- Also looks at any suffix, e.g. gnatmake-4.1 -> "gcc-4.1". Prog is the
-- default name of the current program being executed, e.g. "gnatmake",
-- "gnatlink".
@@ -718,9 +716,9 @@ private
File_Names : File_Name_Array_Ptr :=
new File_Name_Array (1 .. Int (Argument_Count) + 2);
-- As arguments are scanned, file names are stored in this array. The
- -- strings do not have terminating NUL files. The array is extensible,
- -- because when using project files, there may be more files than
- -- arguments on the command line.
+ -- strings do not have terminating NULs. The array is extensible, because
+ -- when using project files, there may be more files than arguments on the
+ -- command line.
type File_Index_Array is array (Int range <>) of Int;
type File_Index_Array_Ptr is access File_Index_Array;
@@ -772,7 +770,7 @@ private
procedure Write_Info (Info : String);
-- Implements Write_Binder_Info, Write_Debug_Info, and Write_Library_Info
- procedure Write_With_Check (A : Address; N : Integer);
+ procedure Write_With_Check (A : Address; N : Integer);
-- Writes N bytes from buffer starting at address A to file whose FD is
-- stored in Output_FD, and whose file name is stored as a File_Name_Type
-- in Output_File_Name. A check is made for disk full, and if this is
diff --git a/gcc/ada/output.adb b/gcc/ada/output.adb
index 432247f..e886b92 100644
--- a/gcc/ada/output.adb
+++ b/gcc/ada/output.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute 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.ads b/gcc/ada/output.ads
index d501602..6a36533 100644
--- a/gcc/ada/output.ads
+++ b/gcc/ada/output.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute 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-ch10.adb b/gcc/ada/par-ch10.adb
index 70984b1..f02934a 100644
--- a/gcc/ada/par-ch10.adb
+++ b/gcc/ada/par-ch10.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -555,7 +555,7 @@ package body Ch10 is
| 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_Body
| N_Package_Instantiation
| N_Package_Renaming_Declaration
| N_Package_Specification
@@ -1162,24 +1162,22 @@ package body Ch10 is
Loc : Source_Ptr;
SR_Present : Boolean)
is
- Unum : constant Unit_Number_Type := Get_Cunit_Unit_Number (Cunit);
- Sind : constant Source_File_Index := Source_Index (Unum);
- Unam : constant Unit_Name_Type := Unit_Name (Unum);
+ Unum : constant Unit_Number_Type := Get_Cunit_Unit_Number (Cunit);
+ Sind : constant Source_File_Index := Source_Index (Unum);
+ Unam : constant Unit_Name_Type := Unit_Name (Unum);
begin
- if List_Units then
- Write_Str ("Unit ");
- Write_Unit_Name (Unit_Name (Unum));
- Unit_Location (Sind, Loc);
+ Write_Str ("Unit ");
+ Write_Unit_Name (Unit_Name (Unum));
+ Unit_Location (Sind, Loc);
- if SR_Present then
- Write_Str (", SR");
- end if;
-
- Write_Str (", file name ");
- Write_Name (Get_File_Name (Unam, Nkind (Unit (Cunit)) = N_Subunit));
- Write_Eol;
+ if SR_Present then
+ Write_Str (", SR");
end if;
+
+ Write_Str (", file name ");
+ Write_Name (Get_File_Name (Unam, Nkind (Unit (Cunit)) = N_Subunit));
+ Write_Eol;
end Unit_Display;
-------------------
diff --git a/gcc/ada/par-ch11.adb b/gcc/ada/par-ch11.adb
index 63f0c6e..8304c3e 100644
--- a/gcc/ada/par-ch11.adb
+++ b/gcc/ada/par-ch11.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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,7 @@ pragma Style_Checks (All_Checks);
-- Turn off subprogram body ordering check. Subprograms are in order
-- by RM section rather than alphabetical
-with Sinfo.CN; use Sinfo.CN;
+with Sinfo.CN; use Sinfo.CN;
separate (Par)
package body Ch11 is
@@ -233,6 +233,24 @@ package body Ch11 is
Set_Expression (Raise_Node, P_Expression);
end if;
+ if Token = Tok_When then
+ Error_Msg_GNAT_Extension ("raise when statement");
+
+ Mutate_Nkind (Raise_Node, N_Raise_When_Statement);
+
+ if Token = Tok_When and then not Missing_Semicolon_On_When then
+ Scan; -- past WHEN
+ Set_Condition (Raise_Node, P_Expression_No_Right_Paren);
+
+ -- Allow IF instead of WHEN, giving error message
+
+ elsif Token = Tok_If then
+ T_When;
+ Scan; -- past IF used in place of WHEN
+ Set_Condition (Raise_Node, P_Expression_No_Right_Paren);
+ end if;
+ end if;
+
TF_Semicolon;
return Raise_Node;
end P_Raise_Statement;
diff --git a/gcc/ada/par-ch12.adb b/gcc/ada/par-ch12.adb
index a4799c7..eac3643 100644
--- a/gcc/ada/par-ch12.adb
+++ b/gcc/ada/par-ch12.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -559,6 +559,20 @@ package body Ch12 is
if Def_Node /= Error then
Set_Formal_Type_Definition (Decl_Node, Def_Node);
+
+ if Token = Tok_Or then
+ Error_Msg_Ada_2022_Feature
+ ("default for formal type", Sloc (Decl_Node));
+ Scan; -- Past OR
+
+ if Token /= Tok_Use then
+ Error_Msg_SC ("missing USE for default subtype");
+ else
+ Scan; -- Past USE
+ Set_Default_Subtype_Mark (Decl_Node, P_Name);
+ end if;
+ end if;
+
P_Aspect_Specifications (Decl_Node);
else
@@ -727,11 +741,18 @@ package body Ch12 is
return Error;
end if;
+ when Tok_Or =>
+ -- Ada_2022: incomplete type with default
+ return
+ New_Node (N_Formal_Incomplete_Type_Definition, Token_Ptr);
+
when Tok_Private =>
return P_Formal_Private_Type_Definition;
when Tok_Tagged =>
- if Next_Token_Is (Tok_Semicolon) then
+ if Next_Token_Is (Tok_Semicolon)
+ or else Next_Token_Is (Tok_Or)
+ then
Typedef_Node :=
New_Node (N_Formal_Incomplete_Type_Definition, Token_Ptr);
Set_Tagged_Present (Typedef_Node);
@@ -960,7 +981,7 @@ package body Ch12 is
-- type DT is new T with private with Atomic;
- Error_Msg_Ada_2020_Feature
+ Error_Msg_Ada_2022_Feature
("formal type with aspect specification", Token_Ptr);
return Def_Node;
diff --git a/gcc/ada/par-ch13.adb b/gcc/ada/par-ch13.adb
index 8bee840..616d398 100644
--- a/gcc/ada/par-ch13.adb
+++ b/gcc/ada/par-ch13.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute 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 78febbf..cb60614 100644
--- a/gcc/ada/par-ch2.adb
+++ b/gcc/ada/par-ch2.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute 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-ch3.adb b/gcc/ada/par-ch3.adb
index 78a3ebd..52e52dc 100644
--- a/gcc/ada/par-ch3.adb
+++ b/gcc/ada/par-ch3.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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,7 @@ pragma Style_Checks (All_Checks);
-- Turn off subprogram body ordering check. Subprograms are in order
-- by RM section rather than alphabetical.
-with Sinfo.CN; use Sinfo.CN;
+with Sinfo.CN; use Sinfo.CN;
separate (Par)
@@ -1379,9 +1379,9 @@ package body Ch3 is
procedure No_List is
begin
if Num_Idents > 1 then
- Error_Msg
+ Error_Msg_N
("identifier list not allowed for RENAMES",
- Sloc (Idents (2)));
+ Idents (2));
end if;
List_OK := False;
@@ -1486,7 +1486,7 @@ package body Ch3 is
-- access_definition
elsif Token = Tok_Renames then
- Error_Msg_Ada_2020_Feature
+ Error_Msg_Ada_2022_Feature
("object renaming without subtype", Token_Ptr);
Scan; -- past renames
@@ -2693,6 +2693,73 @@ package body Ch3 is
Scan_State : Saved_Scan_State;
Aliased_Present : Boolean := False;
+ procedure P_Index_Subtype_Def_With_Fixed_Lower_Bound
+ (Subtype_Mark : Node_Id);
+ -- Parse an unconstrained index range with a fixed lower bound:
+ -- subtype_mark range <expression> .. <>
+ -- This procedure creates a subtype_indication node for the index.
+
+ --------------------------------------------
+ -- P_Index_Range_With_Fixed_Lower_Bound --
+ --------------------------------------------
+
+ procedure P_Index_Subtype_Def_With_Fixed_Lower_Bound
+ (Subtype_Mark : Node_Id)
+ is
+ Low_Expr_Node : constant Node_Id := P_Expression;
+ High_Expr_Node : Node_Id;
+ Indic_Node : Node_Id;
+ Constr_Node : Node_Id;
+ Range_Node : Node_Id;
+
+ begin
+ T_Dot_Dot; -- Error if no ..
+
+ -- A box is required at this point, and we'll set the upper bound to
+ -- the same expression as the lower bound (see further below), to
+ -- avoid problems with trying to analyze an Empty node. Analysis can
+ -- still tell that this is a fixed-lower-bound range because the
+ -- index is represented by a subtype_indication in an unconstrained
+ -- array type definition.
+
+ if Token = Tok_Box then
+ Scan;
+ High_Expr_Node := Low_Expr_Node;
+
+ -- Error if no <> was found, and try to parse an expression since
+ -- it's likely one was given in place of the <>.
+
+ else
+ Error_Msg_AP -- CODEFIX
+ ("missing ""'<'>""");
+
+ High_Expr_Node := P_Expression;
+ end if;
+
+ Constr_Node := New_Node (N_Range_Constraint, Token_Ptr);
+ Range_Node := New_Node (N_Range, Token_Ptr);
+ Set_Range_Expression (Constr_Node, Range_Node);
+
+ Check_Simple_Expression (Low_Expr_Node);
+
+ Set_Low_Bound (Range_Node, Low_Expr_Node);
+ Set_High_Bound (Range_Node, High_Expr_Node);
+
+ Indic_Node :=
+ New_Node (N_Subtype_Indication, Sloc (Subtype_Mark));
+ Set_Subtype_Mark (Indic_Node, Check_Subtype_Mark (Subtype_Mark));
+ Set_Constraint (Indic_Node, Constr_Node);
+
+ Append (Indic_Node, Subs_List);
+ end P_Index_Subtype_Def_With_Fixed_Lower_Bound;
+
+ -- Local variables
+
+ Is_Constrained_Array_Def : Boolean := True;
+ Subtype_Mark_Node : Node_Id;
+
+ -- Start of processing for P_Array_Type_Definition
+
begin
Array_Loc := Token_Ptr;
Scan; -- past ARRAY
@@ -2724,17 +2791,125 @@ package body Ch3 is
Def_Node := New_Node (N_Unconstrained_Array_Definition, Array_Loc);
Restore_Scan_State (Scan_State); -- to first subtype mark
+ Is_Constrained_Array_Def := False;
+
+ -- Now parse a sequence of indexes where each is either of form:
+ -- <subtype_mark> range <>
+ -- or
+ -- <subtype_mark> range <expr> .. <>
+ --
+ -- The latter syntax indicates an index with a fixed lower bound,
+ -- and only applies when extensions are enabled (-gnatX).
+
loop
- Append (P_Subtype_Mark_Resync, Subs_List);
+ Subtype_Mark_Node := P_Subtype_Mark_Resync;
+
T_Range;
- T_Box;
+
+ -- Normal "subtype_mark range <>" form, so simply append
+ -- the subtype reference.
+
+ if Token = Tok_Box then
+ Append (Subtype_Mark_Node, Subs_List);
+ Scan;
+
+ -- Fixed-lower-bound form ("subtype_mark range <expr> .. <>")
+
+ else
+ P_Index_Subtype_Def_With_Fixed_Lower_Bound (Subtype_Mark_Node);
+
+ if not Extensions_Allowed then
+ Error_Msg_N
+ ("fixed-lower-bound array is an extension feature; "
+ & "use -gnatX",
+ Token_Node);
+ end if;
+ end if;
+
exit when Token = Tok_Right_Paren or else Token = Tok_Of;
T_Comma;
end loop;
Set_Subtype_Marks (Def_Node, Subs_List);
- else
+ -- If we don't have "range <>", then "range" will be followed by an
+ -- expression, for either a normal range or a fixed-lower-bound range
+ -- ("<exp> .. <>"), and we have to know which, in order to determine
+ -- whether to parse the indexes for an unconstrained or constrained
+ -- array definition. So we look ahead to see if "<>" follows the "..".
+ -- If not, then this must be a discrete_subtype_indication for a
+ -- constrained_array_definition, which will be processed further below.
+
+ elsif Prev_Token = Tok_Range
+ and then Token /= Tok_Right_Paren and then Token /= Tok_Comma
+ then
+ -- If we have an expression followed by "..", then scan farther
+ -- and check for "<>" to see if we have a fixed-lower-bound range.
+
+ if P_Expression_Or_Range_Attribute /= Error
+ and then Expr_Form /= EF_Range_Attr
+ and then Token = Tok_Dot_Dot
+ then
+ Scan;
+
+ -- If there's a "<>", then we know we have a fixed-lower-bound
+ -- index, so we can proceed with parsing an unconstrained array
+ -- definition.
+
+ if Token = Tok_Box then
+ Is_Constrained_Array_Def := False;
+
+ Def_Node :=
+ New_Node (N_Unconstrained_Array_Definition, Array_Loc);
+
+ Restore_Scan_State (Scan_State); -- to first subtype mark
+
+ -- Now parse a sequence of indexes where each is either of
+ -- form:
+ -- <subtype_mark> range <>
+ -- or
+ -- <subtype_mark> range <expr> .. <>
+ --
+ -- The latter indicates an index with a fixed lower bound,
+ -- and only applies when extensions are enabled (-gnatX).
+
+ loop
+ Subtype_Mark_Node := P_Subtype_Mark_Resync;
+
+ T_Range;
+
+ -- Normal "subtype_mark range <>" form, so simply append
+ -- the subtype reference.
+
+ if Token = Tok_Box then
+ Append (Subtype_Mark_Node, Subs_List);
+ Scan;
+
+ -- This must be an index of form:
+ -- <subtype_mark> range <expr> .. <>"
+
+ else
+ P_Index_Subtype_Def_With_Fixed_Lower_Bound
+ (Subtype_Mark_Node);
+
+ if not Extensions_Allowed then
+ Error_Msg_N
+ ("fixed-lower-bound array is an extension feature; "
+ & "use -gnatX",
+ Token_Node);
+ end if;
+ end if;
+
+ exit when Token = Tok_Right_Paren or else Token = Tok_Of;
+ T_Comma;
+ end loop;
+
+ Set_Subtype_Marks (Def_Node, Subs_List);
+ end if;
+ end if;
+ end if;
+
+ if Is_Constrained_Array_Def then
Def_Node := New_Node (N_Constrained_Array_Definition, Array_Loc);
Restore_Scan_State (Scan_State); -- to first discrete range
@@ -3217,8 +3392,30 @@ package body Ch3 is
Constr_Node := New_Node (N_Range, Token_Ptr);
Set_Low_Bound (Constr_Node, Expr_Node);
Scan; -- past ..
- Expr_Node := P_Expression;
- Check_Simple_Expression (Expr_Node);
+
+ -- If the upper bound is given by "<>", this is an index for
+ -- a fixed-lower-bound subtype, so set the expression to Empty
+ -- for now (it will be set to the ranges maximum upper bound
+ -- later during analysis), and scan to the next token.
+
+ if Token = Tok_Box then
+ if not Extensions_Allowed then
+ Error_Msg_N
+ ("fixed-lower-bound array is an extension feature; "
+ & "use -gnatX",
+ Expr_Node);
+ end if;
+
+ Expr_Node := Empty;
+ Scan;
+
+ -- Otherwise parse the range's upper bound expression
+
+ else
+ Expr_Node := P_Expression;
+ Check_Simple_Expression (Expr_Node);
+ end if;
+
Set_High_Bound (Constr_Node, Expr_Node);
Append (Constr_Node, Constr_List);
goto Loop_Continue;
diff --git a/gcc/ada/par-ch4.adb b/gcc/ada/par-ch4.adb
index 340668e..20f8dd1 100644
--- a/gcc/ada/par-ch4.adb
+++ b/gcc/ada/par-ch4.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -1280,7 +1280,7 @@ package body Ch4 is
if Nkind (Aggr_Node) /= N_Aggregate
and then
Nkind (Aggr_Node) /= N_Extension_Aggregate
- and then Ada_Version < Ada_2020
+ and then Ada_Version < Ada_2022
then
Error_Msg
("aggregate may not have single positional component", Aggr_Sloc);
@@ -1399,7 +1399,7 @@ package body Ch4 is
if Token = Tok_Left_Bracket then
Scan;
- -- Special case for null aggregate in Ada 2020
+ -- Special case for null aggregate in Ada 2022
if Token = Tok_Right_Bracket then
Scan; -- past ]
@@ -1601,7 +1601,7 @@ package body Ch4 is
-- identifier or OTHERS follows (the latter cases are missing
-- comma cases). Also assume positional if a semicolon follows,
-- which can happen if there are missing parens.
- -- In Ada_2012 and Ada_2020 an iterated association can appear.
+ -- In Ada 2012 and 2022 an iterated association can appear.
elsif Nkind (Expr_Node) in
N_Iterated_Component_Association | N_Iterated_Element_Association
@@ -1734,8 +1734,9 @@ package body Ch4 is
-- aggregates (AI-287)
function P_Record_Or_Array_Component_Association return Node_Id is
- Assoc_Node : Node_Id;
-
+ Assoc_Node : Node_Id;
+ Box_Present : Boolean := False;
+ Box_With_Identifier_Present : Boolean := False;
begin
-- A loop indicates an iterated_component_association
@@ -1744,6 +1745,8 @@ package body Ch4 is
end if;
Assoc_Node := New_Node (N_Component_Association, Token_Ptr);
+ Set_Binding_Chars (Assoc_Node, No_Name);
+
Set_Choices (Assoc_Node, P_Discrete_Choice_List);
Set_Sloc (Assoc_Node, Token_Ptr);
TF_Arrow;
@@ -1755,12 +1758,78 @@ package body Ch4 is
Error_Msg_Ada_2005_Extension ("component association with '<'>");
+ Box_Present := True;
Set_Box_Present (Assoc_Node);
- Scan; -- Past box
- else
+ Scan; -- past box
+ elsif Token = Tok_Less then
+ declare
+ Scan_State : Saved_Scan_State;
+ Id : Node_Id;
+ begin
+ Save_Scan_State (Scan_State);
+ Scan; -- past "<"
+ if Token = Tok_Identifier then
+ Id := P_Defining_Identifier;
+ if Token = Tok_Greater then
+ if Extensions_Allowed then
+ Set_Box_Present (Assoc_Node);
+ Set_Binding_Chars (Assoc_Node, Chars (Id));
+ Box_Present := True;
+ Box_With_Identifier_Present := True;
+ Scan; -- past ">"
+ else
+ Error_Msg
+ ("Identifier within box only supported under -gnatX",
+ Token_Ptr);
+ Box_Present := True;
+ -- Avoid cascading errors by ignoring the identifier
+ end if;
+ end if;
+ end if;
+ if not Box_Present then
+ -- it wasn't an "is <identifier>", so restore.
+ Restore_Scan_State (Scan_State);
+ end if;
+ end;
+ end if;
+
+ if not Box_Present then
Set_Expression (Assoc_Node, P_Expression);
end if;
+ -- Check for "is <identifier>" for aggregate that is part of
+ -- a pattern for a general case statement.
+
+ if Token = Tok_Is then
+ declare
+ Scan_State : Saved_Scan_State;
+ Id : Node_Id;
+ begin
+ Save_Scan_State (Scan_State);
+ Scan; -- past "is"
+ if Token = Tok_Identifier then
+ Id := P_Defining_Identifier;
+
+ if not Extensions_Allowed then
+ Error_Msg
+ ("IS following component association"
+ & " only supported under -gnatX",
+ Token_Ptr);
+ elsif Box_With_Identifier_Present then
+ Error_Msg
+ ("Both identifier-in-box and trailing identifier"
+ & " specified for one component association",
+ Token_Ptr);
+ else
+ Set_Binding_Chars (Assoc_Node, Chars (Id));
+ end if;
+ else
+ -- It wasn't an "is <identifier>", so restore.
+ Restore_Scan_State (Scan_State);
+ end if;
+ end;
+ end if;
+
return Assoc_Node;
end P_Record_Or_Array_Component_Association;
@@ -2928,7 +2997,7 @@ package body Ch4 is
Scan; -- past minus
when Tok_At_Sign => -- AI12-0125 : target_name
- Error_Msg_Ada_2020_Feature ("target name", Token_Ptr);
+ Error_Msg_Ada_2022_Feature ("target name", Token_Ptr);
Node1 := P_Name;
return Node1;
@@ -3396,7 +3465,7 @@ package body Ch4 is
procedure Build_Iterated_Element_Association;
-- If the iterator includes a key expression or a filter, it is
- -- an Ada_2020 Iterator_Element_Association within a container
+ -- an Ada 2022 Iterator_Element_Association within a container
-- aggregate.
----------------------------------------
@@ -3432,7 +3501,7 @@ package body Ch4 is
Save_Scan_State (State);
-- A lookahead is necessary to differentiate between the
- -- Ada 2012 form with a choice list, and the Ada 202x element
+ -- Ada 2012 form with a choice list, and the Ada 2022 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:
@@ -3463,7 +3532,7 @@ package body Ch4 is
if Token = Tok_Use then
- -- Ada_2020 Key-expression is present, rewrite node as an
+ -- Ada 2022 Key-expression is present, rewrite node as an
-- Iterated_Element_Association.
Scan; -- past USE
@@ -3471,7 +3540,7 @@ package body Ch4 is
Set_Key_Expression (Assoc_Node, P_Expression);
elsif Present (Filter) then
- -- A loop_parameter_specification also indicates an Ada_2020
+ -- A loop_parameter_specification also indicates an Ada 2022
-- construct, in contrast with a subtype indication used in
-- array aggregates.
@@ -3481,7 +3550,7 @@ package body Ch4 is
TF_Arrow;
Set_Expression (Assoc_Node, P_Expression);
- elsif Ada_Version >= Ada_2020
+ elsif Ada_Version >= Ada_2022
and then Token = Tok_Of
then
Restore_Scan_State (State);
@@ -3504,7 +3573,7 @@ package body Ch4 is
Set_Expression (Assoc_Node, P_Expression);
end if;
- Error_Msg_Ada_2020_Feature ("iterated component", Token_Ptr);
+ Error_Msg_Ada_2022_Feature ("iterated component", Token_Ptr);
return Assoc_Node;
end P_Iterated_Component_Association;
@@ -3689,7 +3758,7 @@ package body Ch4 is
Result : constant Node_Id :=
Make_Expression_With_Actions (Loc, Actions, Expression);
begin
- Error_Msg_Ada_2020_Feature ("declare expression", Loc);
+ Error_Msg_Ada_2022_Feature ("declare expression", Loc);
return Result;
end;
diff --git a/gcc/ada/par-ch5.adb b/gcc/ada/par-ch5.adb
index a8d49b1..1e55181 100644
--- a/gcc/ada/par-ch5.adb
+++ b/gcc/ada/par-ch5.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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,7 @@ pragma Style_Checks (All_Checks);
-- Turn off subprogram body ordering check. Subprograms are in order by RM
-- section rather than alphabetical.
-with Sinfo.CN; use Sinfo.CN;
+with Sinfo.CN; use Sinfo.CN;
separate (Par)
package body Ch5 is
@@ -1299,17 +1299,16 @@ package body Ch5 is
return Cond;
- -- Otherwise check for redundant parentheses
-
- -- If the condition is a conditional or a quantified expression, it is
- -- parenthesized in the context of a condition, because of a separate
- -- syntax rule.
+ -- Otherwise check for redundant parentheses but do not emit messages
+ -- about expressions that require parentheses (e.g. conditional,
+ -- quantified or declaration expressions).
else
if Style_Check
and then
Paren_Count (Cond) >
(if Nkind (Cond) in N_Case_Expression
+ | N_Expression_With_Actions
| N_If_Expression
| N_Quantified_Expression
then 1
@@ -1715,7 +1714,7 @@ package body Ch5 is
(Loop_Param_Specification_Node, P_Discrete_Subtype_Definition);
if Token = Tok_When then
- Error_Msg_Ada_2020_Feature ("iterator filter", Token_Ptr);
+ Error_Msg_Ada_2022_Feature ("iterator filter", Token_Ptr);
Scan; -- past WHEN
Set_Iterator_Filter
@@ -1742,7 +1741,15 @@ package body Ch5 is
if Token = Tok_Colon then
Scan; -- past :
- Set_Subtype_Indication (Node1, P_Subtype_Indication);
+
+ if Token = Tok_Access then
+ Error_Msg_Ada_2022_Feature
+ ("access definition in loop parameter", Token_Ptr);
+ Set_Subtype_Indication (Node1, P_Access_Definition (False));
+
+ else
+ Set_Subtype_Indication (Node1, P_Subtype_Indication);
+ end if;
end if;
if Token = Tok_Of then
@@ -1762,7 +1769,7 @@ package body Ch5 is
Set_Of_Present (Node1);
Error_Msg_N
("subtype indication is only legal on an element iterator",
- Subtype_Indication (Node1));
+ Subtype_Indication (Node1));
else
return Error;
@@ -1776,7 +1783,7 @@ package body Ch5 is
Set_Name (Node1, P_Name);
if Token = Tok_When then
- Error_Msg_Ada_2020_Feature ("iterator filter", Token_Ptr);
+ Error_Msg_Ada_2022_Feature ("iterator filter", Token_Ptr);
Scan; -- past WHEN
Set_Iterator_Filter
@@ -1906,47 +1913,6 @@ package body Ch5 is
function P_Exit_Statement return Node_Id is
Exit_Node : Node_Id;
- function Missing_Semicolon_On_Exit return Boolean;
- -- This function deals with the following specialized situation
- --
- -- when 'x' =>
- -- exit [identifier]
- -- when 'y' =>
- --
- -- This looks like a messed up EXIT WHEN, when in fact the problem
- -- is a missing semicolon. It is called with Token pointing to the
- -- WHEN token, and returns True if a semicolon is missing before
- -- the WHEN as in the above example.
-
- -------------------------------
- -- Missing_Semicolon_On_Exit --
- -------------------------------
-
- function Missing_Semicolon_On_Exit return Boolean is
- State : Saved_Scan_State;
-
- begin
- if not Token_Is_At_Start_Of_Line then
- return False;
-
- elsif Scopes (Scope.Last).Etyp /= E_Case then
- return False;
-
- else
- Save_Scan_State (State);
- Scan; -- past WHEN
- Scan; -- past token after WHEN
-
- if Token = Tok_Arrow then
- Restore_Scan_State (State);
- return True;
- else
- Restore_Scan_State (State);
- return False;
- end if;
- end if;
- end Missing_Semicolon_On_Exit;
-
-- Start of processing for P_Exit_Statement
begin
@@ -1976,7 +1942,7 @@ package body Ch5 is
end loop Check_No_Exit_Name;
end if;
- if Token = Tok_When and then not Missing_Semicolon_On_Exit then
+ if Token = Tok_When and then not Missing_Semicolon_On_When then
Scan; -- past WHEN
Set_Condition (Exit_Node, P_Condition);
@@ -2011,7 +1977,15 @@ package body Ch5 is
Scan; -- past GOTO (or TO)
Set_Name (Goto_Node, P_Qualified_Simple_Name_Resync);
Append_Elmt (Goto_Node, Goto_List);
- No_Constraint;
+
+ if Token = Tok_When then
+ Error_Msg_GNAT_Extension ("goto when statement");
+
+ Scan; -- past WHEN
+ Mutate_Nkind (Goto_Node, N_Goto_When_Statement);
+ Set_Condition (Goto_Node, P_Expression_No_Right_Paren);
+ end if;
+
TF_Semicolon;
return Goto_Node;
end P_Goto_Statement;
diff --git a/gcc/ada/par-ch6.adb b/gcc/ada/par-ch6.adb
index 145fbc4..be85d09 100644
--- a/gcc/ada/par-ch6.adb
+++ b/gcc/ada/par-ch6.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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,7 @@ pragma Style_Checks (All_Checks);
-- Turn off subprogram body ordering check. Subprograms are in order
-- by RM section rather than alphabetical
-with Sinfo.CN; use Sinfo.CN;
+with Sinfo.CN; use Sinfo.CN;
separate (Par)
package body Ch6 is
@@ -201,6 +201,28 @@ package body Ch6 is
-- Error recovery: cannot raise Error_Resync
function P_Subprogram (Pf_Flags : Pf_Rec) return Node_Id is
+
+ function Contains_Import_Aspect (Aspects : List_Id) return Boolean;
+ -- Return True if Aspects contains an Import aspect.
+
+ ----------------------------
+ -- Contains_Import_Aspect --
+ ----------------------------
+
+ function Contains_Import_Aspect (Aspects : List_Id) return Boolean is
+ Aspect : Node_Id := First (Aspects);
+ begin
+ while Present (Aspect) loop
+ if Chars (Identifier (Aspect)) = Name_Import then
+ return True;
+ end if;
+
+ Next (Aspect);
+ end loop;
+
+ return False;
+ end Contains_Import_Aspect;
+
Specification_Node : Node_Id;
Name_Node : Node_Id;
Aspects : List_Id;
@@ -982,10 +1004,12 @@ package body Ch6 is
if Pf_Flags.Pbod
-- Disconnect this processing if we have scanned a null procedure
- -- because in this case the spec is complete anyway with no body.
+ -- or an Import aspect because in this case the spec is complete
+ -- anyway with no body.
and then (Nkind (Specification_Node) /= N_Procedure_Specification
or else not Null_Present (Specification_Node))
+ and then not Contains_Import_Aspect (Aspects)
then
SIS_Labl := Scopes (Scope.Last).Labl;
SIS_Sloc := Scopes (Scope.Last).Sloc;
@@ -1620,7 +1644,7 @@ package body Ch6 is
-- the time being.
elsif Token = Tok_With then
- Error_Msg_Ada_2020_Feature
+ Error_Msg_Ada_2022_Feature
("aspect on formal parameter", Token_Ptr);
P_Aspect_Specifications (Specification_Node, False);
@@ -1874,33 +1898,34 @@ package body Ch6 is
function P_Return_Statement return Node_Id is
-- The caller has checked that the initial token is RETURN
- function Is_Simple return Boolean;
+ function Is_Extended return Boolean;
-- Scan state is just after RETURN (and is left that way). Determine
-- whether this is a simple or extended return statement by looking
-- ahead for "identifier :", which implies extended.
- ---------------
- -- Is_Simple --
- ---------------
+ -----------------
+ -- Is_Extended --
+ -----------------
- function Is_Simple return Boolean is
- Scan_State : Saved_Scan_State;
- Result : Boolean := True;
+ function Is_Extended return Boolean is
+ Scan_State : Saved_Scan_State;
+ Is_Extended : Boolean := False;
begin
+
if Token = Tok_Identifier then
Save_Scan_State (Scan_State); -- at identifier
Scan; -- past identifier
if Token = Tok_Colon then
- Result := False; -- It's an extended_return_statement.
+ Is_Extended := True;
end if;
Restore_Scan_State (Scan_State); -- to identifier
end if;
- return Result;
- end Is_Simple;
+ return Is_Extended;
+ end Is_Extended;
Ret_Sloc : constant Source_Ptr := Token_Ptr;
Ret_Strt : constant Column_Number := Start_Column;
@@ -1922,22 +1947,9 @@ package body Ch6 is
-- Nontrivial case
else
- -- Simple_return_statement with expression
-
- -- We avoid trying to scan an expression if we are at an
- -- expression terminator since in that case the best error
- -- message is probably that we have a missing semicolon.
-
- if Is_Simple then
- Ret_Node := New_Node (N_Simple_Return_Statement, Ret_Sloc);
-
- if Token not in Token_Class_Eterm then
- Set_Expression (Ret_Node, P_Expression_No_Right_Paren);
- end if;
-
-- Extended_return_statement (Ada 2005 only -- AI-318):
- else
+ if Is_Extended then
Error_Msg_Ada_2005_Extension ("extended return statement");
Ret_Node := New_Node (N_Extended_Return_Statement, Ret_Sloc);
@@ -1954,7 +1966,6 @@ package body Ch6 is
Scopes (Scope.Last).Etyp := E_Return;
Scopes (Scope.Last).Labl := Error;
Scopes (Scope.Last).Sloc := Ret_Sloc;
-
Scan; -- past DO
Set_Handled_Statement_Sequence
(Ret_Node, P_Handled_Sequence_Of_Statements);
@@ -1962,6 +1973,41 @@ package body Ch6 is
-- Do we need to handle Error_Resync here???
end if;
+
+ -- Simple_return_statement or Return_when_Statement
+ -- with expression.
+
+ -- We avoid trying to scan an expression if we are at an
+ -- expression terminator since in that case the best error
+ -- message is probably that we have a missing semicolon.
+
+ else
+ Ret_Node := New_Node (N_Simple_Return_Statement, Ret_Sloc);
+
+ if Token not in Token_Class_Eterm then
+ Set_Expression (Ret_Node, P_Expression_No_Right_Paren);
+ end if;
+
+ -- When the next token is WHEN or IF we know that we are looking
+ -- at a Return_when_statement
+
+ if Token = Tok_When and then not Missing_Semicolon_On_When then
+ Error_Msg_GNAT_Extension ("return when statement");
+ Mutate_Nkind (Ret_Node, N_Return_When_Statement);
+
+ Scan; -- past WHEN
+ Set_Condition (Ret_Node, P_Condition);
+
+ -- Allow IF instead of WHEN, giving error message
+
+ elsif Token = Tok_If then
+ Error_Msg_GNAT_Extension ("return when statement");
+ Mutate_Nkind (Ret_Node, N_Return_When_Statement);
+
+ T_When;
+ Scan; -- past IF used in place of WHEN
+ Set_Condition (Ret_Node, P_Condition);
+ end if;
end if;
TF_Semicolon;
diff --git a/gcc/ada/par-ch7.adb b/gcc/ada/par-ch7.adb
index 9645250..8bbb0ea 100644
--- a/gcc/ada/par-ch7.adb
+++ b/gcc/ada/par-ch7.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute 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-ch8.adb b/gcc/ada/par-ch8.adb
index cfcc6e0..ab2cfaf 100644
--- a/gcc/ada/par-ch8.adb
+++ b/gcc/ada/par-ch8.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute 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 151656c..e0d5631 100644
--- a/gcc/ada/par-ch9.adb
+++ b/gcc/ada/par-ch9.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute 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 4beb051..272e737 100644
--- a/gcc/ada/par-endh.adb
+++ b/gcc/ada/par-endh.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute 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 6be1e47..8356fe5 100644
--- a/gcc/ada/par-labl.adb
+++ b/gcc/ada/par-labl.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute 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 ecd5404..dcba6d5 100644
--- a/gcc/ada/par-load.adb
+++ b/gcc/ada/par-load.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -129,8 +129,8 @@ begin
Save_Style_Check_Options (Save_Style_Checks);
Save_Style_Check := Opt.Style_Check;
- -- If main unit, set Main_Unit_Entity (this will get overwritten if
- -- the main unit has a separate spec, that happens later on in Load)
+ -- If main unit, set Main_Unit_Entity (this will get overwritten if the
+ -- main unit has a separate spec, that happens later on in Load).
if Cur_Unum = Main_Unit then
Main_Unit_Entity := Cunit_Entity (Main_Unit);
@@ -182,14 +182,8 @@ begin
-- Check for predefined file case
if Name_Len > 1
+ and then Name_Buffer (1) in 'a' | 's' | 'i' | 'g'
and then Name_Buffer (2) = '-'
- and then (Name_Buffer (1) = 'a'
- or else
- Name_Buffer (1) = 's'
- or else
- Name_Buffer (1) = 'i'
- or else
- Name_Buffer (1) = 'g')
then
declare
Expect_Name : constant Unit_Name_Type := Expected_Unit (Cur_Unum);
@@ -240,17 +234,15 @@ begin
Error_Msg ("\\found unit $!", Loc);
end if;
- -- In both cases, remove the unit if it is the last unit (which it
- -- normally (always?) will be) so that it is out of the way later.
+ -- In both cases, flag the fatal error and give up
- Remove_Unit (Cur_Unum);
+ Set_Fatal_Error (Cur_Unum, Error_Detected);
+ return;
end if;
-- If current unit is a body, load its corresponding spec
- if Nkind (Unit (Curunit)) = N_Package_Body
- or else Nkind (Unit (Curunit)) = N_Subprogram_Body
- then
+ if Nkind (Unit (Curunit)) in N_Package_Body | N_Subprogram_Body then
Spec_Name := Get_Spec_Name (Unit_Name (Cur_Unum));
Unum :=
Load_Unit
@@ -274,6 +266,12 @@ begin
-- and this is also where we generate the SCO's for this spec.
if Cur_Unum = Main_Unit then
+
+ -- We generate code for the main unit body, so we need to generate
+ -- code for its spec too.
+
+ Set_Generate_Code (Unum, True);
+
Main_Unit_Entity := Cunit_Entity (Unum);
if Generate_SCO then
@@ -304,11 +302,11 @@ begin
-- If current unit is a child unit spec, load its parent. If the child unit
-- is loaded through a limited with, the parent must be as well.
- elsif Nkind (Unit (Curunit)) = N_Package_Declaration
- or else Nkind (Unit (Curunit)) = N_Subprogram_Declaration
- or else Nkind (Unit (Curunit)) in N_Generic_Declaration
- or else Nkind (Unit (Curunit)) in N_Generic_Instantiation
- or else Nkind (Unit (Curunit)) in N_Renaming_Declaration
+ elsif Nkind (Unit (Curunit)) in N_Package_Declaration
+ | N_Subprogram_Declaration
+ | N_Generic_Declaration
+ | N_Generic_Instantiation
+ | N_Renaming_Declaration
then
-- Turn style checks off for parent unit
diff --git a/gcc/ada/par-prag.adb b/gcc/ada/par-prag.adb
index 51409f2..06c7d87 100644
--- a/gcc/ada/par-prag.adb
+++ b/gcc/ada/par-prag.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -158,7 +158,7 @@ function Prag (Pragma_Node : Node_Id; Semi : Source_Ptr) return Node_Id is
procedure Check_Arg_Count (Required : Int) is
begin
if Arg_Count /= Required then
- Error_Msg ("wrong number of arguments for pragma%", Pragma_Sloc);
+ Error_Msg_N ("wrong number of arguments for pragma%", Pragma_Node);
raise Error_Resync;
end if;
end Check_Arg_Count;
@@ -177,7 +177,7 @@ function Prag (Pragma_Node : Node_Id; Semi : Source_Ptr) return Node_Id is
Error_Msg_Name_2 := Name_On;
Error_Msg_Name_3 := Name_Off;
- Error_Msg ("argument for pragma% must be% or%", Sloc (Argx));
+ Error_Msg_N ("argument for pragma% must be% or%", Argx);
raise Error_Resync;
end if;
end Check_Arg_Is_On_Or_Off;
@@ -189,9 +189,9 @@ function Prag (Pragma_Node : Node_Id; Semi : Source_Ptr) return Node_Id is
procedure Check_Arg_Is_String_Literal (Arg : Node_Id) is
begin
if Nkind (Expression (Arg)) /= N_String_Literal then
- Error_Msg
+ Error_Msg_N
("argument for pragma% must be string literal",
- Sloc (Expression (Arg)));
+ Expression (Arg));
raise Error_Resync;
end if;
end Check_Arg_Is_String_Literal;
@@ -385,13 +385,13 @@ begin
end if;
--------------
- -- Ada_2020 --
+ -- Ada_2022 --
--------------
- when Pragma_Ada_2020 =>
+ when Pragma_Ada_2022 =>
if Arg_Count = 0 then
- Ada_Version := Ada_2020;
- Ada_Version_Explicit := Ada_2020;
+ Ada_Version := Ada_2022;
+ Ada_Version_Explicit := Ada_2022;
Ada_Version_Pragma := Pragma_Node;
end if;
@@ -443,10 +443,8 @@ begin
Check_Arg_Is_On_Or_Off (Arg1);
if Chars (Expression (Arg1)) = Name_On then
- Extensions_Allowed := True;
- Ada_Version := Ada_Version_Type'Last;
+ Ada_Version := Ada_With_Extensions;
else
- Extensions_Allowed := False;
Ada_Version := Ada_Version_Explicit;
end if;
@@ -466,7 +464,7 @@ begin
A := Expression (Arg1);
if Nkind (A) /= N_Identifier then
- Error_Msg ("incorrect argument for pragma %", Sloc (A));
+ Error_Msg_N ("incorrect argument for pragma %", A);
else
Set_Name_Table_Boolean3 (Chars (A), True);
end if;
@@ -718,9 +716,9 @@ begin
begin
if Prag_Id = Pragma_Source_File_Name then
if Project_File_In_Use = In_Use then
- Error_Msg
+ Error_Msg_N
("pragma Source_File_Name cannot be used " &
- "with a project file", Pragma_Sloc);
+ "with a project file", Pragma_Node);
else
Project_File_In_Use := Not_In_Use;
@@ -728,9 +726,9 @@ begin
else
if Project_File_In_Use = Not_In_Use then
- Error_Msg
+ Error_Msg_N
("pragma Source_File_Name_Project should only be used " &
- "with a project file", Pragma_Sloc);
+ "with a project file", Pragma_Node);
else
Project_File_In_Use := In_Use;
end if;
@@ -773,9 +771,9 @@ begin
or else Intval (Expr) > 999
or else Intval (Expr) <= 0
then
- Error_Msg
+ Error_Msg_N
("pragma% index must be integer literal" &
- " in range 1 .. 999", Sloc (Expr));
+ " in range 1 .. 999", Expr);
raise Error_Resync;
else
Index := UI_To_Int (Intval (Expr));
@@ -908,8 +906,8 @@ begin
and then Num_SRef_Pragmas (Current_Source_File) = 0
and then Operating_Mode /= Check_Syntax
then
- Error_Msg -- CODEFIX
- ("first % pragma must be first line of file", Pragma_Sloc);
+ Error_Msg_N -- CODEFIX
+ ("first % pragma must be first line of file", Pragma_Node);
raise Error_Resync;
end if;
@@ -917,9 +915,9 @@ begin
if Arg_Count = 1 then
if Num_SRef_Pragmas (Current_Source_File) = 0 then
- Error_Msg
+ Error_Msg_N
("file name required for first % pragma in file",
- Pragma_Sloc);
+ Pragma_Node);
raise Error_Resync;
else
Fname := No_File;
@@ -934,17 +932,17 @@ begin
if Num_SRef_Pragmas (Current_Source_File) > 0 then
if Fname /= Full_Ref_Name (Current_Source_File) then
- Error_Msg
- ("file name must be same in all % pragmas", Pragma_Sloc);
+ Error_Msg_N
+ ("file name must be same in all % pragmas", Pragma_Node);
raise Error_Resync;
end if;
end if;
end if;
if Nkind (Expression (Arg1)) /= N_Integer_Literal then
- Error_Msg
+ Error_Msg_N
("argument for pragma% must be integer literal",
- Sloc (Expression (Arg1)));
+ Expression (Arg1));
raise Error_Resync;
-- OK, this source reference pragma is effective, however, we
@@ -1059,7 +1057,7 @@ begin
end if;
if not OK then
- Error_Msg ("incorrect argument for pragma%", Sloc (A));
+ Error_Msg_N ("incorrect argument for pragma%", A);
raise Error_Resync;
end if;
end if;
@@ -1381,7 +1379,6 @@ begin
| Pragma_Export_Function
| Pragma_Export_Object
| Pragma_Export_Procedure
- | Pragma_Export_Value
| Pragma_Export_Valued_Procedure
| Pragma_Extend_System
| Pragma_Extensions_Visible
@@ -1392,6 +1389,7 @@ begin
| Pragma_Finalize_Storage_Only
| Pragma_Ghost
| Pragma_Global
+ | Pragma_GNAT_Annotate
| Pragma_Ident
| Pragma_Implementation_Defined
| Pragma_Implemented
@@ -1525,7 +1523,6 @@ begin
| Pragma_Unevaluated_Use_Of_Old
| Pragma_Unimplemented_Unit
| Pragma_Universal_Aliasing
- | Pragma_Universal_Data
| Pragma_Unmodified
| Pragma_Unreferenced
| Pragma_Unreferenced_Objects
diff --git a/gcc/ada/par-sync.adb b/gcc/ada/par-sync.adb
index 4df97ac..4ad4627 100644
--- a/gcc/ada/par-sync.adb
+++ b/gcc/ada/par-sync.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute 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 7a3ed5c..e2965d6 100644
--- a/gcc/ada/par-tchk.adb
+++ b/gcc/ada/par-tchk.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute 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 1f26075..f4179b9 100644
--- a/gcc/ada/par-util.adb
+++ b/gcc/ada/par-util.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -254,7 +254,7 @@ package body Util is
then
return Mark;
else
- Error_Msg ("subtype mark expected", Sloc (Mark));
+ Error_Msg_N ("subtype mark expected", Mark);
return Error;
end if;
end Check_Subtype_Mark;
@@ -276,10 +276,10 @@ 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 Ada 2020.
+ -- Ditto for a right bracket in Ada 2022.
elsif Token = Tok_Right_Paren
- or else (Token = Tok_Right_Bracket and then Ada_Version >= Ada_2020)
+ or else (Token = Tok_Right_Bracket and then Ada_Version >= Ada_2022)
then
return False;
@@ -630,6 +630,35 @@ package body Util is
Scan;
end Merge_Identifier;
+ -------------------------------
+ -- Missing_Semicolon_On_When --
+ -------------------------------
+
+ function Missing_Semicolon_On_When return Boolean is
+ State : Saved_Scan_State;
+
+ begin
+ if not Token_Is_At_Start_Of_Line then
+ return False;
+
+ elsif Scopes (Scope.Last).Etyp /= E_Case then
+ return False;
+
+ else
+ Save_Scan_State (State);
+ Scan; -- past WHEN
+ Scan; -- past token after WHEN
+
+ if Token = Tok_Arrow then
+ Restore_Scan_State (State);
+ return True;
+ else
+ Restore_Scan_State (State);
+ return False;
+ end if;
+ end if;
+ end Missing_Semicolon_On_When;
+
-------------------
-- Next_Token_Is --
-------------------
diff --git a/gcc/ada/par.adb b/gcc/ada/par.adb
index 95695d2..312c411 100644
--- a/gcc/ada/par.adb
+++ b/gcc/ada/par.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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,33 +23,35 @@
-- --
------------------------------------------------------------------------------
-with Aspects; use Aspects;
-with Atree; use Atree;
-with Casing; use Casing;
-with Debug; use Debug;
-with Elists; use Elists;
-with Errout; use Errout;
-with Fname; use Fname;
-with Lib; use Lib;
-with Namet; use Namet;
-with Namet.Sp; use Namet.Sp;
-with Nlists; use Nlists;
-with Nmake; use Nmake;
-with Opt; use Opt;
-with Output; use Output;
-with Par_SCO; use Par_SCO;
-with Restrict; use Restrict;
-with Scans; use Scans;
-with Scn; use Scn;
-with Sem_Util; use Sem_Util;
-with Sinput; use Sinput;
-with Sinput.L; use Sinput.L;
-with Sinfo; use Sinfo;
-with Snames; use Snames;
+with Aspects; use Aspects;
+with Atree; use Atree;
+with Casing; use Casing;
+with Debug; use Debug;
+with Elists; use Elists;
+with Errout; use Errout;
+with Fname; use Fname;
+with Lib; use Lib;
+with Namet; use Namet;
+with Namet.Sp; use Namet.Sp;
+with Nlists; use Nlists;
+with Nmake; use Nmake;
+with Opt; use Opt;
+with Output; use Output;
+with Par_SCO; use Par_SCO;
+with Restrict; use Restrict;
+with Scans; use Scans;
+with Scn; use Scn;
+with Sem_Util; use Sem_Util;
+with Sinput; use Sinput;
+with Sinput.L; use Sinput.L;
+with Sinfo; use Sinfo;
+with Sinfo.Nodes; use Sinfo.Nodes;
+with Sinfo.Utils; use Sinfo.Utils;
+with Snames; use Snames;
with Style;
-with Stylesw; use Stylesw;
+with Stylesw; use Stylesw;
with Table;
-with Tbuild; use Tbuild;
+with Tbuild; use Tbuild;
---------
-- Par --
@@ -1349,6 +1351,18 @@ function Par (Configuration_Pragmas : Boolean) return List_Id is
-- conditions are met, an error message is issued, and the merge is
-- carried out, modifying the Chars field of Prev.
+ function Missing_Semicolon_On_When return Boolean;
+ -- This function deals with the following specialized situations
+ --
+ -- when 'x' =>
+ -- exit/return [identifier]
+ -- when 'y' =>
+ --
+ -- This looks like a messed up EXIT WHEN or RETURN WHEN, when in fact
+ -- the problem is a missing semicolon. It is called with Token pointing
+ -- to the WHEN token, and returns True if a semicolon is missing before
+ -- the WHEN as in the above example.
+
function Next_Token_Is (Tok : Token_Type) return Boolean;
-- Looks at token after current one and returns True if the token type
-- matches Tok. The scan is unconditionally restored on return.
@@ -1636,14 +1650,12 @@ begin
Uname : constant String :=
Get_Name_String
(Unit_Name (Current_Source_Unit));
- Name : String (1 .. Uname'Length - 2);
-
- begin
+ Name : String renames
+ Uname (Uname'First .. Uname'Last - 2);
-- Because Unit_Name includes "%s"/"%b", we need to strip
-- the last two characters to get the real unit name.
- Name := Uname (Uname'First .. Uname'Last - 2);
-
+ begin
if Name = "ada" or else
Name = "interfaces" or else
Name = "system"
diff --git a/gcc/ada/par.ads b/gcc/ada/par.ads
index 10d0e40..9d7b864 100644
--- a/gcc/ada/par.ads
+++ b/gcc/ada/par.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute 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 1579653..b4f7609 100644
--- a/gcc/ada/par_sco.adb
+++ b/gcc/ada/par_sco.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2009-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2009-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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,26 +23,28 @@
-- --
------------------------------------------------------------------------------
-with Aspects; use Aspects;
-with Atree; use Atree;
-with Debug; use Debug;
-with Errout; use Errout;
-with Lib; use Lib;
-with Lib.Util; use Lib.Util;
-with Namet; use Namet;
-with Nlists; use Nlists;
-with Opt; use Opt;
-with Output; use Output;
+with Aspects; use Aspects;
+with Atree; use Atree;
+with Debug; use Debug;
+with Errout; use Errout;
+with Lib; use Lib;
+with Lib.Util; use Lib.Util;
+with Namet; use Namet;
+with Nlists; use Nlists;
+with Opt; use Opt;
+with Output; use Output;
with Put_SCOs;
-with SCOs; use SCOs;
-with Sem; use Sem;
-with Sem_Util; use Sem_Util;
-with Sinfo; use Sinfo;
-with Sinput; use Sinput;
-with Snames; use Snames;
+with SCOs; use SCOs;
+with Sem; use Sem;
+with Sem_Util; use Sem_Util;
+with Sinfo; use Sinfo;
+with Sinfo.Nodes; use Sinfo.Nodes;
+with Sinfo.Utils; use Sinfo.Utils;
+with Sinput; use Sinput;
+with Snames; use Snames;
with Table;
-with GNAT.HTable; use GNAT.HTable;
+with GNAT.HTable; use GNAT.HTable;
with GNAT.Heap_Sort_G;
package body Par_SCO is
@@ -681,9 +683,12 @@ package body Par_SCO is
-- two levels (through the pragma argument association) to
-- get to the pragma node itself. For the guard on a select
-- alternative, we do not have access to the token location for
- -- the WHEN, so we use the first sloc of the condition itself
- -- (note: we use First_Sloc, not Sloc, because this is what is
- -- referenced by dominance markers).
+ -- the WHEN, so we use the first sloc of the condition itself.
+ -- First_Sloc gives the most sensible result, but we have to
+ -- beware of also using it when computing the dominance marker
+ -- sloc (in the Set_Statement_Entry procedure), as this is not
+ -- fully equivalent to the "To" sloc computed by
+ -- Sloc_Range (Guard, To, From).
-- Doesn't this requirement of using First_Sloc need to be
-- documented in the spec ???
@@ -1422,7 +1427,7 @@ package body Par_SCO is
-- Dominance information for the current basic block
Current_Test : Node_Id;
- -- Conditional node (N_If_Statement or N_Elsiif being processed
+ -- Conditional node (N_If_Statement or N_Elsif being processed)
N : Node_Id;
@@ -1577,6 +1582,18 @@ package body Par_SCO is
To := No_Location;
end if;
+ -- Be consistent with the location determined in
+ -- Output_Header.
+
+ if Current_Dominant.K = 'T'
+ and then Nkind (Parent (Current_Dominant.N))
+ in N_Accept_Alternative
+ | N_Delay_Alternative
+ | N_Terminate_Alternative
+ then
+ From := First_Sloc (Current_Dominant.N);
+ end if;
+
Set_Raw_Table_Entry
(C1 => '>',
C2 => Current_Dominant.K,
@@ -1865,7 +1882,7 @@ package body Par_SCO is
Process_Decisions_Defer (Cond, 'G');
-- For an entry body with a barrier, the entry body
- -- is dominanted by a True evaluation of the barrier.
+ -- is dominated by a True evaluation of the barrier.
Inner_Dominant := ('T', N);
end if;
diff --git a/gcc/ada/par_sco.ads b/gcc/ada/par_sco.ads
index 8cb2118..da8cded 100644
--- a/gcc/ada/par_sco.ads
+++ b/gcc/ada/par_sco.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2009-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2009-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute 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 c00962d..f7717bf 100644
--- a/gcc/ada/pprint.adb
+++ b/gcc/ada/pprint.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2008-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2008-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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,20 +23,25 @@
-- --
------------------------------------------------------------------------------
-with Atree; use Atree;
-with Csets; use Csets;
-with Einfo; use Einfo;
-with Namet; use Namet;
-with Nlists; use Nlists;
-with Opt; use Opt;
-with Sinfo; use Sinfo;
-with Sinput; use Sinput;
-with Snames; use Snames;
-with Uintp; use Uintp;
+with Atree; use Atree;
+with Einfo; use Einfo;
+with Einfo.Entities; use Einfo.Entities;
+with Einfo.Utils; use Einfo.Utils;
+with Namet; use Namet;
+with Nlists; use Nlists;
+with Opt; use Opt;
+with Sinfo; use Sinfo;
+with Sinfo.Nodes; use Sinfo.Nodes;
+with Sinfo.Utils; use Sinfo.Utils;
+with Sinput; use Sinput;
+with Snames; use Snames;
+with Uintp; use Uintp;
+
+with System.Case_Util;
package body Pprint is
- List_Name_Count : Integer := 0;
+ List_Name_Count : Natural := 0;
-- Counter used to prevent infinite recursion while computing name of
-- complex expressions.
@@ -225,8 +230,7 @@ package body Pprint is
end;
when N_Integer_Literal =>
- UI_Image (Intval (Expr));
- return UI_Image_Buffer (1 .. UI_Image_Length);
+ return UI_Image (Intval (Expr));
when N_Real_Literal =>
return Real_Image (Realval (Expr));
@@ -238,10 +242,10 @@ package body Pprint is
return "new " & Expr_Name (Expression (Expr));
when N_Aggregate =>
- if Present (Sinfo.Expressions (Expr)) then
+ if Present (Expressions (Expr)) then
return
List_Name
- (List => First (Sinfo.Expressions (Expr)),
+ (List => First (Expressions (Expr)),
Add_Space => False);
-- Do not return empty string for (others => <>) aggregate
@@ -265,39 +269,13 @@ package body Pprint is
when N_Extension_Aggregate =>
return "(" & Expr_Name (Ancestor_Part (Expr)) & " with "
& List_Name
- (List => First (Sinfo.Expressions (Expr)),
+ (List => First (Expressions (Expr)),
Add_Space => False,
Add_Paren => False) & ")";
when N_Attribute_Reference =>
if Take_Prefix then
declare
- function To_Mixed_Case (S : String) return String;
- -- Transform given string into the corresponding one in
- -- mixed case form.
-
- -------------------
- -- To_Mixed_Case --
- -------------------
-
- function To_Mixed_Case (S : String) return String is
- Result : String (S'Range);
- Ucase : Boolean := True;
-
- begin
- for J in S'Range loop
- if Ucase then
- Result (J) := Fold_Upper (S (J));
- else
- Result (J) := Fold_Lower (S (J));
- end if;
-
- Ucase := (S (J) = '_');
- end loop;
-
- return Result;
- end To_Mixed_Case;
-
Id : constant Attribute_Id :=
Get_Attribute_Id (Attribute_Name (Expr));
@@ -306,7 +284,7 @@ package body Pprint is
Str : constant String :=
Expr_Name (Prefix (Expr))
& "'"
- & To_Mixed_Case
+ & System.Case_Util.To_Mixed
(Get_Name_String (Attribute_Name (Expr)));
N : Node_Id;
@@ -382,9 +360,8 @@ package body Pprint is
and then Nkind (Decl) = N_Object_Declaration
and then not Comes_From_Source (Decl)
and then Constant_Present (Decl)
- and then Present (Sinfo.Expression (Decl))
- and then Nkind (Sinfo.Expression (Decl)) =
- N_Reference
+ and then Present (Expression (Decl))
+ and then Nkind (Expression (Decl)) = N_Reference
then
return "";
end if;
@@ -437,12 +414,14 @@ package body Pprint is
when N_If_Expression =>
declare
- N : constant Node_Id := First (Sinfo.Expressions (Expr));
+ Cond_Expr : constant Node_Id := First (Expressions (Expr));
+ Then_Expr : constant Node_Id := Next (Cond_Expr);
+ Else_Expr : constant Node_Id := Next (Then_Expr);
begin
return
- "if " & Expr_Name (N) & " then "
- & Expr_Name (Next (N)) & " else "
- & Expr_Name (Next (Next (N)));
+ "if " & Expr_Name (Cond_Expr) & " then "
+ & Expr_Name (Then_Expr) & " else "
+ & Expr_Name (Else_Expr);
end;
when N_Qualified_Expression =>
@@ -648,9 +627,9 @@ package body Pprint is
if Take_Prefix then
return
Expr_Name (Prefix (Expr))
- & List_Name (First (Sinfo.Expressions (Expr)));
+ & List_Name (First (Expressions (Expr)));
else
- return List_Name (First (Sinfo.Expressions (Expr)));
+ return List_Name (First (Expressions (Expr)));
end if;
when N_Function_Call =>
@@ -662,13 +641,12 @@ package body Pprint is
if Default = "" then
return '('
& Expr_Name (Name (Expr))
- & List_Name (First (Sinfo.Parameter_Associations (Expr)))
+ & List_Name (First (Parameter_Associations (Expr)))
& ')';
else
return
Expr_Name (Name (Expr))
- & List_Name
- (First (Sinfo.Parameter_Associations (Expr)));
+ & List_Name (First (Parameter_Associations (Expr)));
end if;
when N_Null =>
@@ -682,7 +660,7 @@ package body Pprint is
end case;
end Expr_Name;
- -- Start of processing for Expression_Name
+ -- Start of processing for Expression_Image
begin
if not From_Source then
@@ -697,6 +675,12 @@ package body Pprint is
end;
end if;
+ -- Reach to the underlying expression for an expression-with-actions
+
+ if Nkind (Expr) = N_Expression_With_Actions then
+ return Expression_Image (Expression (Expr), Default);
+ end if;
+
-- Compute left (start) and right (end) slocs for the expression
-- Consider using Sinput.Sloc_Range instead, except that it does not
-- work properly currently???
@@ -788,11 +772,11 @@ package body Pprint is
end if;
when N_Indexed_Component =>
- Right := Original_Node (Last (Sinfo.Expressions (Right)));
+ Right := Original_Node (Last (Expressions (Right)));
Append_Paren := Append_Paren + 1;
when N_Function_Call =>
- if Present (Sinfo.Parameter_Associations (Right)) then
+ if Present (Parameter_Associations (Right)) then
declare
Rover : Node_Id;
Found : Boolean;
@@ -801,7 +785,7 @@ package body Pprint is
-- Avoid source position confusion associated with
-- parameters for which Comes_From_Source is False.
- Rover := First (Sinfo.Parameter_Associations (Right));
+ Rover := First (Parameter_Associations (Right));
Found := False;
while Present (Rover) loop
if Comes_From_Source (Original_Node (Rover)) then
diff --git a/gcc/ada/pprint.ads b/gcc/ada/pprint.ads
index 4b8bd9c..dbfbb2e 100644
--- a/gcc/ada/pprint.ads
+++ b/gcc/ada/pprint.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2008-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2008-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute 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 044fe20..37556d5 100644
--- a/gcc/ada/prep.adb
+++ b/gcc/ada/prep.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2002-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2002-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute 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 5ee6c49..91ed310 100644
--- a/gcc/ada/prep.ads
+++ b/gcc/ada/prep.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2002-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2002-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute 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 61628ba..d5ccbf9 100644
--- a/gcc/ada/prepcomp.adb
+++ b/gcc/ada/prepcomp.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2003-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2003-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute 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 de6db1b..9aefdf8 100644
--- a/gcc/ada/prepcomp.ads
+++ b/gcc/ada/prepcomp.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2002-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2002-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute 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 3b02468..1873603 100644
--- a/gcc/ada/put_scos.adb
+++ b/gcc/ada/put_scos.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2009-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2009-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute 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 3b1a7bc..912350f 100644
--- a/gcc/ada/put_scos.ads
+++ b/gcc/ada/put_scos.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2009-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2009-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute 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 b096eba..5fdd76f 100644
--- a/gcc/ada/raise-gcc.c
+++ b/gcc/ada/raise-gcc.c
@@ -6,7 +6,7 @@
* *
* C Implementation File *
* *
- * Copyright (C) 1992-2020, Free Software Foundation, Inc. *
+ * Copyright (C) 1992-2021, Free Software Foundation, Inc. *
* *
* GNAT is 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,14 +48,13 @@
# endif
#endif
-#include <stdarg.h>
-
#ifdef __cplusplus
+# include <cstdarg>
# include <cstdlib>
#else
-typedef char bool;
-# define true 1
-# define false 0
+# include <stdarg.h>
+# include <stdbool.h>
+# include <stdlib.h>
#endif
#include "raise.h"
@@ -123,7 +122,6 @@ extern void __gnat_raise_abort (void) __attribute__ ((noreturn));
#define abort() __gnat_raise_abort()
#elif defined(STANDALONE)
-#include <stdlib.h>
#define inhibit_libc
#endif
@@ -542,17 +540,17 @@ typedef struct
/* ABI header, maximally aligned. */
} _GNAT_Exception;
-/* The two constants below are specific ttype identifiers for special
+/* The three constants below are specific ttype identifiers for special
exception ids. Their type should match what a-exexpr exports. */
-extern const int __gnat_others_value;
-#define GNAT_OTHERS ((_Unwind_Ptr) &__gnat_others_value)
+extern char __gnat_others_value;
+#define GNAT_OTHERS ((Exception_Id) &__gnat_others_value)
-extern const int __gnat_all_others_value;
-#define GNAT_ALL_OTHERS ((_Unwind_Ptr) &__gnat_all_others_value)
+extern char __gnat_all_others_value;
+#define GNAT_ALL_OTHERS ((Exception_Id) &__gnat_all_others_value)
-extern const int __gnat_unhandled_others_value;
-#define GNAT_UNHANDLED_OTHERS ((_Unwind_Ptr) &__gnat_unhandled_others_value)
+extern char __gnat_unhandled_others_value;
+#define GNAT_UNHANDLED_OTHERS ((Exception_Id) &__gnat_unhandled_others_value)
/* Describe the useful region data associated with an unwind context. */
@@ -902,12 +900,10 @@ get_call_site_action_for (_Unwind_Ptr ip,
#define Foreign_Data_For __gnat_foreign_data_for
#define EID_For __gnat_eid_for
-extern bool Is_Handled_By_Others (_Unwind_Ptr eid);
-extern char Language_For (_Unwind_Ptr eid);
-
-extern void *Foreign_Data_For (_Unwind_Ptr eid);
-
-extern Exception_Id EID_For (_GNAT_Exception * e);
+extern bool Is_Handled_By_Others (Exception_Id eid);
+extern char Language_For (Exception_Id eid);
+extern void *Foreign_Data_For (Exception_Id eid);
+extern Exception_Id EID_For (_GNAT_Exception *e);
#define Foreign_Exception system__exceptions__foreign_exception
extern struct Exception_Data Foreign_Exception;
@@ -928,7 +924,7 @@ exception_class_eq (const _GNAT_Exception *except,
/* Return how CHOICE matches PROPAGATED_EXCEPTION. */
static enum action_kind
-is_handled_by (_Unwind_Ptr choice, _GNAT_Exception *propagated_exception)
+is_handled_by (Exception_Id choice, _GNAT_Exception *propagated_exception)
{
/* All others choice match everything. */
if (choice == GNAT_ALL_OTHERS)
@@ -937,14 +933,10 @@ is_handled_by (_Unwind_Ptr choice, _GNAT_Exception *propagated_exception)
/* GNAT exception occurrence. */
if (exception_class_eq (propagated_exception, GNAT_EXCEPTION_CLASS))
{
- /* Pointer to the GNAT exception data corresponding to the propagated
- occurrence. */
- _Unwind_Ptr E = (_Unwind_Ptr) EID_For (propagated_exception);
-
if (choice == GNAT_UNHANDLED_OTHERS)
return unhandler;
- E = (_Unwind_Ptr) EID_For (propagated_exception);
+ Exception_Id E = EID_For (propagated_exception);
/* Base matching rules: An exception data (id) matches itself, "when
all_others" matches anything and "when others" matches anything
@@ -960,7 +952,7 @@ is_handled_by (_Unwind_Ptr choice, _GNAT_Exception *propagated_exception)
if (choice == GNAT_ALL_OTHERS
|| choice == GNAT_OTHERS
#ifndef CERT
- || choice == (_Unwind_Ptr) &Foreign_Exception
+ || choice == &Foreign_Exception
#endif
)
return handler;
@@ -1057,25 +1049,25 @@ get_action_description_for (_Unwind_Ptr ip,
/* Positive filters are for regular handlers. */
else if (ar_filter > 0)
{
- /* Do not catch an exception if the _UA_FORCE_UNWIND flag is
- passed (to follow the ABI). */
- if (!(uw_phase & _UA_FORCE_UNWIND))
- {
+ /* Do not catch an exception if the _UA_FORCE_UNWIND flag is
+ passed (to follow the ABI). */
+ if (!(uw_phase & _UA_FORCE_UNWIND))
+ {
enum action_kind act;
- /* See if the filter we have is for an exception which
- matches the one we are propagating. */
- _Unwind_Ptr choice =
- get_ttype_entry_for (region, ar_filter);
+ /* See if the filter we have is for an exception which
+ matches the one we are propagating. */
+ Exception_Id choice
+ = (Exception_Id) get_ttype_entry_for (region, ar_filter);
act = is_handled_by (choice, gnat_exception);
- if (act != nothing)
- {
+ if (act != nothing)
+ {
action->kind = act;
- action->ttype_filter = ar_filter;
- return;
- }
- }
+ action->ttype_filter = ar_filter;
+ return;
+ }
+ }
}
/* Negative filter values are for C++ exception specifications.
@@ -1612,7 +1604,7 @@ __gnat_personality_seh0 (PEXCEPTION_RECORD ms_exc, void *this_frame,
return
_GCC_specific_handler (ms_exc, this_frame, ms_orig_context, ms_disp,
- __gnat_personality_imp);
+ PERSONALITY_FUNCTION);
}
/* Define __gnat_personality_v0 for convenience */
diff --git a/gcc/ada/raise.c b/gcc/ada/raise.c
index 0454c20..0c12d07 100644
--- a/gcc/ada/raise.c
+++ b/gcc/ada/raise.c
@@ -6,7 +6,7 @@
* *
* C Implementation File *
* *
- * Copyright (C) 1992-2020, Free Software Foundation, Inc. *
+ * Copyright (C) 1992-2021, Free Software Foundation, Inc. *
* *
* GNAT is 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,67 +62,13 @@ __gnat_unhandled_terminate (void)
#ifndef IN_RTS
int
__gnat_backtrace (void **array ATTRIBUTE_UNUSED,
- int size ATTRIBUTE_UNUSED,
- void *exclude_min ATTRIBUTE_UNUSED,
- void *exclude_max ATTRIBUTE_UNUSED,
- int skip_frames ATTRIBUTE_UNUSED)
+ int size ATTRIBUTE_UNUSED,
+ void *exclude_min ATTRIBUTE_UNUSED,
+ void *exclude_max ATTRIBUTE_UNUSED,
+ int skip_frames ATTRIBUTE_UNUSED)
{
return 0;
}
-
-void
-__gnat_eh_personality (void)
-{
- abort ();
-}
-
-void
-__gnat_rcheck_04 (void)
-{
- abort ();
-}
-
-void
-__gnat_rcheck_10 (void)
-{
- abort ();
-}
-
-void
-__gnat_rcheck_19 (void)
-{
- abort ();
-}
-
-void
-__gnat_rcheck_20 (void)
-{
- abort ();
-}
-
-void
-__gnat_rcheck_21 (void)
-{
- abort ();
-}
-
-void
-__gnat_rcheck_30 (void)
-{
- abort ();
-}
-
-void
-__gnat_rcheck_31 (void)
-{
- abort ();
-}
-
-void
-__gnat_rcheck_32 (void)
-{
- abort ();
-}
#endif
#ifdef __cplusplus
}
diff --git a/gcc/ada/raise.h b/gcc/ada/raise.h
index 2e42656..b2793b5 100644
--- a/gcc/ada/raise.h
+++ b/gcc/ada/raise.h
@@ -6,7 +6,7 @@
* *
* C Header File *
* *
- * Copyright (C) 1992-2020, Free Software Foundation, Inc. *
+ * Copyright (C) 1992-2021, Free Software Foundation, Inc. *
* *
* GNAT is 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,9 +40,9 @@ struct Exception_Data
char Not_Handled_By_Others;
char Lang;
int Name_Length;
- char *Full_Name;
- char *Htable_Ptr;
- void *Foreign_Data;
+ __UINTPTR_TYPE__ Full_Name;
+ void *HTable_Ptr;
+ __UINTPTR_TYPE__ Foreign_Data;
void (*Raise_Hook)(void);
};
@@ -50,13 +50,11 @@ typedef struct Exception_Data *Exception_Id;
struct Exception_Occurrence;
-extern void _gnat_builtin_longjmp (void *, int);
extern void __gnat_unhandled_terminate (void);
extern void *__gnat_malloc (__SIZE_TYPE__);
extern void __gnat_free (void *);
extern void *__gnat_realloc (void *, __SIZE_TYPE__);
extern void __gnat_finalize (void);
-extern void set_gnat_exit_status (int);
extern void __gnat_set_globals (void);
extern void __gnat_initialize (void *);
extern void __gnat_init_float (void);
diff --git a/gcc/ada/repinfo-input.adb b/gcc/ada/repinfo-input.adb
index e00fa1d..5d85040 100644
--- a/gcc/ada/repinfo-input.adb
+++ b/gcc/ada/repinfo-input.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2018-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2018-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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,7 +38,7 @@ package body Repinfo.Input is
-- Value for Storage_Unit
type JSON_Entity_Kind is (JE_Record_Type, JE_Array_Type, JE_Other);
- -- Kind of an entiy
+ -- Kind of an entity
type JSON_Entity_Node (Kind : JSON_Entity_Kind := JE_Other) is record
Esize : Node_Ref_Or_Val;
@@ -215,7 +215,7 @@ package body Repinfo.Input is
J_COMMA,
J_COLON,
J_EOF);
- -- JSON Token kind. Note that in ECMA 404 there is no notion of integer.
+ -- JSON token kind. Note that in ECMA 404 there is no notion of integer.
-- Only numbers are supported. In our implementation we return J_INTEGER
-- if there is no decimal part in the number. The semantic is that this
-- is a J_NUMBER token that might be represented as an integer. Special
@@ -1219,7 +1219,7 @@ package body Repinfo.Input is
Var : JSON_Variant_Node;
begin
- -- Read a non-empty array of components
+ -- Read a nonempty array of components
Read_Token_And_Error (J_ARRAY, Token_Start, Token_End);
diff --git a/gcc/ada/repinfo-input.ads b/gcc/ada/repinfo-input.ads
index ead9a4b..fc34f02 100644
--- a/gcc/ada/repinfo-input.ads
+++ b/gcc/ada/repinfo-input.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2018-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2018-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute 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.adb b/gcc/ada/repinfo.adb
index bfb8af3..148de53 100644
--- a/gcc/ada/repinfo.adb
+++ b/gcc/ada/repinfo.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1999-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1999-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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,25 +24,29 @@
------------------------------------------------------------------------------
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 Sem_Eval; use Sem_Eval;
-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 Einfo.Entities; use Einfo.Entities;
+with Einfo.Utils; use Einfo.Utils;
+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 Sinfo.Nodes; use Sinfo.Nodes;
+with Sinfo.Utils; use Sinfo.Utils;
+with Sinput; use Sinput;
+with Snames; use Snames;
+with Stringt; use Stringt;
with Table;
with Ttypes;
-with Uname; use Uname;
-with Urealp; use Urealp;
+with Uname; use Uname;
+with Urealp; use Urealp;
with Ada.Unchecked_Conversion;
@@ -406,15 +410,23 @@ package body Repinfo is
end if;
end if;
- if List_Representation_Info_To_JSON then
- Write_Str (" ""Alignment"": ");
- Write_Val (Alignment (Ent));
+ if Known_Alignment (Ent) then
+ if List_Representation_Info_To_JSON then
+ Write_Str (" ""Alignment"": ");
+ Write_Val (Alignment (Ent));
+ else
+ Write_Str ("for ");
+ List_Name (Ent);
+ Write_Str ("'Alignment use ");
+ Write_Val (Alignment (Ent));
+ Write_Line (";");
+ end if;
+
+ -- Alignment is not always set for task and protected types
+
else
- Write_Str ("for ");
- List_Name (Ent);
- Write_Str ("'Alignment use ");
- Write_Val (Alignment (Ent));
- Write_Line (";");
+ pragma Assert
+ (Is_Concurrent_Type (Ent) or else Is_Class_Wide_Type (Ent));
end if;
end List_Common_Type_Info;
@@ -959,10 +971,15 @@ package body Repinfo is
procedure List_Structural_Record_Layout
(Ent : Entity_Id;
- Outer_Ent : Entity_Id;
+ Ext_Ent : Entity_Id;
+ Ext_Level : Nat := 0;
Variant : Node_Id := Empty;
Indent : Natural := 0);
- -- Internal recursive procedure to display the structural layout
+ -- Internal recursive procedure to display the structural layout.
+ -- If Ext_Ent is not equal to Ent, it is an extension of Ent and
+ -- Ext_Level is the number of successive extensions between them.
+ -- If Variant is present, it's for a variant in the variant part
+ -- instead of the common part of Ent. Indent is the indentation.
Incomplete_Layout : exception;
-- Exception raised if the layout is incomplete in -gnatc mode
@@ -1027,7 +1044,7 @@ package body Repinfo is
-- whose position is not specified have starting normalized
-- bit position of zero.
- if Unknown_Normalized_First_Bit (Comp)
+ if not Known_Normalized_First_Bit (Comp)
and then not Is_Packed (Ent)
then
Set_Normalized_First_Bit (Comp, Uint_0);
@@ -1040,7 +1057,7 @@ package body Repinfo is
-- Complete annotation in case not done
- if Unknown_Normalized_First_Bit (Comp) then
+ if not Known_Normalized_First_Bit (Comp) then
Set_Normalized_Position (Comp, Npos);
Set_Normalized_First_Bit (Comp, Fbit);
end if;
@@ -1198,7 +1215,7 @@ package body Repinfo is
-- No_Uint, not Uint_0. Really everyone should use No_Uint???
elsif List_Representation_Info < 3
- or else (Esize (Ent) /= Uint_0 and then Unknown_Esize (Ent))
+ or else (Esize (Ent) /= Uint_0 and then not Known_Esize (Ent))
then
Write_Unknown_Val;
@@ -1315,7 +1332,12 @@ package body Repinfo is
end if;
end if;
- List_Component_Layout (Comp,
+ -- The Parent_Subtype in an extension is not back-annotated
+
+ List_Component_Layout (
+ (if Known_Normalized_Position (Comp)
+ then Comp
+ else Original_Record_Component (Comp)),
Starting_Position, Starting_First_Bit, Prefix);
end;
@@ -1330,15 +1352,16 @@ package body Repinfo is
procedure List_Structural_Record_Layout
(Ent : Entity_Id;
- Outer_Ent : Entity_Id;
+ Ext_Ent : Entity_Id;
+ Ext_Level : Nat := 0;
Variant : Node_Id := Empty;
Indent : Natural := 0)
is
function Derived_Discriminant (Disc : Entity_Id) return Entity_Id;
- -- This function assumes that Outer_Ent is an extension of Ent.
+ -- This function assumes that Ext_Ent is an extension of Ent.
-- Disc is a discriminant of Ent that does not itself constrain a
-- discriminant of the parent type of Ent. Return the discriminant
- -- of Outer_Ent that ultimately constrains Disc, if any.
+ -- of Ext_Ent that ultimately constrains Disc, if any.
----------------------------
-- Derived_Discriminant --
@@ -1349,7 +1372,7 @@ package body Repinfo is
Derived_Disc : Entity_Id;
begin
- Derived_Disc := First_Discriminant (Outer_Ent);
+ Derived_Disc := First_Discriminant (Ext_Ent);
-- Loop over the discriminants of the extension
@@ -1376,7 +1399,7 @@ package body Repinfo is
Next_Discriminant (Derived_Disc);
end loop;
- -- Disc is not constrained by a discriminant of Outer_Ent
+ -- Disc is not constrained by a discriminant of Ext_Ent
return Empty;
end Derived_Discriminant;
@@ -1428,12 +1451,21 @@ package body Repinfo is
pragma Assert (Present (Parent_Type));
end if;
- Parent_Type := Base_Type (Parent_Type);
- if not In_Extended_Main_Source_Unit (Parent_Type) then
- raise Not_In_Extended_Main;
+ -- Do not list variants if one of them has been selected
+
+ if Has_Static_Discriminants (Parent_Type) then
+ List_Record_Layout (Parent_Type);
+
+ else
+ Parent_Type := Base_Type (Parent_Type);
+ if not In_Extended_Main_Source_Unit (Parent_Type) then
+ raise Not_In_Extended_Main;
+ end if;
+
+ List_Structural_Record_Layout
+ (Parent_Type, Ext_Ent, Ext_Level + 1);
end if;
- List_Structural_Record_Layout (Parent_Type, Outer_Ent);
First := False;
if Present (Record_Extension_Part (Definition)) then
@@ -1463,7 +1495,7 @@ package body Repinfo is
-- If this is the parent type of an extension, retrieve
-- the derived discriminant from the extension, if any.
- if Ent /= Outer_Ent then
+ if Ent /= Ext_Ent then
Listed_Disc := Derived_Discriminant (Disc);
if No (Listed_Disc) then
@@ -1540,7 +1572,11 @@ package body Repinfo is
Spaces (Indent);
Write_Line (" ],");
Spaces (Indent);
- Write_Str (" ""variant"" : [");
+ Write_Str (" """);
+ for J in 1 .. Ext_Level loop
+ Write_Str ("parent_");
+ end loop;
+ Write_Str ("variant"" : [");
-- Otherwise we recurse on each variant
@@ -1563,7 +1599,8 @@ package body Repinfo is
Spaces (Indent);
Write_Str (" ""record"": [");
- List_Structural_Record_Layout (Ent, Outer_Ent, Var, Indent + 4);
+ List_Structural_Record_Layout
+ (Ent, Ext_Ent, Ext_Level, Var, Indent + 4);
Write_Eol;
Spaces (Indent);
@@ -2026,7 +2063,7 @@ package body Repinfo is
if List_Representation_Info_To_JSON then
Write_Line (",");
Write_Str (" ""Small"": ");
- UR_Write (Small_Value (Ent));
+ UR_Write_To_JSON (Small_Value (Ent));
else
Write_Str ("for ");
List_Name (Ent);
@@ -2048,9 +2085,9 @@ package body Repinfo is
if List_Representation_Info_To_JSON then
Write_Line (",");
Write_Str (" ""Range"": [ ");
- UR_Write (Realval (Low_Bound (R)));
+ UR_Write_To_JSON (Realval (Low_Bound (R)));
Write_Str (", ");
- UR_Write (Realval (High_Bound (R)));
+ UR_Write_To_JSON (Realval (High_Bound (R)));
Write_Str (" ]");
else
Write_Str ("for ");
diff --git a/gcc/ada/repinfo.ads b/gcc/ada/repinfo.ads
index a2ab832..606bba4 100644
--- a/gcc/ada/repinfo.ads
+++ b/gcc/ada/repinfo.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1999-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1999-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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,7 @@ package Repinfo is
-- "name" : string
-- "location" : string
-- "record" : array of components
- -- "variant" : array of variants
+ -- "[parent_]*variant" : array of variants
-- "formal" : array of formal parameters
-- "mechanism" : string
-- "Size" : numerical expression
@@ -209,8 +209,9 @@ package Repinfo is
-- fully qualified Ada name. The value of "location" is the expanded
-- chain of instantiation locations that contains the entity.
-- "record" is present for every record type and its value is the list of
- -- components. "variant" is present only if the record type has a variant
- -- part and its value is the list of variants.
+ -- components. "[parent_]*variant" is present only if the record type, or
+ -- one of its ancestors (parent, grand-parent, etc) if it's an extension,
+ -- has a variant part and its value is the list of variants.
-- "formal" is present for every subprogram and entry, and its value is
-- the list of formal parameters. "mechanism" is present for functions
-- only and its value is the return mechanim.
diff --git a/gcc/ada/repinfo.h b/gcc/ada/repinfo.h
index e6835c3..1b96ceb 100644
--- a/gcc/ada/repinfo.h
+++ b/gcc/ada/repinfo.h
@@ -6,7 +6,7 @@
* *
* C Header File *
* *
- * Copyright (C) 1999-2020, Free Software Foundation, Inc. *
+ * Copyright (C) 1999-2021, Free Software Foundation, Inc. *
* *
* GNAT is free software; you can redistribute 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 c63c881..d97a42e 100644
--- a/gcc/ada/restrict.adb
+++ b/gcc/ada/restrict.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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,20 +23,24 @@
-- --
------------------------------------------------------------------------------
-with Atree; use Atree;
-with Casing; use Casing;
-with Einfo; use Einfo;
-with Errout; use Errout;
-with Debug; use Debug;
-with Fname; use Fname;
-with Fname.UF; use Fname.UF;
-with Lib; use Lib;
-with Opt; use Opt;
-with Sinfo; use Sinfo;
-with Sinput; use Sinput;
-with Stand; use Stand;
-with Targparm; use Targparm;
-with Uname; use Uname;
+with Atree; use Atree;
+with Casing; use Casing;
+with Einfo; use Einfo;
+with Einfo.Entities; use Einfo.Entities;
+with Einfo.Utils; use Einfo.Utils;
+with Errout; use Errout;
+with Debug; use Debug;
+with Fname; use Fname;
+with Fname.UF; use Fname.UF;
+with Lib; use Lib;
+with Opt; use Opt;
+with Sinfo; use Sinfo;
+with Sinfo.Nodes; use Sinfo.Nodes;
+with Sinfo.Utils; use Sinfo.Utils;
+with Sinput; use Sinput;
+with Stand; use Stand;
+with Targparm; use Targparm;
+with Uname; use Uname;
package body Restrict is
@@ -62,7 +66,7 @@ package body Restrict is
No_Specification_Of_Aspects : array (Aspect_Id) of Source_Ptr :=
(others => No_Location);
- -- Entries in this array are set to point to a previously occuring pragma
+ -- Entries in this array are set to point to a previously occurring pragma
-- that activates a No_Specification_Of_Aspect check.
No_Specification_Of_Aspect_Warning : array (Aspect_Id) of Boolean :=
@@ -392,10 +396,9 @@ package body Restrict is
N : Node_Id;
V : Uint := Uint_Minus_1)
is
- Msg_Issued : Boolean;
- pragma Unreferenced (Msg_Issued);
+ Ignore_Msg_Issued : Boolean;
begin
- Check_Restriction (Msg_Issued, R, N, V);
+ Check_Restriction (Ignore_Msg_Issued, R, N, V);
end Check_Restriction;
procedure Check_Restriction
@@ -920,6 +923,21 @@ package body Restrict is
or else Targparm.Restrictions_On_Target.Set (No_Tasking);
end Global_No_Tasking;
+ ---------------------------------------------
+ -- No_Dynamic_Accessibility_Checks_Enabled --
+ ---------------------------------------------
+
+ function No_Dynamic_Accessibility_Checks_Enabled
+ (N : Node_Id) return Boolean
+ is
+ pragma Unreferenced (N);
+ -- N is currently unreferenced but present for debugging purposes and
+ -- potential future use.
+
+ begin
+ return Restrictions.Set (No_Dynamic_Accessibility_Checks);
+ end No_Dynamic_Accessibility_Checks_Enabled;
+
-------------------------------
-- No_Exception_Handlers_Set --
-------------------------------
diff --git a/gcc/ada/restrict.ads b/gcc/ada/restrict.ads
index 7a84d37..eec85c2 100644
--- a/gcc/ada/restrict.ads
+++ b/gcc/ada/restrict.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -114,6 +114,7 @@ package Restrict is
No_Default_Initialization => True,
No_Direct_Boolean_Operators => True,
No_Dispatching_Calls => True,
+ No_Dynamic_Accessibility_Checks => True,
No_Dynamic_Attachment => True,
No_Elaboration_Code => True,
No_Enumeration_Maps => True,
@@ -377,6 +378,15 @@ 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 No_Dynamic_Accessibility_Checks_Enabled
+ (N : Node_Id) return Boolean;
+ -- Test to see if the current restrictions settings specify that
+ -- No_Dynamic_Accessibility_Checks is activated.
+
+ -- N is currently unused, but is reserved for future use and debugging
+ -- purposes to provide more context on a node for which an accessibility
+ -- check is being performed or generated (e.g. is N in a predefined unit).
+
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
diff --git a/gcc/ada/rident.ads b/gcc/ada/rident.ads
index e9f538c..888a256 100644
--- a/gcc/ada/rident.ads
+++ b/gcc/ada/rident.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute 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 92f3e89..ac0efd0 100644
--- a/gcc/ada/rtfinal.c
+++ b/gcc/ada/rtfinal.c
@@ -6,7 +6,7 @@
* *
* C Implementation File *
* *
- * Copyright (C) 2014-2020, Free Software Foundation, Inc. *
+ * Copyright (C) 2014-2021, Free Software Foundation, Inc. *
* *
* GNAT is free software; you can redistribute 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 1bb3cb0..83a63c8 100644
--- a/gcc/ada/rtinit.c
+++ b/gcc/ada/rtinit.c
@@ -6,7 +6,7 @@
* *
* C Implementation File *
* *
- * Copyright (C) 2014-2020, Free Software Foundation, Inc. *
+ * Copyright (C) 2014-2021, Free Software Foundation, Inc. *
* *
* GNAT is 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,19 @@ static void skip_quoted_string (const WCHAR **current_in,
}
ci++;
}
+
+ /* Handle the case in which a nul character was found instead of a closing
+ double quote. In that case consider all the backslashes as literal
+ characters. */
+ if (*ci == '\0')
+ {
+ for (int i=0; i<qbs_count; i++)
+ {
+ *co='\\';
+ co++;
+ }
+ }
+
*current_in = ci;
*current_out = co;
}
@@ -205,7 +218,10 @@ static void skip_argument (const WCHAR **current_in,
bs_count = 0;
*co = *ci; co++;
}
- ci++;
+ if (*ci != '\0')
+ {
+ ci++;
+ }
}
for (int i=0; i<bs_count; i++)
diff --git a/gcc/ada/rtsfind.adb b/gcc/ada/rtsfind.adb
index 6a0631f..5a89076 100644
--- a/gcc/ada/rtsfind.adb
+++ b/gcc/ada/rtsfind.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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,35 +23,39 @@
-- --
------------------------------------------------------------------------------
-with Atree; use Atree;
-with Casing; use Casing;
-with Csets; use Csets;
-with Debug; use Debug;
-with Einfo; use Einfo;
-with Elists; use Elists;
-with Errout; use Errout;
+with Atree; use Atree;
+with Casing; use Casing;
+with Csets; use Csets;
+with Debug; use Debug;
+with Einfo; use Einfo;
+with Einfo.Entities; use Einfo.Entities;
+with Einfo.Utils; use Einfo.Utils;
+with Elists; use Elists;
+with Errout; use Errout;
with Exp_Dist;
-with Fname; use Fname;
-with Fname.UF; use Fname.UF;
-with Ghost; use Ghost;
-with Lib; use Lib;
-with Lib.Load; use Lib.Load;
-with Namet; use Namet;
-with Nlists; use Nlists;
-with Nmake; use Nmake;
-with Output; use Output;
-with Opt; use Opt;
-with Restrict; use Restrict;
-with Sem; use Sem;
-with Sem_Aux; use Sem_Aux;
-with Sem_Ch7; use Sem_Ch7;
-with Sem_Dist; use Sem_Dist;
-with Sem_Util; use Sem_Util;
-with Sinfo; use Sinfo;
-with Stand; use Stand;
-with Snames; use Snames;
-with Tbuild; use Tbuild;
-with Uname; use Uname;
+with Fname; use Fname;
+with Fname.UF; use Fname.UF;
+with Ghost; use Ghost;
+with Lib; use Lib;
+with Lib.Load; use Lib.Load;
+with Namet; use Namet;
+with Nlists; use Nlists;
+with Nmake; use Nmake;
+with Output; use Output;
+with Opt; use Opt;
+with Restrict; use Restrict;
+with Sem; use Sem;
+with Sem_Aux; use Sem_Aux;
+with Sem_Ch7; use Sem_Ch7;
+with Sem_Dist; use Sem_Dist;
+with Sem_Util; use Sem_Util;
+with Sinfo; use Sinfo;
+with Sinfo.Nodes; use Sinfo.Nodes;
+with Sinfo.Utils; use Sinfo.Utils;
+with Stand; use Stand;
+with Snames; use Snames;
+with Tbuild; use Tbuild;
+with Uname; use Uname;
package body Rtsfind is
@@ -570,10 +574,11 @@ package body Rtsfind is
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;
+ range Ada_Strings_Superbounded .. Ada_Strings_Text_Buffers_Unbounded;
- subtype Ada_Strings_Text_Output_Descendant is Ada_Strings_Descendant
- range Ada_Strings_Text_Output_Utils .. Ada_Strings_Text_Output_Buffers;
+ subtype Ada_Strings_Text_Buffers_Descendant is Ada_Strings_Descendant
+ range Ada_Strings_Text_Buffers_Unbounded ..
+ Ada_Strings_Text_Buffers_Unbounded;
subtype Ada_Text_IO_Descendant is Ada_Descendant
range Ada_Text_IO_Decimal_IO .. Ada_Text_IO_Modular_IO;
@@ -597,6 +602,10 @@ package body Rtsfind is
subtype System_Descendant is RTU_Id
range System_Address_Image .. System_Tasking_Stages;
+ subtype System_Atomic_Operations_Descendant is System_Descendant
+ range System_Atomic_Operations_Test_And_Set ..
+ System_Atomic_Operations_Test_And_Set;
+
subtype System_Dim_Descendant is System_Descendant
range System_Dim_Float_IO .. System_Dim_Integer_IO;
@@ -657,8 +666,8 @@ package body Rtsfind is
elsif U_Id in Ada_Strings_Descendant then
Name_Buffer (12) := '.';
- if U_Id in Ada_Strings_Text_Output_Descendant then
- Name_Buffer (24) := '.';
+ if U_Id in Ada_Strings_Text_Buffers_Descendant then
+ Name_Buffer (25) := '.';
end if;
elsif U_Id in Ada_Text_IO_Descendant then
@@ -684,6 +693,10 @@ package body Rtsfind is
elsif U_Id in System_Descendant then
Name_Buffer (7) := '.';
+ if U_Id in System_Atomic_Operations_Descendant then
+ Name_Buffer (25) := '.';
+ end if;
+
if U_Id in System_Dim_Descendant then
Name_Buffer (11) := '.';
end if;
@@ -1795,14 +1808,12 @@ package body Rtsfind is
-------------------------
procedure SPARK_Implicit_Load (E : RE_Id) is
- Unused : Entity_Id;
-
begin
pragma Assert (GNATprove_Mode);
-- Force loading of a predefined unit
- Unused := RTE (E);
+ Discard_Node (RTE (E));
end SPARK_Implicit_Load;
end Rtsfind;
diff --git a/gcc/ada/rtsfind.ads b/gcc/ada/rtsfind.ads
index a690bb4..99f870a 100644
--- a/gcc/ada/rtsfind.ads
+++ b/gcc/ada/rtsfind.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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 @@
-- not been explicitly With'ed.
with Types; use Types;
+with Uintp; use Uintp;
package Rtsfind is
@@ -125,12 +126,11 @@ package Rtsfind is
Ada_Strings_Wide_Superbounded,
Ada_Strings_Wide_Wide_Superbounded,
Ada_Strings_Unbounded,
- Ada_Strings_Text_Output,
+ Ada_Strings_Text_Buffers,
- -- Children of Ada.Strings.Text_Output
+ -- Children of Ada.Strings.Text_Buffers
- Ada_Strings_Text_Output_Utils,
- Ada_Strings_Text_Output_Buffers,
+ Ada_Strings_Text_Buffers_Unbounded,
-- Children of Ada.Text_IO (for Check_Text_IO_Special_Unit)
@@ -195,6 +195,7 @@ package Rtsfind is
System_Arith_128,
System_AST_Handling,
System_Assertions,
+ System_Atomic_Operations,
System_Atomic_Primitives,
System_Aux_DEC,
System_Bignums,
@@ -228,6 +229,8 @@ package Rtsfind is
System_Exception_Table,
System_Exceptions_Debug,
System_Exn_Int,
+ System_Exn_Flt,
+ System_Exn_LFlt,
System_Exn_LLF,
System_Exn_LLI,
System_Exn_LLLI,
@@ -259,18 +262,21 @@ package Rtsfind is
System_Img_Decimal_32,
System_Img_Decimal_64,
System_Img_Decimal_128,
- System_Img_Enum,
- System_Img_Enum_New,
+ System_Img_Enum_8,
+ System_Img_Enum_16,
+ System_Img_Enum_32,
System_Img_Fixed_32,
System_Img_Fixed_64,
System_Img_Fixed_128,
+ System_Img_Flt,
System_Img_Int,
+ System_Img_LFlt,
+ System_Img_LLF,
System_Img_LLI,
System_Img_LLLI,
System_Img_LLU,
System_Img_LLLU,
System_Img_Name,
- System_Img_Real,
System_Img_Uns,
System_Img_WChar,
System_Interrupts,
@@ -428,7 +434,9 @@ package Rtsfind is
System_Val_Decimal_32,
System_Val_Decimal_64,
System_Val_Decimal_128,
- System_Val_Enum,
+ System_Val_Enum_8,
+ System_Val_Enum_16,
+ System_Val_Enum_32,
System_Val_Fixed_32,
System_Val_Fixed_64,
System_Val_Fixed_128,
@@ -461,6 +469,10 @@ package Rtsfind is
System_WWd_Enum,
System_WWd_Wchar,
+ -- Children of System.Atomic_Operations
+
+ System_Atomic_Operations_Test_And_Set,
+
-- Children of System.Dim
System_Dim_Float_IO,
@@ -596,15 +608,14 @@ 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_Root_Buffer_Type, -- Ada.Strings.Text_Buffers
+ RE_Put_UTF_8, -- Ada.Strings.Text_Buffers
+ RE_Wide_Wide_Put, -- Ada.Strings.Text_Buffers
- 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_Buffer_Type, -- Ada.Strings.Text_Buffers.Unbounded
+ RE_Get, -- Ada.Strings.Text_Buffers.Unbounded
+ RE_Wide_Get, -- Ada.Strings.Text_Buffers.Unbounded
+ RE_Wide_Wide_Get, -- Ada.Strings.Text_Buffers.Unbounded
RE_Wait_For_Release, -- Ada.Synchronous_Barriers
@@ -702,6 +713,7 @@ package Rtsfind is
RE_TK_Tagged, -- Ada.Tags
RE_TK_Task, -- Ada.Tags
RE_Unregister_Tag, -- Ada.Tags
+ RE_Wide_Wide_Expanded_Name, -- Ada.Tags
RE_Set_Specific_Handler, -- Ada.Task_Termination
RE_Specific_Handler, -- Ada.Task_Termination
@@ -793,6 +805,9 @@ package Rtsfind is
RE_Uint32, -- System.Atomic_Primitives
RE_Uint64, -- System.Atomic_Primitives
+ RE_Test_And_Set_Flag, -- System.Atomic_Operations.Test_And_Set
+ RE_Atomic_Test_And_Set, -- System.Atomic_Operations.Test_And_Set
+
RE_AST_Handler, -- System.Aux_DEC
RE_Import_Address, -- System.Aux_DEC
RE_Import_Value, -- System.Aux_DEC
@@ -830,7 +845,9 @@ package Rtsfind is
RE_To_Bignum, -- System.Bignums
RE_From_Bignum, -- System.Bignums
+ RE_Val_2, -- System.Bitfields
RE_Copy_Bitfield, -- System.Bitfields
+ RE_Fast_Copy_Bitfield, -- System.Bitfields
RE_Bit_And, -- System.Bit_Ops
RE_Bit_Eq, -- System.Bit_Ops
@@ -901,8 +918,10 @@ package Rtsfind is
RE_Exn_Integer, -- System.Exn_Int
- RE_Exn_Float, -- System.Exn_LLF
- RE_Exn_Long_Float, -- System.Exn_LLF
+ RE_Exn_Float, -- System.Exn_Flt
+
+ RE_Exn_Long_Float, -- System.Exn_LFlt
+
RE_Exn_Long_Long_Float, -- System.Exn_LLF
RE_Exn_Long_Long_Integer, -- System.Exn_LLI
@@ -956,14 +975,14 @@ package Rtsfind is
RE_Fore_Decimal128, -- System.Fore_Decimal_128
+ RE_Fore_Fixed, -- System.Fore_Real
+
RE_Fore_Fixed32, -- System.Fore_Fixed_32
RE_Fore_Fixed64, -- System.Fore_Fixed_64
RE_Fore_Fixed128, -- System.Fore_Fixed_128
- RE_Fore_Real, -- System.Fore_Real
-
RE_Image_Boolean, -- System.Img_Bool
RE_Image_Character, -- System.Img_Char
@@ -979,8 +998,14 @@ package Rtsfind is
RE_Image_Enumeration_16, -- System.Img_Enum_New
RE_Image_Enumeration_32, -- System.Img_Enum_New
+ RE_Image_Float, -- System_Img_Flt
+
RE_Image_Integer, -- System.Img_Int
+ RE_Image_Long_Float, -- System_Img_LFlt
+
+ RE_Image_Long_Long_Float, -- System_Img_LLF
+
RE_Image_Long_Long_Integer, -- System.Img_LLI
RE_Image_Long_Long_Long_Integer, -- System.Img_LLLI
@@ -989,12 +1014,13 @@ package Rtsfind is
RE_Image_Long_Long_Long_Unsigned, -- System.Img_LLLU
+ RE_Image_Fixed, -- System.Img_LFlt
+
RE_Image_Fixed32, -- System.Img_Fixed_32
+
RE_Image_Fixed64, -- System.Img_Fixed_64
- RE_Image_Fixed128, -- System.Img_Fixed_128
- RE_Image_Ordinary_Fixed_Point, -- System.Img_Real
- RE_Image_Floating_Point, -- System.Img_Real
+ RE_Image_Fixed128, -- System.Img_Fixed_128
RE_Image_Unsigned, -- System.Img_Uns
@@ -1959,11 +1985,6 @@ package Rtsfind is
RE_Conditional_Call, -- System.Tasking
RE_Asynchronous_Call, -- System.Tasking
- RE_Foreign_Task_Level, -- System.Tasking
- RE_Environment_Task_Level, -- System.Tasking
- RE_Independent_Task_Level, -- System.Tasking
- RE_Library_Task_Level, -- System.Tasking
-
RE_Ada_Task_Control_Block, -- System.Tasking
RE_Task_List, -- System.Tasking
@@ -1980,7 +2001,6 @@ package Rtsfind is
RE_Task_Entry_Index, -- System.Tasking
RE_Self, -- System.Tasking
- RE_Master_Id, -- System.Tasking
RE_Unspecified_Priority, -- System.Tasking
RE_Activation_Chain, -- System.Tasking
@@ -2004,7 +2024,6 @@ package Rtsfind is
RE_Bits_1, -- System.Unsigned_Types
RE_Bits_2, -- System.Unsigned_Types
RE_Bits_4, -- System.Unsigned_Types
- RE_Float_Unsigned, -- System.Unsigned_Types
RE_Long_Long_Unsigned, -- System.Unsigned_Types
RE_Long_Long_Long_Unsigned, -- System.Unsigned_Types
RE_Packed_Byte, -- System.Unsigned_Types
@@ -2026,9 +2045,13 @@ package Rtsfind is
RE_Value_Decimal128, -- System_Val_Decimal_128
- RE_Value_Enumeration_8, -- System.Val_Enum
- RE_Value_Enumeration_16, -- System.Val_Enum
- RE_Value_Enumeration_32, -- System.Val_Enum
+ RE_Value_Enumeration_8, -- System.Val_Enum_8
+ RE_Value_Enumeration_16, -- System.Val_Enum_16
+ RE_Value_Enumeration_32, -- System.Val_Enum_32
+
+ RE_Valid_Value_Enumeration_8, -- System.Val_Enum_8
+ RE_Valid_Value_Enumeration_16, -- System.Val_Enum_16
+ RE_Valid_Value_Enumeration_32, -- System.Val_Enum_32
RE_Value_Fixed32, -- System_Val_Fixed_32
@@ -2270,15 +2293,14 @@ 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_Root_Buffer_Type => Ada_Strings_Text_Buffers,
+ RE_Put_UTF_8 => Ada_Strings_Text_Buffers,
+ RE_Wide_Wide_Put => Ada_Strings_Text_Buffers,
- 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_Buffer_Type => Ada_Strings_Text_Buffers_Unbounded,
+ RE_Get => Ada_Strings_Text_Buffers_Unbounded,
+ RE_Wide_Get => Ada_Strings_Text_Buffers_Unbounded,
+ RE_Wide_Wide_Get => Ada_Strings_Text_Buffers_Unbounded,
RE_Wait_For_Release => Ada_Synchronous_Barriers,
@@ -2376,6 +2398,7 @@ package Rtsfind is
RE_TK_Tagged => Ada_Tags,
RE_TK_Task => Ada_Tags,
RE_Unregister_Tag => Ada_Tags,
+ RE_Wide_Wide_Expanded_Name => Ada_Tags,
RE_Set_Specific_Handler => Ada_Task_Termination,
RE_Specific_Handler => Ada_Task_Termination,
@@ -2467,6 +2490,9 @@ package Rtsfind is
RE_Uint32 => System_Atomic_Primitives,
RE_Uint64 => System_Atomic_Primitives,
+ RE_Test_And_Set_Flag => System_Atomic_Operations_Test_And_Set,
+ RE_Atomic_Test_And_Set => System_Atomic_Operations_Test_And_Set,
+
RE_AST_Handler => System_Aux_DEC,
RE_Import_Address => System_Aux_DEC,
RE_Import_Value => System_Aux_DEC,
@@ -2504,7 +2530,9 @@ package Rtsfind is
RE_To_Bignum => System_Bignums,
RE_From_Bignum => System_Bignums,
+ RE_Val_2 => System_Bitfields,
RE_Copy_Bitfield => System_Bitfields,
+ RE_Fast_Copy_Bitfield => System_Bitfields,
RE_Bit_And => System_Bit_Ops,
RE_Bit_Eq => System_Bit_Ops,
@@ -2581,8 +2609,10 @@ package Rtsfind is
RE_Exn_Integer => System_Exn_Int,
- RE_Exn_Float => System_Exn_LLF,
- RE_Exn_Long_Float => System_Exn_LLF,
+ RE_Exn_Float => System_Exn_Flt,
+
+ RE_Exn_Long_Float => System_Exn_LFlt,
+
RE_Exn_Long_Long_Float => System_Exn_LLF,
RE_Exn_Long_Long_Integer => System_Exn_LLI,
@@ -2636,14 +2666,14 @@ package Rtsfind is
RE_Fore_Decimal128 => System_Fore_Decimal_128,
+ RE_Fore_Fixed => System_Fore_Real,
+
RE_Fore_Fixed32 => System_Fore_Fixed_32,
RE_Fore_Fixed64 => System_Fore_Fixed_64,
RE_Fore_Fixed128 => System_Fore_Fixed_128,
- RE_Fore_Real => System_Fore_Real,
-
RE_Image_Boolean => System_Img_Bool,
RE_Image_Character => System_Img_Char,
@@ -2655,12 +2685,20 @@ package Rtsfind is
RE_Image_Decimal128 => System_Img_Decimal_128,
- RE_Image_Enumeration_8 => System_Img_Enum_New,
- RE_Image_Enumeration_16 => System_Img_Enum_New,
- RE_Image_Enumeration_32 => System_Img_Enum_New,
+ RE_Image_Enumeration_8 => System_Img_Enum_8,
+
+ RE_Image_Enumeration_16 => System_Img_Enum_16,
+
+ RE_Image_Enumeration_32 => System_Img_Enum_32,
+
+ RE_Image_Float => System_Img_Flt,
RE_Image_Integer => System_Img_Int,
+ RE_Image_Long_Float => System_Img_LFlt,
+
+ RE_Image_Long_Long_Float => System_Img_LLF,
+
RE_Image_Long_Long_Integer => System_Img_LLI,
RE_Image_Long_Long_Long_Integer => System_Img_LLLI,
@@ -2669,12 +2707,13 @@ package Rtsfind is
RE_Image_Long_Long_Long_Unsigned => System_Img_LLLU,
+ RE_Image_Fixed => System_Img_LFlt,
+
RE_Image_Fixed32 => System_Img_Fixed_32,
+
RE_Image_Fixed64 => System_Img_Fixed_64,
- RE_Image_Fixed128 => System_Img_Fixed_128,
- RE_Image_Ordinary_Fixed_Point => System_Img_Real,
- RE_Image_Floating_Point => System_Img_Real,
+ RE_Image_Fixed128 => System_Img_Fixed_128,
RE_Image_Unsigned => System_Img_Uns,
@@ -3639,11 +3678,6 @@ package Rtsfind is
RE_Conditional_Call => System_Tasking,
RE_Asynchronous_Call => System_Tasking,
- RE_Foreign_Task_Level => System_Tasking,
- RE_Environment_Task_Level => System_Tasking,
- RE_Independent_Task_Level => System_Tasking,
- RE_Library_Task_Level => System_Tasking,
-
RE_Ada_Task_Control_Block => System_Tasking,
RE_Task_List => System_Tasking,
@@ -3660,7 +3694,6 @@ package Rtsfind is
RE_Task_Entry_Index => System_Tasking,
RE_Self => System_Tasking,
- RE_Master_Id => System_Tasking,
RE_Unspecified_Priority => System_Tasking,
RE_Activation_Chain => System_Tasking,
@@ -3684,7 +3717,6 @@ package Rtsfind is
RE_Bits_1 => System_Unsigned_Types,
RE_Bits_2 => System_Unsigned_Types,
RE_Bits_4 => System_Unsigned_Types,
- RE_Float_Unsigned => System_Unsigned_Types,
RE_Long_Long_Unsigned => System_Unsigned_Types,
RE_Long_Long_Long_Unsigned => System_Unsigned_Types,
RE_Packed_Byte => System_Unsigned_Types,
@@ -3706,9 +3738,17 @@ package Rtsfind is
RE_Value_Decimal128 => System_Val_Decimal_128,
- RE_Value_Enumeration_8 => System_Val_Enum,
- RE_Value_Enumeration_16 => System_Val_Enum,
- RE_Value_Enumeration_32 => System_Val_Enum,
+ RE_Value_Enumeration_8 => System_Val_Enum_8,
+
+ RE_Value_Enumeration_16 => System_Val_Enum_16,
+
+ RE_Value_Enumeration_32 => System_Val_Enum_32,
+
+ RE_Valid_Value_Enumeration_8 => System_Val_Enum_8,
+
+ RE_Valid_Value_Enumeration_16 => System_Val_Enum_16,
+
+ RE_Valid_Value_Enumeration_32 => System_Val_Enum_32,
RE_Value_Fixed32 => System_Val_Fixed_32,
@@ -3967,6 +4007,9 @@ package Rtsfind is
System_Unsigned_Types => True,
others => False);
+ Library_Task_Level : constant Uint := Uint_3;
+ -- Corresponds to System.Tasking.Library_Task_Level
+
-----------------
-- Subprograms --
-----------------
@@ -4055,10 +4098,11 @@ package Rtsfind is
-- and without generating an error message, i.e. if the call will obtain
-- the desired entity without any problems.
--
- -- If we call this and it returns True, we should generate a call to E.
- -- In other words, the compiler should not call RTE_Available (E) until
- -- it has decided it wants to generate a call to E. Otherwise we can get
- -- spurious dependencies and elaboration orders.
+ -- If we call this and it returns True, we should generate a reference to
+ -- E (usually a call). In other words, for a subprogram E, the compiler
+ -- should not call RTE_Available (E) until it has decided it wants to
+ -- generate a call to E. Otherwise we can get spurious dependencies and
+ -- elaboration orders.
--
-- if RTE_Available (E) -- WRONG!
-- and then <some condition>
diff --git a/gcc/ada/runtime.h b/gcc/ada/runtime.h
index fa0c810..7721947 100644
--- a/gcc/ada/runtime.h
+++ b/gcc/ada/runtime.h
@@ -6,7 +6,7 @@
* *
* C Header File *
* *
- * Copyright (C) 2019-2020, Free Software Foundation, Inc. *
+ * Copyright (C) 2019-2021, Free Software Foundation, Inc. *
* *
* GNAT is 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,9 +31,11 @@
/* This file provides common definitions used by GNAT C runtime files. */
+/* The following include is here to meet the published VxWorks requirement
+ that the vxWorks.h header appear before any other header. */
#ifdef __vxworks
#include "vxWorks.h"
-#endif /* __vxworks */
+#endif
#ifndef ATTRIBUTE_UNUSED
#define ATTRIBUTE_UNUSED __attribute__((unused))
diff --git a/gcc/ada/s-oscons-tmplt.c b/gcc/ada/s-oscons-tmplt.c
index 582c35e..54fa2f1 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-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2000-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -1463,14 +1463,8 @@ CND(MSG_PEEK, "Peek at incoming data")
CND(MSG_EOR, "Send end of record")
#ifndef MSG_WAITALL
-#ifdef __MINWGW32__
-/* The value of MSG_WAITALL is 8. Nevertheless winsock.h doesn't
- define it, but it is still usable as we link to winsock2 API. */
-# define MSG_WAITALL (1 << 3)
-#else
# define MSG_WAITALL -1
#endif
-#endif
CND(MSG_WAITALL, "Wait for full reception")
#ifndef MSG_NOSIGNAL
@@ -1501,6 +1495,39 @@ CNS(MSG_Forced_Flags, "")
#endif
CND(TCP_NODELAY, "Do not coalesce packets")
+#ifndef TCP_KEEPCNT
+#ifdef __MINGW32__
+/* Windows headers can be too old to have all available constants.
+ * We know this one. */
+# define TCP_KEEPCNT 16
+#else
+# define TCP_KEEPCNT -1
+#endif
+#endif
+CND(TCP_KEEPCNT, "Maximum number of keepalive probes")
+
+#ifndef TCP_KEEPIDLE
+#ifdef __MINGW32__
+/* Windows headers can be too old to have all available constants.
+ * We know this one. */
+# define TCP_KEEPIDLE 3
+#else
+# define TCP_KEEPIDLE -1
+#endif
+#endif
+CND(TCP_KEEPIDLE, "Idle time before TCP starts sending keepalive probes")
+
+#ifndef TCP_KEEPINTVL
+#ifdef __MINGW32__
+/* Windows headers can be too old to have all available constants.
+ * We know this one. */
+# define TCP_KEEPINTVL 17
+#else
+# define TCP_KEEPINTVL -1
+#endif
+#endif
+CND(TCP_KEEPINTVL, "Time between individual keepalive probes")
+
#ifndef SO_REUSEADDR
# define SO_REUSEADDR -1
#endif
@@ -1662,8 +1689,14 @@ CND(IPV6_DSTOPTS, "Set the destination options delivery")
CND(IPV6_HOPOPTS, "Set the hop options delivery")
#ifndef IPV6_FLOWINFO
+#ifdef __linux__
+/* The IPV6_FLOWINFO is defined in linux/in6.h, but we can't include it because
+ * of conflicts with other headers. */
+# define IPV6_FLOWINFO 11
+#else
# define IPV6_FLOWINFO -1
#endif
+#endif
CND(IPV6_FLOWINFO, "Set the flow ID delivery")
#ifndef IPV6_HOPLIMIT
diff --git a/gcc/ada/sa_messages.adb b/gcc/ada/sa_messages.adb
index fefc4f0..41c0db1 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-2020, AdaCore --
+-- Copyright (C) 2015-2021, 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 1f6fca8..4f4ed8a 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-2020, AdaCore --
+-- Copyright (C) 2015-2021, 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- --
@@ -96,7 +96,7 @@ package SA_Messages is
-- Contract_Cases, Default_Initial_Condition, Initial_Condition,
-- Loop_Invariant, Loop_Variant, Refined_Post, and Subprogram_Variant.
--
- -- TBD: it might be nice to distinguish these different kinds of assertions
+ -- It might be nice to distinguish these different kinds of assertions
-- as is done in SPARK's VC_Kind enumeration type, but any distinction
-- which isn't already present in CP's BE_Message_Subkind enumeration type
-- would require more work on the CP side.
diff --git a/gcc/ada/scans.adb b/gcc/ada/scans.adb
index 9ea407e..268d2bd 100644
--- a/gcc/ada/scans.adb
+++ b/gcc/ada/scans.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute 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 6db276b..5cbae5a 100644
--- a/gcc/ada/scans.ads
+++ b/gcc/ada/scans.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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 Scans is
-- exception-name". This degrades error recovery slightly, and perhaps
-- we could do better, but not worth the effort.
- -- Ada 2020 introduces square brackets as delimiters for array and
+ -- Ada 2022 introduces square brackets as delimiters for array and
-- container aggregates.
Tok_Raise, -- RAISE
@@ -441,12 +441,12 @@ package Scans is
-- scanned literal.
Real_Literal_Value : Ureal;
- -- Valid only when Token is Tok_Real_Literal, contains the value of the
+ -- Valid only when Token is Tok_Real_Literal. Contains the value of the
-- scanned literal.
Int_Literal_Value : Uint;
- -- Valid only when Token = Tok_Integer_Literal, contains the value of the
- -- scanned literal.
+ -- Valid only when Token = Tok_Integer_Literal, and we are not in
+ -- syntax-only mode. Contains the value of the scanned literal.
Based_Literal_Uses_Colon : Boolean;
-- Valid only when Token = Tok_Integer_Literal or Tok_Real_Literal. Set
diff --git a/gcc/ada/scil_ll.adb b/gcc/ada/scil_ll.adb
index 53c9013..487dd36 100644
--- a/gcc/ada/scil_ll.adb
+++ b/gcc/ada/scil_ll.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2010-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2010-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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,11 @@
-- --
------------------------------------------------------------------------------
-with Atree; use Atree;
-with Opt; use Opt;
-with Sinfo; use Sinfo;
-with System.HTable; use System.HTable;
+with Atree; use Atree;
+with Opt; use Opt;
+with Sinfo; use Sinfo;
+with Sinfo.Nodes; use Sinfo.Nodes;
+with System.HTable; use System.HTable;
package body SCIL_LL is
diff --git a/gcc/ada/scil_ll.ads b/gcc/ada/scil_ll.ads
index 5770b37..ee1e1ff 100644
--- a/gcc/ada/scil_ll.ads
+++ b/gcc/ada/scil_ll.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2010-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2010-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute 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 408e31f..ad53279 100644
--- a/gcc/ada/scn.adb
+++ b/gcc/ada/scn.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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,16 +23,17 @@
-- --
------------------------------------------------------------------------------
-with Atree; use Atree;
-with Csets; use Csets;
-with Namet; use Namet;
-with Opt; use Opt;
-with Restrict; use Restrict;
-with Rident; use Rident;
-with Scans; use Scans;
-with Sinfo; use Sinfo;
-with Sinput; use Sinput;
-with Uintp; use Uintp;
+with Atree; use Atree;
+with Csets; use Csets;
+with Namet; use Namet;
+with Opt; use Opt;
+with Restrict; use Restrict;
+with Rident; use Rident;
+with Scans; use Scans;
+with Sinfo; use Sinfo;
+with Sinfo.Nodes; use Sinfo.Nodes;
+with Sinput; use Sinput;
+with Uintp; use Uintp;
package body Scn is
@@ -154,7 +155,14 @@ package body Scn is
when Tok_Integer_Literal =>
Token_Node := New_Node (N_Integer_Literal, Token_Ptr);
- Set_Intval (Token_Node, Int_Literal_Value);
+
+ -- Int_Literal_Value can be No_Uint in some cases in syntax-only
+ -- mode (see Scng.Scan.Nlit).
+
+ if Int_Literal_Value /= No_Uint then
+ Set_Intval (Token_Node, Int_Literal_Value);
+ end if;
+
Check_Obsolete_Base_Char;
when Tok_String_Literal =>
diff --git a/gcc/ada/scn.ads b/gcc/ada/scn.ads
index 5e20019..2bf3feb 100644
--- a/gcc/ada/scn.ads
+++ b/gcc/ada/scn.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute 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 df6a689..bf1307c 100644
--- a/gcc/ada/scng.adb
+++ b/gcc/ada/scng.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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,16 +230,16 @@ package body Scng is
-- Initialize scan control variables
- Current_Source_File := Index;
- Source := Source_Text (Current_Source_File);
- Scan_Ptr := Source_First (Current_Source_File);
- Token := No_Token;
- Token_Ptr := Scan_Ptr;
- Current_Line_Start := Scan_Ptr;
- Token_Node := Empty;
- Token_Name := No_Name;
- Start_Column := Set_Start_Column;
- First_Non_Blank_Location := Scan_Ptr;
+ Current_Source_File := Index;
+ Source := Source_Text (Current_Source_File);
+ Scan_Ptr := Source_First (Current_Source_File);
+ Token := No_Token;
+ Token_Ptr := Scan_Ptr;
+ Current_Line_Start := Scan_Ptr;
+ Token_Node := Empty;
+ Token_Name := No_Name;
+ Start_Column := Set_Start_Column;
+ First_Non_Blank_Location := Scan_Ptr;
Initialize_Checksum;
Wide_Char_Byte_Count := 0;
@@ -1303,7 +1303,7 @@ package body Scng is
-- AI12-0125-03 : @ is target_name
when '@' =>
- Error_Msg_Ada_2020_Feature ("target name", Token_Ptr);
+ Error_Msg_Ada_2022_Feature ("target name", Token_Ptr);
Accumulate_Checksum ('@');
Scan_Ptr := Scan_Ptr + 1;
@@ -1707,7 +1707,7 @@ package body Scng is
-- "abs"'Address. Other literals are included to give better error
-- behavior for illegal cases like 123'Img.
--
- -- In Ada 2020, a target name (i.e. @) is a valid prefix of an
+ -- In Ada 2022, a target name (i.e. @) is a valid prefix of an
-- attribute, and functions like a name.
if Prev_Token = Tok_All
@@ -1827,10 +1827,10 @@ package body Scng is
return;
-- Right bracket or right brace, treated as right paren but proper
- -- aggregate delimiter in Ada 2020.
+ -- aggregate delimiter in Ada 2022.
when ']' | '}' =>
- if Ada_Version >= Ada_2020 then
+ if Ada_Version >= Ada_2022 then
Token := Tok_Right_Bracket;
else
diff --git a/gcc/ada/scng.ads b/gcc/ada/scng.ads
index d907d75..56e24879 100644
--- a/gcc/ada/scng.ads
+++ b/gcc/ada/scng.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute 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 c529fd6..5bebe4f 100644
--- a/gcc/ada/scos.adb
+++ b/gcc/ada/scos.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2009-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2009-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute 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 e23f3b5..d8e88dd 100644
--- a/gcc/ada/scos.ads
+++ b/gcc/ada/scos.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2009-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2009-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute 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.h b/gcc/ada/scos.h
index 2235ef7..2d46c6e 100644
--- a/gcc/ada/scos.h
+++ b/gcc/ada/scos.h
@@ -6,7 +6,7 @@
* *
* C Header File *
* *
- * Copyright (C) 2014-2020, Free Software Foundation, Inc. *
+ * Copyright (C) 2014-2021, Free Software Foundation, Inc. *
* *
* GNAT is free software; you can redistribute 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 80a2bae..b909ef1 100644
--- a/gcc/ada/sdefault.ads
+++ b/gcc/ada/sdefault.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute 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 27e6379..6d169a9 100644
--- a/gcc/ada/seh_init.c
+++ b/gcc/ada/seh_init.c
@@ -6,7 +6,7 @@
* *
* C Implementation File *
* *
- * Copyright (C) 2005-2020, Free Software Foundation, Inc. *
+ * Copyright (C) 2005-2021, Free Software Foundation, Inc. *
* *
* GNAT is 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,8 +64,8 @@ extern struct Exception_Data storage_error;
extern struct Exception_Data tasking_error;
extern struct Exception_Data _abort_signal;
-#define Raise_From_Signal_Handler ada__exceptions__raise_from_signal_handler
-extern void Raise_From_Signal_Handler (struct Exception_Data *, const char *)
+#define Raise_From_Signal_Handler __gnat_raise_from_signal_handler
+extern void Raise_From_Signal_Handler (struct Exception_Data *, const void *)
ATTRIBUTE_NORETURN;
diff --git a/gcc/ada/sem.adb b/gcc/ada/sem.adb
index 7a67a43..783c94aa 100644
--- a/gcc/ada/sem.adb
+++ b/gcc/ada/sem.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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,38 +23,43 @@
-- --
------------------------------------------------------------------------------
-with Atree; use Atree;
-with Debug; use Debug;
-with Debug_A; use Debug_A;
-with Elists; use Elists;
-with Exp_SPARK; use Exp_SPARK;
-with Expander; use Expander;
-with Ghost; use Ghost;
-with Lib; use Lib;
-with Lib.Load; use Lib.Load;
-with Nlists; use Nlists;
-with Output; use Output;
-with Restrict; use Restrict;
-with Sem_Attr; use Sem_Attr;
-with Sem_Ch2; use Sem_Ch2;
-with Sem_Ch3; use Sem_Ch3;
-with Sem_Ch4; use Sem_Ch4;
-with Sem_Ch5; use Sem_Ch5;
-with Sem_Ch6; use Sem_Ch6;
-with Sem_Ch7; use Sem_Ch7;
-with Sem_Ch8; use Sem_Ch8;
-with Sem_Ch9; use Sem_Ch9;
-with Sem_Ch10; use Sem_Ch10;
-with Sem_Ch11; use Sem_Ch11;
-with Sem_Ch12; use Sem_Ch12;
-with Sem_Ch13; use Sem_Ch13;
-with Sem_Prag; use Sem_Prag;
-with Sem_Util; use Sem_Util;
-with Sinfo; use Sinfo;
-with Stand; use Stand;
-with Stylesw; use Stylesw;
-with Uintp; use Uintp;
-with Uname; use Uname;
+with Atree; use Atree;
+with Debug; use Debug;
+with Debug_A; use Debug_A;
+with Einfo; use Einfo;
+with Einfo.Entities; use Einfo.Entities;
+with Einfo.Utils; use Einfo.Utils;
+with Elists; use Elists;
+with Exp_SPARK; use Exp_SPARK;
+with Expander; use Expander;
+with Ghost; use Ghost;
+with Lib; use Lib;
+with Lib.Load; use Lib.Load;
+with Nlists; use Nlists;
+with Output; use Output;
+with Restrict; use Restrict;
+with Sem_Attr; use Sem_Attr;
+with Sem_Ch2; use Sem_Ch2;
+with Sem_Ch3; use Sem_Ch3;
+with Sem_Ch4; use Sem_Ch4;
+with Sem_Ch5; use Sem_Ch5;
+with Sem_Ch6; use Sem_Ch6;
+with Sem_Ch7; use Sem_Ch7;
+with Sem_Ch8; use Sem_Ch8;
+with Sem_Ch9; use Sem_Ch9;
+with Sem_Ch10; use Sem_Ch10;
+with Sem_Ch11; use Sem_Ch11;
+with Sem_Ch12; use Sem_Ch12;
+with Sem_Ch13; use Sem_Ch13;
+with Sem_Prag; use Sem_Prag;
+with Sem_Util; use Sem_Util;
+with Sinfo; use Sinfo;
+with Sinfo.Nodes; use Sinfo.Nodes;
+with Sinfo.Utils; use Sinfo.Utils;
+with Stand; use Stand;
+with Stylesw; use Stylesw;
+with Uintp; use Uintp;
+with Uname; use Uname;
with Unchecked_Deallocation;
@@ -293,6 +298,9 @@ package body Sem is
when N_Goto_Statement =>
Analyze_Goto_Statement (N);
+ when N_Goto_When_Statement =>
+ Analyze_Goto_When_Statement (N);
+
when N_Handled_Sequence_Of_Statements =>
Analyze_Handled_Statements (N);
@@ -500,6 +508,9 @@ package body Sem is
when N_Raise_Statement =>
Analyze_Raise_Statement (N);
+ when N_Raise_When_Statement =>
+ Analyze_Raise_When_Statement (N);
+
when N_Raise_xxx_Error =>
Analyze_Raise_xxx_Error (N);
@@ -521,6 +532,9 @@ package body Sem is
when N_Requeue_Statement =>
Analyze_Requeue (N);
+ when N_Return_When_Statement =>
+ Analyze_Return_When_Statement (N);
+
when N_Simple_Return_Statement =>
Analyze_Simple_Return_Statement (N);
diff --git a/gcc/ada/sem.ads b/gcc/ada/sem.ads
index 6003997..2fdccf7 100644
--- a/gcc/ada/sem.ads
+++ b/gcc/ada/sem.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -202,7 +202,6 @@
-- called Preanalyze_And_Resolve and is in Sem_Res.
with Alloc;
-with Einfo; use Einfo;
with Opt; use Opt;
with Table;
with Types; use Types;
@@ -534,7 +533,7 @@ package Sem is
-- See Sem_Ch10 (Install_Parents, Remove_Parents).
Node_To_Be_Wrapped : Node_Id;
- -- Only used in transient scopes. Records the node which will be wrapped
+ -- Only used in transient scopes. Records the node that will be wrapped
-- by the transient block.
Actions_To_Be_Wrapped : Scope_Actions;
diff --git a/gcc/ada/sem_aggr.adb b/gcc/ada/sem_aggr.adb
index b94f369..9ad9629 100644
--- a/gcc/ada/sem_aggr.adb
+++ b/gcc/ada/sem_aggr.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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,49 +23,54 @@
-- --
------------------------------------------------------------------------------
-with Aspects; use Aspects;
-with Atree; use Atree;
-with Checks; use Checks;
-with Einfo; use Einfo;
-with Elists; use Elists;
-with Errout; use Errout;
-with Expander; use Expander;
-with Exp_Ch6; use Exp_Ch6;
-with Exp_Tss; use Exp_Tss;
-with Exp_Util; use Exp_Util;
-with Freeze; use Freeze;
-with Itypes; use Itypes;
-with Lib; use Lib;
-with Lib.Xref; use Lib.Xref;
-with Namet; use Namet;
-with Namet.Sp; use Namet.Sp;
-with Nmake; use Nmake;
-with Nlists; use Nlists;
-with Opt; use Opt;
-with Restrict; use Restrict;
-with Rident; use Rident;
-with Sem; use Sem;
-with Sem_Aux; use Sem_Aux;
-with Sem_Cat; use Sem_Cat;
-with Sem_Ch3; use Sem_Ch3;
-with Sem_Ch5; use Sem_Ch5;
-with Sem_Ch8; use Sem_Ch8;
-with Sem_Ch13; use Sem_Ch13;
-with Sem_Dim; use Sem_Dim;
-with Sem_Eval; use Sem_Eval;
-with Sem_Res; use Sem_Res;
-with Sem_Util; use Sem_Util;
-with Sem_Type; use Sem_Type;
-with Sem_Warn; use Sem_Warn;
-with Sinfo; use Sinfo;
-with Snames; use Snames;
-with Stringt; use Stringt;
-with Stand; use Stand;
-with Style; use Style;
-with Targparm; use Targparm;
-with Tbuild; use Tbuild;
-with Ttypes; use Ttypes;
-with Uintp; use Uintp;
+with Aspects; use Aspects;
+with Atree; use Atree;
+with Checks; use Checks;
+with Einfo; use Einfo;
+with Einfo.Entities; use Einfo.Entities;
+with Einfo.Utils; use Einfo.Utils;
+with Elists; use Elists;
+with Errout; use Errout;
+with Expander; use Expander;
+with Exp_Ch6; use Exp_Ch6;
+with Exp_Tss; use Exp_Tss;
+with Exp_Util; use Exp_Util;
+with Freeze; use Freeze;
+with Itypes; use Itypes;
+with Lib; use Lib;
+with Lib.Xref; use Lib.Xref;
+with Namet; use Namet;
+with Namet.Sp; use Namet.Sp;
+with Nmake; use Nmake;
+with Nlists; use Nlists;
+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;
+with Sem_Cat; use Sem_Cat;
+with Sem_Ch3; use Sem_Ch3;
+with Sem_Ch5; use Sem_Ch5;
+with Sem_Ch8; use Sem_Ch8;
+with Sem_Ch13; use Sem_Ch13;
+with Sem_Dim; use Sem_Dim;
+with Sem_Eval; use Sem_Eval;
+with Sem_Res; use Sem_Res;
+with Sem_Util; use Sem_Util;
+with Sem_Type; use Sem_Type;
+with Sem_Warn; use Sem_Warn;
+with Sinfo; use Sinfo;
+with Sinfo.Nodes; use Sinfo.Nodes;
+with Sinfo.Utils; use Sinfo.Utils;
+with Snames; use Snames;
+with Stringt; use Stringt;
+with Stand; use Stand;
+with Style; use Style;
+with Targparm; use Targparm;
+with Tbuild; use Tbuild;
+with Ttypes; use Ttypes;
+with Uintp; use Uintp;
package body Sem_Aggr is
@@ -903,7 +908,7 @@ package body Sem_Aggr is
elsif Present (Find_Aspect (Typ, Aspect_Aggregate))
and then Ekind (Typ) /= E_Record_Type
- and then Ada_Version >= Ada_2020
+ and then Ada_Version >= Ada_2022
then
Resolve_Container_Aggregate (N, Typ);
@@ -1677,7 +1682,7 @@ package body Sem_Aggr is
Enter_Name (Id);
Set_Etype (Id, Index_Typ);
- Set_Ekind (Id, E_Variable);
+ Mutate_Ekind (Id, E_Variable);
Set_Scope (Id, Ent);
-- Analyze expression without expansion, to verify legality.
@@ -2859,7 +2864,7 @@ package body Sem_Aggr is
Set_Etype (Id, Key_Type);
end if;
- Set_Ekind (Id, E_Variable);
+ Mutate_Ekind (Id, E_Variable);
Set_Scope (Id, Ent);
Set_Referenced (Id);
@@ -2980,9 +2985,12 @@ package body Sem_Aggr is
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;
+ Comp : Node_Id;
+ Choice : Node_Id;
+ Num_Choices : Nat := 0;
+ Hi_Val : Uint;
+ Lo_Val : Uint;
begin
if Present (Expressions (N)) then
Comp := First (Expressions (N));
@@ -2999,7 +3007,7 @@ package body Sem_Aggr is
return;
end if;
- Comp := First (Expressions (N));
+ Comp := First (Component_Associations (N));
while Present (Comp) loop
if Nkind (Comp) = N_Component_Association then
@@ -3007,6 +3015,7 @@ package body Sem_Aggr is
while Present (Choice) loop
Analyze_And_Resolve (Choice, Index_Type);
+ Num_Choices := Num_Choices + 1;
Next (Choice);
end loop;
@@ -3018,10 +3027,107 @@ package body Sem_Aggr is
then
Resolve_Iterated_Association
(Comp, Index_Type, Comp_Type);
+ Num_Choices := Num_Choices + 1;
end if;
Next (Comp);
end loop;
+
+ -- The component associations in an indexed aggregate
+ -- must denote a contiguous set of static values. We
+ -- build a table of values/ranges and sort it, as is done
+ -- elsewhere for case statements and array aggregates.
+ -- If the aggregate has a single iterated association it
+ -- is allowed to be nonstatic and there is nothing to check.
+
+ if Num_Choices > 1 then
+ declare
+ Table : Case_Table_Type (1 .. Num_Choices);
+ No_Choice : Pos := 1;
+ Lo, Hi : Node_Id;
+
+ -- Traverse aggregate to determine size of needed table.
+ -- Verify that bounds are static and that loops have no
+ -- filters or key expressions.
+
+ begin
+ Comp := First (Component_Associations (N));
+ while Present (Comp) loop
+ if Nkind (Comp) = N_Iterated_Element_Association then
+ if Present
+ (Loop_Parameter_Specification (Comp))
+ then
+ if Present (Iterator_Filter
+ (Loop_Parameter_Specification (Comp)))
+ then
+ Error_Msg_N
+ ("iterator filter not allowed " &
+ "in indexed aggregate", Comp);
+ return;
+
+ elsif Present (Key_Expression
+ (Loop_Parameter_Specification (Comp)))
+ then
+ Error_Msg_N
+ ("key expression not allowed " &
+ "in indexed aggregate", Comp);
+ return;
+ end if;
+ end if;
+ else
+ Choice := First (Choices (Comp));
+
+ while Present (Choice) loop
+ Get_Index_Bounds (Choice, Lo, Hi);
+ Table (No_Choice).Choice := Choice;
+ Table (No_Choice).Lo := Lo;
+ Table (No_Choice).Hi := Hi;
+
+ -- Verify staticness of value or range
+
+ if not Is_Static_Expression (Lo)
+ or else not Is_Static_Expression (Hi)
+ then
+ Error_Msg_N
+ ("nonstatic expression for index " &
+ "for indexed aggregate", Choice);
+ return;
+ end if;
+
+ No_Choice := No_Choice + 1;
+ Next (Choice);
+ end loop;
+ end if;
+
+ Next (Comp);
+ end loop;
+
+ Sort_Case_Table (Table);
+
+ for J in 1 .. Num_Choices - 1 loop
+ Hi_Val := Expr_Value (Table (J).Hi);
+ Lo_Val := Expr_Value (Table (J + 1).Lo);
+
+ if Lo_Val = Hi_Val then
+ Error_Msg_N
+ ("duplicate index in indexed aggregate",
+ Table (J + 1).Choice);
+ exit;
+
+ elsif Lo_Val < Hi_Val then
+ Error_Msg_N
+ ("overlapping indices in indexed aggregate",
+ Table (J + 1).Choice);
+ exit;
+
+ elsif Lo_Val > Hi_Val + 1 then
+ Error_Msg_N
+ ("missing index values", Table (J + 1).Choice);
+ exit;
+ end if;
+ end loop;
+ end;
+ end if;
end if;
end;
end if;
@@ -3035,7 +3141,7 @@ package body Sem_Aggr is
Base : constant Node_Id := Expression (N);
begin
- Error_Msg_Ada_2020_Feature ("delta aggregate", Sloc (N));
+ Error_Msg_Ada_2022_Feature ("delta aggregate", Sloc (N));
if not Is_Composite_Type (Typ) then
Error_Msg_N ("not a composite type", N);
@@ -3098,7 +3204,7 @@ package body Sem_Aggr is
if No (Scope (Id)) then
Set_Etype (Id, Index_Type);
- Set_Ekind (Id, E_Variable);
+ Mutate_Ekind (Id, E_Variable);
Set_Scope (Id, Ent);
end if;
Enter_Name (Id);
@@ -4743,7 +4849,7 @@ package body Sem_Aggr is
then
Error_Msg_NE
("aggregate not available for type& whose ancestor "
- & "has unknown discriminants ", N, Typ);
+ & "has unknown discriminants", N, Typ);
end if;
if Has_Unknown_Discriminants (Typ)
@@ -4922,12 +5028,19 @@ package body Sem_Aggr is
Prepend_Elmt (Parent_Typ, To => Parent_Typ_List);
Parent_Typ := Etype (Parent_Typ);
+ -- Check whether a private parent requires the use of
+ -- an extension aggregate. This test does not apply in
+ -- an instantiation: if the generic unit is legal so is
+ -- the instance.
+
if Nkind (Parent (Base_Type (Parent_Typ))) =
N_Private_Type_Declaration
or else Nkind (Parent (Base_Type (Parent_Typ))) =
N_Private_Extension_Declaration
then
- if Nkind (N) /= N_Extension_Aggregate then
+ if Nkind (N) /= N_Extension_Aggregate
+ and then not In_Instance
+ then
Error_Msg_NE
("type of aggregate has private ancestor&!",
N, Parent_Typ);
@@ -5031,7 +5144,7 @@ package body Sem_Aggr is
if Present (Get_Value (Component, Component_Associations (N))) then
Error_Msg_NE
- ("more than one value supplied for Component &", N, Component);
+ ("more than one value supplied for component &", N, Component);
end if;
Next (Positional_Expr);
@@ -5085,7 +5198,18 @@ package body Sem_Aggr is
-- replace the reference to the current instance by the target
-- object of the aggregate.
- if Present (Parent (Component))
+ if Is_Case_Choice_Pattern (N) then
+
+ -- Do not transform box component values in a case-choice
+ -- aggregate.
+
+ Add_Association
+ (Component => Component,
+ Expr => Empty,
+ Assoc_List => New_Assoc_List,
+ Is_Box_Present => True);
+
+ elsif Present (Parent (Component))
and then Nkind (Parent (Component)) = N_Component_Declaration
and then Present (Expression (Parent (Component)))
then
diff --git a/gcc/ada/sem_aggr.ads b/gcc/ada/sem_aggr.ads
index cbbc71d..01aa33d 100644
--- a/gcc/ada/sem_aggr.ads
+++ b/gcc/ada/sem_aggr.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute 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_attr.adb b/gcc/ada/sem_attr.adb
index e4537e4..d1a91d8 100644
--- a/gcc/ada/sem_attr.adb
+++ b/gcc/ada/sem_attr.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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,61 +25,65 @@
with Ada.Characters.Latin_1; use Ada.Characters.Latin_1;
-with Aspects; use Aspects;
-with Atree; use Atree;
-with Casing; use Casing;
-with Checks; use Checks;
-with Debug; use Debug;
-with Einfo; use Einfo;
-with Elists; use Elists;
-with Errout; use Errout;
+with Aspects; use Aspects;
+with Atree; use Atree;
+with Casing; use Casing;
+with Checks; use Checks;
+with Debug; use Debug;
+with Einfo; use Einfo;
+with Einfo.Entities; use Einfo.Entities;
+with Einfo.Utils; use Einfo.Utils;
+with Elists; use Elists;
+with Errout; use Errout;
with Eval_Fat;
-with Exp_Dist; use Exp_Dist;
-with Exp_Util; use Exp_Util;
-with Expander; use Expander;
-with Freeze; use Freeze;
-with Gnatvsn; use Gnatvsn;
-with Itypes; use Itypes;
-with Lib; use Lib;
-with Lib.Xref; use Lib.Xref;
-with Nlists; use Nlists;
-with Nmake; use Nmake;
-with Opt; use Opt;
-with Restrict; use Restrict;
-with Rident; use Rident;
-with Rtsfind; use Rtsfind;
+with Exp_Dist; use Exp_Dist;
+with Exp_Util; use Exp_Util;
+with Expander; use Expander;
+with Freeze; use Freeze;
+with Gnatvsn; use Gnatvsn;
+with Itypes; use Itypes;
+with Lib; use Lib;
+with Lib.Xref; use Lib.Xref;
+with Nlists; use Nlists;
+with Nmake; use Nmake;
+with Opt; use Opt;
+with Restrict; use Restrict;
+with Rident; use Rident;
+with Rtsfind; use Rtsfind;
with Sdefault;
-with Sem; use Sem;
-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_Ch10; use Sem_Ch10;
-with Sem_Dim; use Sem_Dim;
-with Sem_Dist; use Sem_Dist;
-with Sem_Elab; use Sem_Elab;
-with Sem_Elim; use Sem_Elim;
-with Sem_Eval; use Sem_Eval;
-with Sem_Prag; use Sem_Prag;
-with Sem_Res; use Sem_Res;
-with Sem_Type; use Sem_Type;
-with Sem_Util; use Sem_Util;
+with Sem; use Sem;
+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_Ch10; use Sem_Ch10;
+with Sem_Dim; use Sem_Dim;
+with Sem_Dist; use Sem_Dist;
+with Sem_Elab; use Sem_Elab;
+with Sem_Elim; use Sem_Elim;
+with Sem_Eval; use Sem_Eval;
+with Sem_Prag; use Sem_Prag;
+with Sem_Res; use Sem_Res;
+with Sem_Type; use Sem_Type;
+with Sem_Util; use Sem_Util;
with Sem_Warn;
-with Stand; use Stand;
-with Sinfo; use Sinfo;
-with Sinput; use Sinput;
+with Stand; use Stand;
+with Sinfo; use Sinfo;
+with Sinfo.Nodes; use Sinfo.Nodes;
+with Sinfo.Utils; use Sinfo.Utils;
+with Sinput; use Sinput;
with System;
-with Stringt; use Stringt;
+with Stringt; use Stringt;
with Style;
-with Stylesw; use Stylesw;
-with Targparm; use Targparm;
-with Ttypes; use Ttypes;
-with Tbuild; use Tbuild;
-with Uintp; use Uintp;
-with Uname; use Uname;
-with Urealp; use Urealp;
+with Stylesw; use Stylesw;
+with Targparm; use Targparm;
+with Ttypes; use Ttypes;
+with Tbuild; use Tbuild;
+with Uintp; use Uintp;
+with Uname; use Uname;
+with Urealp; use Urealp;
-with System.CRC32; use System.CRC32;
+with System.CRC32; use System.CRC32;
package body Sem_Attr is
@@ -164,11 +168,11 @@ 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
+ -- The following array is the list of attributes defined in the Ada 2022
-- 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_22 : constant Attribute_Class_Array := Attribute_Class_Array'(
Attribute_Enum_Rep |
Attribute_Enum_Val => True,
others => False);
@@ -318,14 +322,21 @@ package body Sem_Attr is
procedure Check_E2;
-- Check that two attribute arguments are present
- procedure Check_Enum_Image;
- -- If the prefix type of 'Image is an enumeration type, set all its
- -- literals as referenced, since the image function could possibly end
- -- up referencing any of the literals indirectly. Same for Enum_Val.
- -- Set the flag only if the reference is in the main code unit. Same
- -- restriction when resolving 'Value; otherwise an improperly set
- -- reference when analyzing an inlined body will lose a proper
- -- warning on a useless with_clause.
+ procedure Check_Enum_Image (Check_Enumeration_Maps : Boolean := False);
+ -- Common processing for the Image and Value family of attributes,
+ -- including their Wide and Wide_Wide versions, Enum_Val, Img,
+ -- and Valid_Value.
+ --
+ -- If the prefix type of an attribute is an enumeration type, set all
+ -- its literals as referenced, since the attribute function can
+ -- indirectly reference any of the literals. Set the referenced flag
+ -- only if the attribute is in the main code unit; otherwise an
+ -- improperly set reference when analyzing an inlined body will lose a
+ -- proper warning on a useless with_clause.
+ --
+ -- If Check_Enumeration_Maps is True, then the attribute expansion
+ -- requires enumeration maps, so check whether restriction
+ -- No_Enumeration_Maps is active.
procedure Check_First_Last_Valid;
-- Perform all checks for First_Valid and Last_Valid attributes
@@ -378,6 +389,9 @@ package body Sem_Attr is
procedure Check_Real_Type;
-- Verify that prefix of attribute N is fixed or float type
+ procedure Check_Enumeration_Type;
+ -- Verify that prefix of attribute N is an enumeration type
+
procedure Check_Scalar_Type;
-- Verify that prefix of attribute N is a scalar type
@@ -834,10 +848,13 @@ package body Sem_Attr is
begin
-- Access and Unchecked_Access are illegal in declare_expressions,
- -- according to the RM. We also make the GNAT-specific
- -- Unrestricted_Access attribute illegal.
+ -- according to the RM. We also make the GNAT Unrestricted_Access
+ -- attribute illegal if it comes from source.
- if In_Declare_Expr > 0 then
+ if In_Declare_Expr > 0
+ and then (Attr_Id /= Attribute_Unrestricted_Access
+ or else Comes_From_Source (N))
+ then
Error_Attr ("% attribute cannot occur in a declare_expression", N);
end if;
@@ -905,9 +922,9 @@ package body Sem_Attr is
-- a tagged type cleans constant indications from its scope).
elsif Nkind (Parent (N)) = N_Unchecked_Type_Conversion
- and then (Etype (Parent (N)) = RTE (RE_Prim_Ptr)
+ and then (Is_RTE (Etype (Parent (N)), RE_Prim_Ptr)
or else
- Etype (Parent (N)) = RTE (RE_Size_Ptr))
+ Is_RTE (Etype (Parent (N)), RE_Size_Ptr))
and then Is_Dispatching_Operation
(Directly_Designated_Type (Etype (N)))
then
@@ -1464,12 +1481,20 @@ package body Sem_Attr is
-- Check that Image_Type is legal as the type of a prefix of 'Image.
-- Legality depends on the Ada language version.
+ ----------------------
+ -- Check_Image_Type --
+ ----------------------
+
procedure Check_Image_Type (Image_Type : Entity_Id) is
begin
- if Ada_Version < Ada_2020
+ -- Image_Type may be empty in case of another error detected,
+ -- or if an N_Raise_xxx_Error node is a parent of N.
+
+ if Ada_Version < Ada_2022
+ and then Present (Image_Type)
and then not Is_Scalar_Type (Image_Type)
then
- Error_Msg_Ada_2020_Feature ("nonscalar ''Image", Sloc (P));
+ Error_Msg_Ada_2022_Feature ("nonscalar ''Image", Sloc (P));
Error_Attr;
end if;
end Check_Image_Type;
@@ -1486,7 +1511,7 @@ package body Sem_Attr is
Set_Etype (N, Str_Typ);
Check_Image_Type (Etype (P));
- if Attr_Id /= Attribute_Img and then Ada_Version < Ada_2012 then
+ if Attr_Id /= Attribute_Img then
Error_Msg_Ada_2012_Feature ("|Object''Image", Sloc (P));
end if;
else
@@ -1516,7 +1541,7 @@ package body Sem_Attr is
Validate_Non_Static_Attribute_Function_Call;
end if;
- Check_Enum_Image;
+ Check_Enum_Image (Check_Enumeration_Maps => True);
-- Check restriction No_Fixed_IO. Note the check of Comes_From_Source
-- to avoid giving a duplicate message for when Image attributes
@@ -1582,7 +1607,6 @@ package body Sem_Attr is
-- Local variables
- Dims : Int;
Index : Entity_Id;
-- Start of processing for Check_Array_Or_Scalar_Type
@@ -1646,14 +1670,16 @@ package body Sem_Attr is
Set_Etype (N, Base_Type (Etype (Index)));
else
- Dims := UI_To_Int (Intval (E1));
-
- for J in 1 .. Dims - 1 loop
- Next_Index (Index);
- end loop;
+ declare
+ Udims : constant Uint := Expr_Value (E1);
+ Dims : constant Int := UI_To_Int (Udims);
+ begin
+ for J in 1 .. Dims - 1 loop
+ Next_Index (Index);
+ end loop;
+ end;
Set_Etype (N, Base_Type (Etype (Index)));
- Set_Etype (E1, Standard_Integer);
end if;
end if;
end Check_Array_Or_Scalar_Type;
@@ -1951,10 +1977,23 @@ package body Sem_Attr is
-- Check_Enum_Image --
----------------------
- procedure Check_Enum_Image is
+ procedure Check_Enum_Image (Check_Enumeration_Maps : Boolean := False) is
Lit : Entity_Id;
begin
+ -- Ensure that Check_Enumeration_Maps parameter is set precisely for
+ -- attributes whose implementation requires enumeration maps.
+
+ pragma Assert
+ (Check_Enumeration_Maps = (Attr_Id in Attribute_Image
+ | Attribute_Img
+ | Attribute_Valid_Value
+ | Attribute_Value
+ | Attribute_Wide_Image
+ | Attribute_Wide_Value
+ | Attribute_Wide_Wide_Image
+ | Attribute_Wide_Wide_Value));
+
-- When an enumeration type appears in an attribute reference, all
-- literals of the type are marked as referenced. This must only be
-- done if the attribute reference appears in the current source.
@@ -1964,6 +2003,10 @@ package body Sem_Attr is
if Is_Enumeration_Type (P_Base_Type)
and then In_Extended_Main_Code_Unit (N)
then
+ if Check_Enumeration_Maps then
+ Check_Restriction (No_Enumeration_Maps, N);
+ end if;
+
Lit := First_Literal (P_Base_Type);
while Present (Lit) loop
Set_Referenced (Lit);
@@ -2294,20 +2337,15 @@ package body Sem_Attr is
begin
if Is_Entity_Name (P) then
declare
- K : constant Entity_Kind := Ekind (Entity (P));
- T : constant Entity_Id := Etype (Entity (P));
-
+ E : constant Entity_Id := Entity (P);
begin
- if K in Subprogram_Kind
- or else K in Task_Kind
- or else K in Protected_Kind
- or else K = E_Package
- or else K in Generic_Unit_Kind
- or else (K = E_Variable
- and then
- (Is_Task_Type (T)
- or else
- Is_Protected_Type (T)))
+ if Ekind (E) in E_Protected_Type
+ | E_Task_Type
+ | Entry_Kind
+ | Generic_Unit_Kind
+ | Subprogram_Kind
+ | E_Package
+ or else Is_Single_Concurrent_Object (E)
then
return;
end if;
@@ -2330,6 +2368,19 @@ package body Sem_Attr is
end if;
end Check_Real_Type;
+ ----------------------------
+ -- Check_Enumeration_Type --
+ ----------------------------
+
+ procedure Check_Enumeration_Type is
+ begin
+ Check_Type;
+
+ if not Is_Enumeration_Type (P_Type) then
+ Error_Attr_P ("prefix of % attribute must be enumeration type");
+ end if;
+ end Check_Enumeration_Type;
+
-----------------------
-- Check_Scalar_Type --
-----------------------
@@ -2381,15 +2432,18 @@ package body Sem_Attr is
Analyze_And_Resolve (E1);
-- Check that the first argument is
- -- Ada.Strings.Text_Output.Sink'Class.
+ -- Ada.Strings.Text_Buffers.Root_Buffer_Type'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
+ if not Is_RTE (Root_Type (Root_Type (Etype (E1))),
+ RE_Root_Buffer_Type)
+ then
Error_Attr
- ("expected Ada.Strings.Text_Output.Sink''Class", E1);
+ ("expected Ada.Strings.Text_Buffers.Root_Buffer_Type''Class",
+ E1);
end if;
-- Check that the second argument is of the right type
@@ -2557,8 +2611,8 @@ package body Sem_Attr is
-- X for X'Class, and we really want to go to the root.)
if not Is_Access_Type (Etyp)
- or else Root_Type (Root_Type (Designated_Type (Etyp))) /=
- RTE (RE_Root_Stream_Type)
+ or else not Is_RTE (Root_Type (Root_Type (Designated_Type (Etyp))),
+ RE_Root_Stream_Type)
then
Error_Attr
("expected access to Ada.Streams.Root_Stream_Type''Class", E1);
@@ -2838,17 +2892,17 @@ package body Sem_Attr is
case Uneval_Old_Setting is
when 'E' =>
- -- ??? In the case where Ada_Version is < Ada_2020 and
- -- an illegal 'Old prefix would be legal in Ada_2020,
- -- we'd like to call Error_Msg_Ada_2020_Feature.
+ -- ??? In the case where Ada_Version is < Ada_2022 and
+ -- an illegal 'Old prefix would be legal in Ada_2022,
+ -- we'd like to call Error_Msg_Ada_2022_Feature.
-- Identifying that case involves some work.
Error_Attr_P
("prefix of attribute % that is potentially "
& "unevaluated must statically name an entity"
- -- further text needed for accuracy if Ada_2020
- & (if Ada_Version >= Ada_2020
+ -- further text needed for accuracy if Ada_2022
+ & (if Ada_Version >= Ada_2022
and then Attr_Id = Attribute_Old
then " or be eligible for conditional evaluation"
& " (RM 6.1.1 (27))"
@@ -2925,13 +2979,13 @@ package body Sem_Attr is
-- Deal with Ada 2005 attributes that are implementation attributes
-- because they appear in a version of Ada before Ada 2005, ditto for
- -- Ada 2012 and Ada 2020 attributes appearing in an earlier version.
+ -- Ada 2012 and Ada 2022 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)
+ (Attribute_22 (Attr_Id) and then Ada_Version < Ada_2022)
then
Check_Restriction (No_Implementation_Attributes, N);
end if;
@@ -5170,7 +5224,7 @@ package body Sem_Attr is
else
-- Ensure that the prefix of attribute 'Old is an entity when it
-- is potentially unevaluated (6.1.1 (27/3)). This rule is
- -- relaxed in Ada2020 - this relaxation is reflected in the
+ -- relaxed in Ada 2022 - this relaxation is reflected in the
-- call (below) to Eligible_For_Conditional_Evaluation.
if Is_Potentially_Unevaluated (N)
@@ -5377,7 +5431,7 @@ package body Sem_Attr is
or else (Is_Access_Type (Etype (P))
and then Is_Protected_Type (Designated_Type (Etype (P))))
then
- Resolve (P, Etype (P));
+ Resolve (P);
else
Error_Attr_P ("prefix of % attribute must be a protected object");
end if;
@@ -5678,7 +5732,7 @@ package body Sem_Attr is
null;
else
Error_Msg_NE
- ("cannot apply Reduce to object of type$", N, Typ);
+ ("cannot apply Reduce to object of type&", N, Typ);
end if;
elsif Present (Expressions (Stream))
@@ -7041,6 +7095,31 @@ package body Sem_Attr is
Set_Etype (N, Standard_Boolean);
end Valid;
+ -----------------
+ -- Valid_Value --
+ -----------------
+
+ when Attribute_Valid_Value =>
+ Check_E1;
+ Check_Enumeration_Type;
+ Check_Enum_Image (Check_Enumeration_Maps => True);
+ Set_Etype (N, Standard_Boolean);
+ Validate_Non_Static_Attribute_Function_Call;
+
+ if P_Type in Standard_Boolean
+ | Standard_Character
+ | Standard_Wide_Character
+ | Standard_Wide_Wide_Character
+ then
+ Error_Attr_P
+ ("prefix of % attribute must not be a type in Standard");
+ end if;
+
+ if Discard_Names (First_Subtype (P_Type)) then
+ Error_Attr_P
+ ("prefix of % attribute must not have Discard_Names");
+ end if;
+
-------------------
-- Valid_Scalars --
-------------------
@@ -7110,33 +7189,7 @@ package body Sem_Attr is
=>
Check_E1;
Check_Scalar_Type;
-
- -- Case of enumeration type
-
- -- When an enumeration type appears in an attribute reference, all
- -- literals of the type are marked as referenced. This must only be
- -- done if the attribute reference appears in the current source.
- -- Otherwise the information on references may differ between a
- -- normal compilation and one that performs inlining.
-
- if Is_Enumeration_Type (P_Type)
- and then In_Extended_Main_Code_Unit (N)
- then
- Check_Restriction (No_Enumeration_Maps, N);
-
- -- Mark all enumeration literals as referenced, since the use of
- -- the Value attribute can implicitly reference any of the
- -- literals of the enumeration base type.
-
- declare
- Ent : Entity_Id := First_Literal (P_Base_Type);
- begin
- while Present (Ent) loop
- Set_Referenced (Ent);
- Next_Literal (Ent);
- end loop;
- end;
- end if;
+ Check_Enum_Image (Check_Enumeration_Maps => True);
-- Set Etype before resolving expression because expansion of
-- expression may require enclosing type. Note that the type
@@ -7976,14 +8029,27 @@ package body Sem_Attr is
end if;
end;
- -- For Size, give size of object if available, otherwise we
- -- cannot fold Size.
-
elsif Id = Attribute_Size then
+ -- For Enum_Lit'Size, use Enum_Type'Object_Size. Taking the 'Size
+ -- of a literal is kind of a strange thing to do, so we don't want
+ -- to pass this oddity on to the back end. Note that Etype of an
+ -- enumeration literal is always a (base) type, never a
+ -- constrained subtype, so the Esize is always known.
+
if Is_Entity_Name (P)
- and then Known_Static_Esize (Entity (P))
+ and then Ekind (Entity (P)) = E_Enumeration_Literal
+ then
+ pragma Assert (Known_Static_Esize (Etype (P)));
+ Compile_Time_Known_Attribute (N, Esize (Etype (P)));
+
+ -- Otherwise, if Size is available, use that
+
+ elsif Is_Entity_Name (P) and then Known_Static_Esize (Entity (P))
then
Compile_Time_Known_Attribute (N, Esize (Entity (P)));
+
+ -- Otherwise, we cannot fold
+
else
Check_Expressions;
end if;
@@ -9103,11 +9169,13 @@ package body Sem_Attr is
-- Machine --
-------------
+ -- We use the same rounding mode as the one used for RM 4.9(38)
+
when Attribute_Machine =>
Fold_Ureal
(N,
Eval_Fat.Machine
- (P_Base_Type, Expr_Value_R (E1), Eval_Fat.Round, N),
+ (P_Base_Type, Expr_Value_R (E1), Eval_Fat.Round_Even, N),
Static);
------------------
@@ -10457,6 +10525,7 @@ package body Sem_Attr is
| Attribute_Unrestricted_Access
| Attribute_Valid
| Attribute_Valid_Scalars
+ | Attribute_Valid_Value
| Attribute_Value
| Attribute_Wchar_T_Size
| Attribute_Wide_Value
@@ -10714,9 +10783,7 @@ package body Sem_Attr is
-- If attribute was universal type, reset to actual type
- if Etype (N) = Universal_Integer
- or else Etype (N) = Universal_Real
- then
+ if Is_Universal_Numeric_Type (Etype (N)) then
Set_Etype (N, Typ);
end if;
@@ -10745,10 +10812,11 @@ package body Sem_Attr is
Nm : Node_Id;
Note : Boolean := True;
- -- Skip this for the case of Unrestricted_Access occuring in
- -- the context of a Valid check, since this otherwise leads
- -- to a missed warning (the Valid check does not really
- -- modify!) If this case, Note will be reset to False.
+ -- Skip this for the case of Unrestricted_Access occurring
+ -- in the context of a Valid check, since this otherwise
+ -- leads to a missed warning (the Valid check does not
+ -- really modify!) If this case, Note will be reset to
+ -- False.
-- Skip it as well if the type is an Access_To_Constant,
-- given that no use of the value can modify the prefix.
@@ -10881,34 +10949,10 @@ package body Sem_Attr is
if Convention (Designated_Type (Btyp)) /=
Convention (Entity (P))
then
- -- The rule in 6.3.1 (8) deserves a special error
- -- message.
-
- if Convention (Btyp) = Convention_Intrinsic
- and then Nkind (Parent (N)) = N_Procedure_Call_Statement
- and then Is_Entity_Name (Name (Parent (N)))
- and then Inside_A_Generic
- then
- declare
- Subp : constant Entity_Id :=
- Entity (Name (Parent (N)));
- begin
- if Convention (Subp) = Convention_Intrinsic then
- Error_Msg_FE
- ("?subprogram and its formal access "
- & "parameters have convention Intrinsic",
- Parent (N), Subp);
- Error_Msg_N
- ("actual cannot be access attribute", N);
- end if;
- end;
-
- else
- Error_Msg_FE
- ("subprogram & has wrong convention", P, Entity (P));
- Error_Msg_Sloc := Sloc (Btyp);
- Error_Msg_FE ("\does not match & declared#", P, Btyp);
- end if;
+ Error_Msg_FE
+ ("subprogram & has wrong convention", P, Entity (P));
+ Error_Msg_Sloc := Sloc (Btyp);
+ Error_Msg_FE ("\does not match & declared#", P, Btyp);
if not Is_Itype (Btyp)
and then not Has_Convention_Pragma (Btyp)
@@ -11246,7 +11290,11 @@ package body Sem_Attr is
-- this kind of warning is an error in SPARK mode.
if In_Instance_Body then
- Error_Msg_Warn := SPARK_Mode /= On;
+ Error_Msg_Warn :=
+ SPARK_Mode /= On
+ and then
+ not No_Dynamic_Accessibility_Checks_Enabled (P);
+
Error_Msg_F
("non-local pointer cannot point to local object<<", P);
Error_Msg_F ("\Program_Error [<<", P);
@@ -11378,10 +11426,13 @@ package body Sem_Attr is
-- Check the static accessibility rule of 3.10.2(28). Note that
-- this check is not performed for the case of an anonymous
-- access type, since the access attribute is always legal
- -- in such a context.
+ -- in such a context - unless the restriction
+ -- No_Dynamic_Accessibility_Checks is active.
if Attr_Id /= Attribute_Unchecked_Access
- and then Ekind (Btyp) = E_General_Access_Type
+ and then
+ (Ekind (Btyp) = E_General_Access_Type
+ or else No_Dynamic_Accessibility_Checks_Enabled (Btyp))
-- Call Accessibility_Level directly to avoid returning zero
-- on cases where the prefix is an explicitly aliased
@@ -11448,6 +11499,25 @@ package body Sem_Attr is
Error_Msg_F ("context requires a non-protected subprogram", P);
end if;
+ -- AI12-0412: The rule in RM 6.1.1(18.2/5) disallows applying
+ -- attribute Access to a primitive of an abstract type when the
+ -- primitive has any Pre'Class or Post'Class aspects specified
+ -- with nonstatic expressions.
+
+ if Attr_Id = Attribute_Access
+ and then Ekind (Btyp) in E_Access_Subprogram_Type
+ | E_Anonymous_Access_Subprogram_Type
+ and then Is_Entity_Name (P)
+ and then Is_Dispatching_Operation (Entity (P))
+ and then
+ Is_Prim_Of_Abst_Type_With_Nonstatic_CW_Pre_Post (Entity (P))
+ then
+ Error_Msg_N
+ ("attribute not allowed for primitive of abstract type with "
+ & "nonstatic class-wide pre/postconditions",
+ N);
+ end if;
+
-- The context cannot be a pool-specific type, but this is a
-- legality rule, not a resolution rule, so it must be checked
-- separately, after possibly disambiguation (see AI-245).
@@ -11475,14 +11545,14 @@ package body Sem_Attr is
("access to atomic object cannot yield access-to-" &
"non-atomic type", P);
- elsif Is_Volatile_Object (P)
+ elsif Is_Volatile_Object_Ref (P)
and then not Is_Volatile (Designated_Type (Typ))
then
Error_Msg_F
("access to volatile object cannot yield access-to-" &
"non-volatile type", P);
- elsif Is_Volatile_Full_Access_Object (P)
+ elsif Is_Volatile_Full_Access_Object_Ref (P)
and then not Is_Volatile_Full_Access (Designated_Type (Typ))
then
Error_Msg_F
@@ -11491,9 +11561,9 @@ package body Sem_Attr is
end if;
-- Check for nonatomic subcomponent of a full access object
- -- in Ada 2020 (RM C.6 (12)).
+ -- in Ada 2022 (RM C.6 (12)).
- if Ada_Version >= Ada_2020
+ if Ada_Version >= Ada_2022
and then Is_Subcomponent_Of_Full_Access_Object (P)
and then not Is_Atomic_Object (P)
then
@@ -12274,7 +12344,7 @@ package body Sem_Attr is
-- reference is resolved.
case Attr_Id is
- when Attribute_Value =>
+ when Attribute_Valid_Value | Attribute_Value =>
Resolve (First (Expressions (N)), Standard_String);
when Attribute_Wide_Value =>
diff --git a/gcc/ada/sem_attr.ads b/gcc/ada/sem_attr.ads
index 5ccb1c1..7ebdb45 100644
--- a/gcc/ada/sem_attr.ads
+++ b/gcc/ada/sem_attr.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute 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_aux.adb b/gcc/ada/sem_aux.adb
index 4925ffd..ea3b59c 100644
--- a/gcc/ada/sem_aux.adb
+++ b/gcc/ada/sem_aux.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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,13 +23,17 @@
-- --
------------------------------------------------------------------------------
-with Atree; use Atree;
-with Einfo; use Einfo;
-with Nlists; use Nlists;
-with Sinfo; use Sinfo;
-with Snames; use Snames;
-with Stand; use Stand;
-with Uintp; use Uintp;
+with Atree; use Atree;
+with Einfo; use Einfo;
+with Einfo.Entities; use Einfo.Entities;
+with Einfo.Utils; use Einfo.Utils;
+with Nlists; use Nlists;
+with Sinfo; use Sinfo;
+with Sinfo.Nodes; use Sinfo.Nodes;
+with Sinfo.Utils; use Sinfo.Utils;
+with Snames; use Snames;
+with Stand; use Stand;
+with Uintp; use Uintp;
package body Sem_Aux is
@@ -1072,14 +1076,18 @@ package body Sem_Aux is
---------------------
function Is_Limited_Type (Ent : Entity_Id) return Boolean is
- Btype : constant E := Base_Type (Ent);
- Rtype : constant E := Root_Type (Btype);
+ Btype : Entity_Id;
+ Rtype : Entity_Id;
begin
if not Is_Type (Ent) then
return False;
+ end if;
- elsif Ekind (Btype) = E_Limited_Private_Type
+ Btype := Base_Type (Ent);
+ Rtype := Root_Type (Btype);
+
+ if Ekind (Btype) = E_Limited_Private_Type
or else Is_Limited_Composite (Btype)
then
return True;
@@ -1413,12 +1421,16 @@ package body Sem_Aux is
N : Node_Id;
begin
+ pragma Assert (Is_Package_Or_Generic_Package (E));
+
N := Parent (E);
if Nkind (N) = N_Defining_Program_Unit_Name then
N := Parent (N);
end if;
+ pragma Assert (Nkind (N) = N_Package_Specification);
+
return N;
end Package_Specification;
diff --git a/gcc/ada/sem_aux.ads b/gcc/ada/sem_aux.ads
index 237d5dc..810e2d8 100644
--- a/gcc/ada/sem_aux.ads
+++ b/gcc/ada/sem_aux.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute 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_case.adb b/gcc/ada/sem_case.adb
index 6cda6a9..7d08da5 100644
--- a/gcc/ada/sem_case.adb
+++ b/gcc/ada/sem_case.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1996-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1996-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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,28 +23,35 @@
-- --
------------------------------------------------------------------------------
-with Atree; use Atree;
-with Einfo; use Einfo;
-with Errout; use Errout;
-with Namet; use Namet;
-with Nlists; use Nlists;
-with Nmake; use Nmake;
-with Opt; use Opt;
-with Sem; use Sem;
-with Sem_Aux; use Sem_Aux;
-with Sem_Eval; use Sem_Eval;
-with Sem_Res; use Sem_Res;
-with Sem_Util; use Sem_Util;
-with Sem_Type; use Sem_Type;
-with Snames; use Snames;
-with Stand; use Stand;
-with Sinfo; use Sinfo;
-with Tbuild; use Tbuild;
-with Uintp; use Uintp;
+with Atree; use Atree;
+with Einfo; use Einfo;
+with Einfo.Entities; use Einfo.Entities;
+with Einfo.Utils; use Einfo.Utils;
+with Elists; use Elists;
+with Errout; use Errout;
+with Namet; use Namet;
+with Nlists; use Nlists;
+with Nmake; use Nmake;
+with Opt; use Opt;
+with Sem; use Sem;
+with Sem_Aux; use Sem_Aux;
+with Sem_Eval; use Sem_Eval;
+with Sem_Res; use Sem_Res;
+with Sem_Util; use Sem_Util;
+with Sem_Type; use Sem_Type;
+with Snames; use Snames;
+with Stand; use Stand;
+with Sinfo; use Sinfo;
+with Sinfo.Nodes; use Sinfo.Nodes;
+with Sinfo.Utils; use Sinfo.Utils;
+with Table;
+with Tbuild; use Tbuild;
+with Uintp; use Uintp;
with Ada.Unchecked_Deallocation;
with GNAT.Heap_Sort_G;
+with GNAT.Sets;
package body Sem_Case is
@@ -84,13 +91,126 @@ package body Sem_Case is
--
-- Bounds_Type is the type whose range must be covered by the alternatives
--
- -- Subtyp is the subtype of the expression. If its bounds are non-static
+ -- Subtyp is the subtype of the expression. If its bounds are nonstatic
-- the alternatives must cover its base type.
function Choice_Image (Value : Uint; Ctype : Entity_Id) return Name_Id;
-- Given a Pos value of enumeration type Ctype, returns the name
-- ID of an appropriate string to be used in error message output.
+ function Has_Static_Discriminant_Constraint
+ (Subtyp : Entity_Id) return Boolean;
+ -- Returns True if the given subtype is subject to a discriminant
+ -- constraint and at least one of the constraint values is nonstatic.
+
+ package Composite_Case_Ops is
+
+ function Scalar_Part_Count (Subtyp : Entity_Id) return Nat;
+ -- Given the composite type Subtyp of a case selector, returns the
+ -- number of scalar parts in an object of this type. This is the
+ -- dimensionality of the associated Cartesian product space.
+
+ function Choice_Count (Alternatives : List_Id) return Nat;
+ -- The sum of the number of choices for each alternative in the given
+ -- list.
+
+ generic
+ Case_Statement : Node_Id;
+ package Choice_Analysis is
+
+ type Alternative_Id is
+ new Int range 1 .. List_Length (Alternatives (Case_Statement));
+ type Choice_Id is
+ new Int range 1 .. Choice_Count (Alternatives (Case_Statement));
+ type Part_Id is new Int range
+ 1 .. Scalar_Part_Count (Etype (Expression (Case_Statement)));
+
+ type Discrete_Range_Info is
+ record
+ Low, High : Uint;
+ end record;
+
+ type Composite_Range_Info is array (Part_Id) of Discrete_Range_Info;
+
+ type Choice_Range_Info (Is_Others : Boolean := False) is
+ record
+ case Is_Others is
+ when False =>
+ Ranges : Composite_Range_Info;
+ when True =>
+ null;
+ end case;
+ end record;
+
+ type Choices_Range_Info is array (Choice_Id) of Choice_Range_Info;
+
+ package Value_Sets is
+
+ type Value_Set is private;
+ -- A set of points in the Cartesian product space defined
+ -- by the composite type of the case selector.
+ -- Implemented as an access type.
+
+ type Set_Comparison is
+ (Disjoint, Equal, Contains, Contained_By, Overlaps);
+
+ function Compare (S1, S2 : Value_Set) return Set_Comparison;
+ -- If either argument (or both) is empty, result is Disjoint.
+ -- Otherwise, result is Equal if the two sets are equal.
+
+ Empty : constant Value_Set;
+
+ function Matching_Values
+ (Info : Composite_Range_Info) return Value_Set;
+ -- The Cartesian product of the given array of ranges
+ -- (excluding any values outside the Cartesian product of the
+ -- component ranges).
+
+ procedure Union (Target : in out Value_Set; Source : Value_Set);
+ -- Add elements of Source into Target
+
+ procedure Remove (Target : in out Value_Set; Source : Value_Set);
+ -- Remove elements of Source from Target
+
+ function Complement_Is_Empty (Set : Value_Set) return Boolean;
+ -- Return True iff the set is "maximal", in the sense that it
+ -- includes every value in the Cartesian product of the
+ -- component ranges.
+
+ procedure Free_Value_Sets;
+ -- Reclaim storage associated with implementation of this package.
+
+ private
+ type Value_Set is new Natural;
+ -- An index for a table that will be declared in the package body.
+
+ Empty : constant Value_Set := 0;
+
+ end Value_Sets;
+
+ type Single_Choice_Info (Is_Others : Boolean := False) is
+ record
+ Alternative : Alternative_Id;
+ case Is_Others is
+ when False =>
+ Matches : Value_Sets.Value_Set;
+ when True =>
+ null;
+ end case;
+ end record;
+
+ type Choices_Info is array (Choice_Id) of Single_Choice_Info;
+
+ function Analysis return Choices_Info;
+ -- Parse the case choices in order to determine the set of
+ -- matching values associated with each choice.
+
+ type Bound_Values is array (Positive range <>) of Node_Id;
+
+ end Choice_Analysis;
+
+ end Composite_Case_Ops;
+
procedure Expand_Others_Choice
(Case_Table : Choice_Table_Type;
Others_Choice : Node_Id;
@@ -141,9 +261,9 @@ package body Sem_Case is
-- is posted at location C. Caller sets Error_Msg_Sloc for xx.
procedure Explain_Non_Static_Bound;
- -- Called when we find a non-static bound, requiring the base type to
+ -- Called when we find a nonstatic bound, requiring the base type to
-- be covered. Provides where possible a helpful explanation of why the
- -- bounds are non-static, since this is not always obvious.
+ -- bounds are nonstatic, since this is not always obvious.
function Lt_Choice (C1, C2 : Natural) return Boolean;
-- Comparison routine for comparing Choice_Table entries. Use the lower
@@ -531,20 +651,23 @@ package body Sem_Case is
and then Compile_Time_Known_Value (C)
and then Expr_Value (C) = Lo
then
- Error_Msg_N ("duplication of choice value: &#!", C);
+ Error_Msg_N
+ ("duplication of choice value: &#!", Original_Node (C));
-- Not that special case, so just output the integer value
else
Error_Msg_Uint_1 := Lo;
- Error_Msg_N ("duplication of choice value: ^#!", C);
+ Error_Msg_N
+ ("duplication of choice value: ^#!", Original_Node (C));
end if;
-- Enumeration type
else
Error_Msg_Name_1 := Choice_Image (Lo, Bounds_Type);
- Error_Msg_N ("duplication of choice value: %#!", C);
+ Error_Msg_N
+ ("duplication of choice value: %#!", Original_Node (C));
end if;
-- More than one choice value, so print range of values
@@ -577,7 +700,9 @@ package body Sem_Case is
else
Error_Msg_Uint_1 := Lo;
Error_Msg_Uint_2 := Hi;
- Error_Msg_N ("duplication of choice values: ^ .. ^#!", C);
+ Error_Msg_N
+ ("duplication of choice values: ^ .. ^#!",
+ Original_Node (C));
end if;
-- Enumeration type
@@ -585,7 +710,8 @@ package body Sem_Case is
else
Error_Msg_Name_1 := Choice_Image (Lo, Bounds_Type);
Error_Msg_Name_2 := Choice_Image (Hi, Bounds_Type);
- Error_Msg_N ("duplication of choice values: % .. %#!", C);
+ Error_Msg_N
+ ("duplication of choice values: % .. %#!", Original_Node (C));
end if;
end if;
end Dup_Choice;
@@ -614,7 +740,7 @@ package body Sem_Case is
("bounds of & are not static, "
& "alternatives must cover base type!", Expr, Expr);
- -- If this is a case statement, the expression may be non-static
+ -- If this is a case statement, the expression may be nonstatic
-- or else the subtype may be at fault.
elsif Is_Entity_Name (Expr) then
@@ -677,8 +803,6 @@ package body Sem_Case is
--------------------
procedure Missing_Choice (Value1 : Uint; Value2 : Uint) is
- Msg_Sloc : constant Source_Ptr := Sloc (Case_Node);
-
begin
-- AI05-0188 : within an instance the non-others choices do not have
-- to belong to the actual subtype.
@@ -692,7 +816,7 @@ package body Sem_Case is
elsif Value1 > Value2 then
return;
- -- If predicate is already known to be violated, do no check for
+ -- If predicate is already known to be violated, do not check for
-- coverage error, to prevent cascaded messages.
elsif Predicate_Error then
@@ -704,10 +828,10 @@ package body Sem_Case is
if Value1 = Value2 then
if Is_Integer_Type (Bounds_Type) then
Error_Msg_Uint_1 := Value1;
- Error_Msg ("missing case value: ^!", Msg_Sloc);
+ Error_Msg_N ("missing case value: ^!", Case_Node);
else
Error_Msg_Name_1 := Choice_Image (Value1, Bounds_Type);
- Error_Msg ("missing case value: %!", Msg_Sloc);
+ Error_Msg_N ("missing case value: %!", Case_Node);
end if;
-- More than one choice value, so print range of values
@@ -716,11 +840,11 @@ package body Sem_Case is
if Is_Integer_Type (Bounds_Type) then
Error_Msg_Uint_1 := Value1;
Error_Msg_Uint_2 := Value2;
- Error_Msg ("missing case values: ^ .. ^!", Msg_Sloc);
+ Error_Msg_N ("missing case values: ^ .. ^!", Case_Node);
else
Error_Msg_Name_1 := Choice_Image (Value1, Bounds_Type);
Error_Msg_Name_2 := Choice_Image (Value2, Bounds_Type);
- Error_Msg ("missing case values: % .. %!", Msg_Sloc);
+ Error_Msg_N ("missing case values: % .. %!", Case_Node);
end if;
end if;
end Missing_Choice;
@@ -972,6 +1096,1264 @@ package body Sem_Case is
return Name_Find;
end Choice_Image;
+ package body Composite_Case_Ops is
+
+ function Static_Array_Length (Subtyp : Entity_Id) return Nat;
+ -- Given a one-dimensional constrained array subtype with
+ -- statically known bounds, return its length.
+
+ -------------------------
+ -- Static_Array_Length --
+ -------------------------
+
+ function Static_Array_Length (Subtyp : Entity_Id) return Nat is
+ pragma Assert (Is_Constrained (Subtyp));
+ pragma Assert (Number_Dimensions (Subtyp) = 1);
+ Index : constant Node_Id := First_Index (Subtyp);
+ pragma Assert (Is_OK_Static_Range (Index));
+ Lo : constant Uint := Expr_Value (Low_Bound (Index));
+ Hi : constant Uint := Expr_Value (High_Bound (Index));
+ Len : constant Uint := UI_Max (0, (Hi - Lo) + 1);
+ begin
+ return UI_To_Int (Len);
+ end Static_Array_Length;
+
+ -----------------------
+ -- Scalar_Part_Count --
+ -----------------------
+
+ function Scalar_Part_Count (Subtyp : Entity_Id) return Nat is
+ begin
+ if Is_Scalar_Type (Subtyp) then
+ return 1;
+ elsif Is_Array_Type (Subtyp) then
+ return Static_Array_Length (Subtyp)
+ * Scalar_Part_Count (Component_Type (Subtyp));
+ elsif Is_Record_Type (Subtyp) then
+ declare
+ Result : Nat := 0;
+ Comp : Entity_Id := First_Component_Or_Discriminant
+ (Base_Type (Subtyp));
+ begin
+ while Present (Comp) loop
+ Result := Result + Scalar_Part_Count (Etype (Comp));
+ Next_Component_Or_Discriminant (Comp);
+ end loop;
+ return Result;
+ end;
+ else
+ pragma Assert (False);
+ raise Program_Error;
+ end if;
+ end Scalar_Part_Count;
+
+ ------------------
+ -- Choice_Count --
+ ------------------
+
+ function Choice_Count (Alternatives : List_Id) return Nat is
+ Result : Nat := 0;
+ Alt : Node_Id := First (Alternatives);
+ begin
+ while Present (Alt) loop
+ Result := Result + List_Length (Discrete_Choices (Alt));
+ Next (Alt);
+ end loop;
+ return Result;
+ end Choice_Count;
+
+ package body Choice_Analysis is
+
+ function Component_Bounds_Info return Composite_Range_Info;
+ -- Returns the (statically known) bounds for each component.
+ -- The selector expression value (or any other value of the type
+ -- of the selector expression) can be thought of as a point in the
+ -- Cartesian product of these sets.
+
+ function Parse_Choice (Choice : Node_Id;
+ Alt : Node_Id) return Choice_Range_Info;
+ -- Extract Choice_Range_Info from a Choice node
+
+ ---------------------------
+ -- Component_Bounds_Info --
+ ---------------------------
+
+ function Component_Bounds_Info return Composite_Range_Info is
+ Result : Composite_Range_Info;
+ Next : Part_Id := 1;
+ Done : Boolean := False;
+
+ procedure Update_Result (Info : Discrete_Range_Info);
+ -- Initialize first remaining uninitialized element of Result.
+ -- Also set Next and Done.
+
+ -------------------
+ -- Update_Result --
+ -------------------
+
+ procedure Update_Result (Info : Discrete_Range_Info) is
+ begin
+ Result (Next) := Info;
+ if Next /= Part_Id'Last then
+ Next := Next + 1;
+ else
+ pragma Assert (not Done);
+ Done := True;
+ end if;
+ end Update_Result;
+
+ procedure Traverse_Discrete_Parts (Subtyp : Entity_Id);
+ -- Traverse the given subtype, looking for discrete parts.
+ -- For an array subtype of length N, the element subtype
+ -- is traversed N times. For a record subtype, traverse
+ -- each component's subtype (once). When a discrete part is
+ -- found, call Update_Result.
+
+ -----------------------------
+ -- Traverse_Discrete_Parts --
+ -----------------------------
+
+ procedure Traverse_Discrete_Parts (Subtyp : Entity_Id) is
+ begin
+ if Is_Discrete_Type (Subtyp) then
+ Update_Result
+ ((Low => Expr_Value (Type_Low_Bound (Subtyp)),
+ High => Expr_Value (Type_High_Bound (Subtyp))));
+ elsif Is_Array_Type (Subtyp) then
+ for I in 1 .. Static_Array_Length (Subtyp) loop
+ Traverse_Discrete_Parts (Component_Type (Subtyp));
+ end loop;
+ elsif Is_Record_Type (Subtyp) then
+ if Has_Static_Discriminant_Constraint (Subtyp) then
+
+ -- The component range for a constrained discriminant
+ -- is a single value.
+ declare
+ Dc_Elmt : Elmt_Id :=
+ First_Elmt (Discriminant_Constraint (Subtyp));
+ Dc_Value : Uint;
+ begin
+ while Present (Dc_Elmt) loop
+ Dc_Value := Expr_Value (Node (Dc_Elmt));
+ Update_Result ((Low => Dc_Value,
+ High => Dc_Value));
+
+ Next_Elmt (Dc_Elmt);
+ end loop;
+ end;
+
+ -- Generate ranges for nondiscriminant components.
+ declare
+ Comp : Entity_Id := First_Component
+ (Base_Type (Subtyp));
+ begin
+ while Present (Comp) loop
+ Traverse_Discrete_Parts (Etype (Comp));
+ Next_Component (Comp);
+ end loop;
+ end;
+ else
+ -- Generate ranges for all components
+ declare
+ Comp : Entity_Id :=
+ First_Component_Or_Discriminant
+ (Base_Type (Subtyp));
+ begin
+ while Present (Comp) loop
+ Traverse_Discrete_Parts (Etype (Comp));
+ Next_Component_Or_Discriminant (Comp);
+ end loop;
+ end;
+ end if;
+ else
+ Error_Msg_N
+ ("case selector type having a non-discrete non-record"
+ & " non-array subcomponent type not implemented",
+ Expression (Case_Statement));
+ end if;
+ end Traverse_Discrete_Parts;
+
+ begin
+ Traverse_Discrete_Parts (Etype (Expression (Case_Statement)));
+ pragma Assert (Done or else Serious_Errors_Detected > 0);
+ return Result;
+ end Component_Bounds_Info;
+
+ Component_Bounds : constant Composite_Range_Info
+ := Component_Bounds_Info;
+
+ package Case_Bindings is
+
+ procedure Note_Binding
+ (Comp_Assoc : Node_Id;
+ Choice : Node_Id;
+ Alt : Node_Id);
+ -- Note_Binding is called once for each component association
+ -- that defines a binding (using either "A => B is X" or
+ -- "A => <X>" syntax);
+
+ procedure Check_Bindings;
+ -- After all calls to Note_Binding, check that bindings are
+ -- ok (e.g., check consistency among different choices of
+ -- one alternative).
+
+ end Case_Bindings;
+
+ procedure Refresh_Binding_Info (Aggr : Node_Id);
+ -- The parser records binding-related info in the tree.
+ -- The choice nodes that we see here might not be (will never be?)
+ -- the original nodes that were produced by the parser. The info
+ -- recorded by the parser is missing in that case, so this
+ -- procedure recovers it.
+ --
+ -- There are bugs here. In some cases involving nested aggregates,
+ -- the path back to the parser-created nodes is lost. In particular,
+ -- we may fail to detect an illegal case like
+ -- when (F1 | F2 => (Aa => Natural, Bb => Natural is X)) =>
+ -- This should be rejected because it is binding X to both the
+ -- F1.Bb and to the F2.Bb subcomponents of the case selector.
+ -- It would be nice if the not-specific-to-pattern-matching
+ -- aggregate-processing code could remain unaware of the existence
+ -- of this binding-related info but perhaps that isn't possible.
+
+ --------------------------
+ -- Refresh_Binding_Info --
+ --------------------------
+
+ procedure Refresh_Binding_Info (Aggr : Node_Id) is
+ Orig_Aggr : constant Node_Id := Original_Node (Aggr);
+ Orig_Comp : Node_Id := First (Component_Associations (Orig_Aggr));
+ begin
+ if Aggr = Orig_Aggr then
+ return;
+ end if;
+
+ while Present (Orig_Comp) loop
+ if Nkind (Orig_Comp) = N_Component_Association
+ and then Binding_Chars (Orig_Comp) /= No_Name
+ then
+ if List_Length (Choices (Orig_Comp)) /= 1 then
+ -- Conceivably this could be checked during parsing,
+ -- but checking is easier here.
+
+ Error_Msg_N
+ ("binding shared by multiple components", Orig_Comp);
+ return;
+ end if;
+
+ declare
+ Orig_Name : constant Name_Id :=
+ Chars (First (Choices (Orig_Comp)));
+ Comp : Node_Id := First (Component_Associations (Aggr));
+ Matching_Comp : Node_Id := Empty;
+ begin
+ while Present (Comp) loop
+ if Chars (First (Choices (Comp))) = Orig_Name then
+ pragma Assert (not Present (Matching_Comp));
+ Matching_Comp := Comp;
+ end if;
+
+ Next (Comp);
+ end loop;
+
+ pragma Assert (Present (Matching_Comp));
+
+ Set_Binding_Chars
+ (Matching_Comp,
+ Binding_Chars (Orig_Comp));
+ end;
+ end if;
+
+ Next (Orig_Comp);
+ end loop;
+ end Refresh_Binding_Info;
+
+ ------------------
+ -- Parse_Choice --
+ ------------------
+
+ function Parse_Choice (Choice : Node_Id;
+ Alt : Node_Id) return Choice_Range_Info
+ is
+ Result : Choice_Range_Info (Is_Others => False);
+ Ranges : Composite_Range_Info renames Result.Ranges;
+ Next_Part : Part_Id'Base range 1 .. Part_Id'Last + 1 := 1;
+
+ procedure Traverse_Choice (Expr : Node_Id);
+ -- Traverse a legal choice expression, looking for
+ -- values/ranges of discrete parts. Call Update_Result
+ -- for each.
+
+ procedure Update_Result (Discrete_Range : Discrete_Range_Info);
+ -- Initialize first remaining uninitialized element of Ranges.
+ -- Also set Next_Part.
+
+ procedure Update_Result_For_Full_Coverage (Comp_Type : Entity_Id);
+ -- For each scalar part of the given component type, call
+ -- Update_Result with the full range for that scalar part.
+ -- This is used for both box components in aggregates and
+ -- for any inactive-variant components that do not appear in
+ -- a given aggregate.
+
+ -------------------
+ -- Update_Result --
+ -------------------
+
+ procedure Update_Result (Discrete_Range : Discrete_Range_Info) is
+ begin
+ Ranges (Next_Part) := Discrete_Range;
+ Next_Part := Next_Part + 1;
+ end Update_Result;
+
+ -------------------------------------
+ -- Update_Result_For_Full_Coverage --
+ -------------------------------------
+
+ procedure Update_Result_For_Full_Coverage (Comp_Type : Entity_Id)
+ is
+ begin
+ for Counter in 1 .. Scalar_Part_Count (Comp_Type) loop
+ Update_Result (Component_Bounds (Next_Part));
+ end loop;
+ end Update_Result_For_Full_Coverage;
+
+ ---------------------
+ -- Traverse_Choice --
+ ---------------------
+
+ procedure Traverse_Choice (Expr : Node_Id) is
+ begin
+ if Nkind (Expr) = N_Qualified_Expression then
+ Traverse_Choice (Expression (Expr));
+
+ elsif Nkind (Expr) = N_Type_Conversion
+ and then not Comes_From_Source (Expr)
+ then
+ if Expr /= Original_Node (Expr) then
+ Traverse_Choice (Original_Node (Expr));
+ else
+ Traverse_Choice (Expression (Expr));
+ end if;
+
+ elsif Nkind (Expr) = N_Aggregate then
+ if Is_Record_Type (Etype (Expr)) then
+ Refresh_Binding_Info (Aggr => Expr);
+
+ declare
+ Comp_Assoc : Node_Id :=
+ First (Component_Associations (Expr));
+ -- Aggregate has been normalized (components in
+ -- order, only one component per choice, etc.).
+
+ Comp_From_Type : Node_Id :=
+ First_Component_Or_Discriminant
+ (Base_Type (Etype (Expr)));
+
+ Saved_Next_Part : constant Part_Id := Next_Part;
+ begin
+ while Present (Comp_Assoc) loop
+ pragma Assert
+ (List_Length (Choices (Comp_Assoc)) = 1);
+
+ declare
+ Comp : constant Node_Id :=
+ Entity (First (Choices (Comp_Assoc)));
+ Comp_Seen : Boolean := False;
+ begin
+ loop
+ if Original_Record_Component (Comp) =
+ Original_Record_Component (Comp_From_Type)
+ then
+ Comp_Seen := True;
+ else
+ -- We have an aggregate of a type that
+ -- has a variant part (or has a
+ -- subcomponent type that has a variant
+ -- part) and we have to deal with a
+ -- component that is present in the type
+ -- but not in the aggregate (because the
+ -- component is in an inactive variant).
+ --
+ Update_Result_For_Full_Coverage
+ (Comp_Type => Etype (Comp_From_Type));
+ end if;
+
+ Comp_From_Type :=
+ Next_Component_Or_Discriminant
+ (Comp_From_Type);
+
+ exit when Comp_Seen;
+ end loop;
+ end;
+
+ if Box_Present (Comp_Assoc) then
+ -- Box matches all values
+ Update_Result_For_Full_Coverage
+ (Etype (First (Choices (Comp_Assoc))));
+ else
+ Traverse_Choice (Expression (Comp_Assoc));
+ end if;
+
+ if Binding_Chars (Comp_Assoc) /= No_Name
+ then
+ Case_Bindings.Note_Binding
+ (Comp_Assoc => Comp_Assoc,
+ Choice => Choice,
+ Alt => Alt);
+ end if;
+
+ Next (Comp_Assoc);
+ end loop;
+
+ while Present (Comp_From_Type) loop
+ -- Deal with any trailing inactive-variant
+ -- components.
+ --
+ -- See earlier commment about calling
+ -- Update_Result_For_Full_Coverage for such
+ -- components.
+
+ Update_Result_For_Full_Coverage
+ (Comp_Type => Etype (Comp_From_Type));
+
+ Comp_From_Type :=
+ Next_Component_Or_Discriminant (Comp_From_Type);
+ end loop;
+
+ pragma Assert
+ (Nat (Next_Part - Saved_Next_Part)
+ = Scalar_Part_Count (Etype (Expr)));
+ end;
+ elsif Is_Array_Type (Etype (Expr)) then
+ if Is_Non_Empty_List (Component_Associations (Expr)) then
+ Error_Msg_N
+ ("non-positional array aggregate as/within case "
+ & "choice not implemented", Expr);
+ end if;
+
+ declare
+ Subexpr : Node_Id := First (Expressions (Expr));
+ begin
+ while Present (Subexpr) loop
+ Traverse_Choice (Subexpr);
+ Next (Subexpr);
+ end loop;
+ end;
+ else
+ raise Program_Error;
+ end if;
+ elsif Is_Discrete_Type (Etype (Expr)) then
+ if Nkind (Expr) in N_Has_Entity and then
+ Is_Type (Entity (Expr))
+ then
+ declare
+ Low : constant Node_Id :=
+ Type_Low_Bound (Entity (Expr));
+ High : constant Node_Id :=
+ Type_High_Bound (Entity (Expr));
+ begin
+ Update_Result ((Low => Expr_Value (Low),
+ High => Expr_Value (High)));
+ end;
+ else
+ pragma Assert (Compile_Time_Known_Value (Expr));
+ Update_Result ((Low | High => Expr_Value (Expr)));
+ end if;
+ else
+ Error_Msg_N
+ ("non-aggregate case choice subexpression which is not"
+ & " of a discrete type not implemented", Expr);
+ end if;
+ end Traverse_Choice;
+
+ -- Start of processing for Parse_Choice
+
+ begin
+ if Nkind (Choice) = N_Others_Choice then
+ return (Is_Others => True);
+ end if;
+ Traverse_Choice (Choice);
+
+ -- Avoid returning uninitialized garbage in error case
+ if Next_Part /= Part_Id'Last + 1 then
+ pragma Assert (Serious_Errors_Detected > 0);
+ Result.Ranges := (others => (Low => Uint_1, High => Uint_0));
+ end if;
+
+ return Result;
+ end Parse_Choice;
+
+ package body Case_Bindings is
+
+ type Binding is record
+ Comp_Assoc : Node_Id;
+ Choice : Node_Id;
+ Alt : Node_Id;
+ end record;
+
+ type Binding_Index is new Natural;
+
+ package Case_Bindings_Table is new Table.Table
+ (Table_Component_Type => Binding,
+ Table_Index_Type => Binding_Index,
+ Table_Low_Bound => 1,
+ Table_Initial => 16,
+ Table_Increment => 64,
+ Table_Name => "Composite_Case_Ops.Case_Bindings");
+
+ ------------------
+ -- Note_Binding --
+ ------------------
+
+ procedure Note_Binding
+ (Comp_Assoc : Node_Id;
+ Choice : Node_Id;
+ Alt : Node_Id)
+ is
+ begin
+ Case_Bindings_Table.Append
+ ((Comp_Assoc => Comp_Assoc,
+ Choice => Choice,
+ Alt => Alt));
+ end Note_Binding;
+
+ --------------------
+ -- Check_Bindings --
+ --------------------
+
+ procedure Check_Bindings
+ is
+ use Case_Bindings_Table;
+ begin
+ if Last = 0 then
+ -- no bindings to check
+ return;
+ end if;
+
+ declare
+ Tab : Table_Type
+ renames Case_Bindings_Table.Table (1 .. Last);
+
+ function Same_Id (Idx1, Idx2 : Binding_Index)
+ return Boolean is (
+ Binding_Chars (Tab (Idx1).Comp_Assoc) =
+ Binding_Chars (Tab (Idx2).Comp_Assoc));
+
+ function Binding_Subtype (Idx : Binding_Index)
+ return Entity_Id is
+ (Etype (Nlists.First (Choices (Tab (Idx).Comp_Assoc))));
+ begin
+ -- Verify that elements with given choice or alt value
+ -- are contiguous, and that elements with equal
+ -- choice values have same alt value.
+
+ for Idx1 in 2 .. Tab'Last loop
+ if Tab (Idx1 - 1).Choice /= Tab (Idx1).Choice then
+ pragma Assert
+ (for all Idx2 in Idx1 + 1 .. Tab'Last =>
+ Tab (Idx2).Choice /= Tab (Idx1 - 1).Choice);
+ else
+ pragma Assert (Tab (Idx1 - 1).Alt = Tab (Idx1).Alt);
+ end if;
+ if Tab (Idx1 - 1).Alt /= Tab (Idx1).Alt then
+ pragma Assert
+ (for all Idx2 in Idx1 + 1 .. Tab'Last =>
+ Tab (Idx2).Alt /= Tab (Idx1 - 1).Alt);
+ end if;
+ end loop;
+
+ -- Check for user errors:
+ -- 1) Two choices for a given alternative shall define the
+ -- same set of names. Can't have
+ -- when (<X>, 0) | (0, <Y>) =>
+ -- 2) A choice shall not define a name twice. Can't have
+ -- when (A => <X>, B => <X>, C => 0) =>
+ -- 3) Two definitions of a name within one alternative
+ -- shall have statically matching component subtypes.
+ -- Can't have
+ -- type R is record Int : Integer;
+ -- Nat : Natural; end record;
+ -- case R'(...) is
+ -- when (<X>, 1) | (1, <X>) =>
+ -- 4) A given binding shall match only one value.
+ -- Can't have
+ -- (Fld1 | Fld2 => (Fld => <X>))
+ -- For now, this is enforced *very* conservatively
+ -- with respect to arrays - a binding cannot match
+ -- any part of an array. This is temporary.
+
+ for Idx1 in Tab'Range loop
+ if Idx1 = 1
+ or else Tab (Idx1 - 1).Alt /= Tab (Idx1).Alt
+ then
+ -- Process one alternative
+ declare
+ Alt_Start : constant Binding_Index := Idx1;
+ Alt : constant Node_Id := Tab (Alt_Start).Alt;
+
+ First_Choice : constant Node_Id :=
+ Nlists.First (Discrete_Choices (Alt));
+ First_Choice_Bindings : Natural := 0;
+ begin
+ -- Check for duplicates within one choice,
+ -- and for choices with no bindings.
+
+ if First_Choice /= Tab (Alt_Start).Choice then
+ Error_Msg_N ("binding(s) missing for choice",
+ First_Choice);
+ return;
+ end if;
+
+ declare
+ Current_Choice : Node_Id := First_Choice;
+ Choice_Start : Binding_Index := Alt_Start;
+ begin
+ for Idx2 in Alt_Start .. Tab'Last loop
+ exit when Tab (Idx2).Alt /= Alt;
+ if Tab (Idx2).Choice = Current_Choice then
+ for Idx3 in Choice_Start .. Idx2 - 1 loop
+ if Same_Id (Idx2, Idx3)
+ then
+ Error_Msg_N
+ ("duplicate binding in choice",
+ Current_Choice);
+ return;
+ end if;
+ end loop;
+ else
+ Next (Current_Choice);
+ pragma Assert (Present (Current_Choice));
+ Choice_Start := Idx2;
+
+ if Tab (Idx2).Choice /= Current_Choice
+ then
+ Error_Msg_N
+ ("binding(s) missing for choice",
+ Current_Choice);
+ return;
+ end if;
+ end if;
+ end loop;
+
+ -- If we made it through all the bindings
+ -- for this alternative but didn't make it
+ -- to the last choice, then bindings are
+ -- missing for all remaining choices.
+ -- We only complain about the first one.
+
+ if Present (Next (Current_Choice)) then
+ Error_Msg_N
+ ("binding(s) missing for choice",
+ Next (Current_Choice));
+ return;
+ end if;
+ end;
+
+ -- Count bindings for first choice of alternative
+
+ for FC_Idx in Alt_Start .. Tab'Last loop
+ exit when Tab (FC_Idx).Choice /= First_Choice;
+ First_Choice_Bindings :=
+ First_Choice_Bindings + 1;
+ end loop;
+
+ declare
+ Current_Choice : Node_Id := First_Choice;
+ Current_Choice_Bindings : Natural := 0;
+ begin
+ for Idx2 in Alt_Start .. Tab'Last loop
+ exit when Tab (Idx2).Alt /= Alt;
+
+ -- If starting a new choice
+
+ if Tab (Idx2).Choice /= Current_Choice then
+
+ -- Check count for choice just finished
+
+ if Current_Choice_Bindings
+ /= First_Choice_Bindings
+ then
+ Error_Msg_N
+ ("subsequent choice has different"
+ & " number of bindings than first"
+ & " choice", Current_Choice);
+ end if;
+
+ Current_Choice := Tab (Idx2).Choice;
+ Current_Choice_Bindings := 1;
+
+ -- Remember that Alt has both one or more
+ -- bindings and two or more choices; we'll
+ -- need to know this during expansion.
+
+ Set_Multidefined_Bindings (Alt, True);
+ else
+ Current_Choice_Bindings :=
+ Current_Choice_Bindings + 1;
+ end if;
+
+ -- Check that first choice has binding with
+ -- matching name; check subtype consistency.
+
+ declare
+ Found : Boolean := False;
+ begin
+ for FC_Idx in
+ Alt_Start ..
+ Alt_Start + Binding_Index
+ (First_Choice_Bindings - 1)
+ loop
+ if Same_Id (Idx2, FC_Idx) then
+ if not Subtypes_Statically_Match
+ (Binding_Subtype (Idx2),
+ Binding_Subtype (FC_Idx))
+ then
+ Error_Msg_N
+ ("subtype of binding in "
+ & "subsequent choice does not "
+ & "match that in first choice",
+ Tab (Idx2).Comp_Assoc);
+ end if;
+ Found := True;
+ exit;
+ end if;
+ end loop;
+
+ if not Found then
+ Error_Msg_N
+ ("binding defined in subsequent "
+ & "choice not defined in first "
+ & "choice", Current_Choice);
+ end if;
+ end;
+
+ -- Check for illegal repeated binding
+ -- via an enclosing aggregate, as in
+ -- (F1 | F2 => (F3 => Natural is X,
+ -- F4 => Natural))
+ -- where the inner aggregate would be ok.
+
+ declare
+ Rover : Node_Id := Tab (Idx2).Comp_Assoc;
+ begin
+ while Rover /= Tab (Idx2).Choice loop
+ Rover :=
+ (if Is_List_Member (Rover) then
+ Parent (List_Containing (Rover))
+ else Parent (Rover));
+ pragma Assert (Present (Rover));
+ if Nkind (Rover)
+ = N_Component_Association
+ and then List_Length (Choices (Rover))
+ > 1
+ then
+ Error_Msg_N
+ ("binding shared by multiple "
+ & "enclosing components",
+ Tab (Idx2).Comp_Assoc);
+ end if;
+ end loop;
+ end;
+ end loop;
+ end;
+
+ -- Construct the (unanalyzed) declarations for
+ -- the current alternative. Then analyze them.
+
+ if First_Choice_Bindings > 0 then
+ declare
+ Loc : constant Source_Ptr := Sloc (Alt);
+ Declarations : constant List_Id := New_List;
+ Decl : Node_Id;
+ begin
+ for FC_Idx in
+ Alt_Start ..
+ Alt_Start +
+ Binding_Index (First_Choice_Bindings - 1)
+ loop
+ Decl := Make_Object_Declaration
+ (Sloc => Loc,
+ Defining_Identifier =>
+ Make_Defining_Identifier
+ (Loc,
+ Binding_Chars
+ (Tab (FC_Idx).Comp_Assoc)),
+ Object_Definition =>
+ New_Occurrence_Of
+ (Binding_Subtype (FC_Idx), Loc));
+
+ Append_To (Declarations, Decl);
+ end loop;
+
+ declare
+ Old_Statements : constant List_Id :=
+ Statements (Alt);
+ New_Statements : constant List_Id :=
+ New_List;
+
+ Block_Statement : constant Node_Id :=
+ Make_Block_Statement (Sloc => Loc,
+ Declarations => Declarations,
+ Handled_Statement_Sequence =>
+ Make_Handled_Sequence_Of_Statements
+ (Loc, Old_Statements),
+ Has_Created_Identifier => True);
+ begin
+ Append_To
+ (New_Statements, Block_Statement);
+
+ Set_Statements (Alt, New_Statements);
+ end;
+ end;
+ end if;
+ end;
+ end if;
+ end loop;
+ end;
+ end Check_Bindings;
+ end Case_Bindings;
+
+ function Choice_Bounds_Info return Choices_Range_Info;
+ -- Returns mapping from any given Choice_Id value to that choice's
+ -- component-to-range map.
+
+ ------------------------
+ -- Choice_Bounds_Info --
+ ------------------------
+
+ function Choice_Bounds_Info return Choices_Range_Info is
+ Result : Choices_Range_Info;
+ Alt : Node_Id := First (Alternatives (Case_Statement));
+ C_Id : Choice_Id := 1;
+ begin
+ while Present (Alt) loop
+ declare
+ Choice : Node_Id := First (Discrete_Choices (Alt));
+ begin
+ while Present (Choice) loop
+ Result (C_Id) := Parse_Choice (Choice, Alt => Alt);
+
+ Next (Choice);
+ if C_Id /= Choice_Id'Last then
+ C_Id := C_Id + 1;
+ end if;
+ end loop;
+ end;
+ Next (Alt);
+ end loop;
+
+ pragma Assert (C_Id = Choice_Id'Last);
+
+ -- No more calls to Note_Binding, so time for checks.
+ Case_Bindings.Check_Bindings;
+
+ return Result;
+ end Choice_Bounds_Info;
+
+ Choices_Bounds : constant Choices_Range_Info := Choice_Bounds_Info;
+
+ package body Value_Sets is
+ use GNAT;
+
+ function Hash (Key : Uint) return Bucket_Range_Type is
+ (Bucket_Range_Type
+ (UI_To_Int (Key mod (Uint_2 ** Uint_31))));
+
+ package Uint_Sets is new GNAT.Sets.Membership_Sets
+ (Uint, "=", Hash);
+
+ type Representative_Values_Array is
+ array (Part_Id) of Uint_Sets.Membership_Set;
+
+ function Representative_Values_Init
+ return Representative_Values_Array;
+ -- Select the representative values for each Part_Id value.
+ -- This function is called exactly once, immediately after it
+ -- is declared.
+
+ --------------------------------
+ -- Representative_Values_Init --
+ --------------------------------
+
+ function Representative_Values_Init
+ return Representative_Values_Array
+ is
+ -- For each range of each choice (as well as the range for the
+ -- component subtype, which is handled in the first loop),
+ -- insert the low bound of the range and the successor of
+ -- the high bound into the corresponding R_V element.
+ --
+ -- The idea we are trying to capture here is somewhat tricky.
+ -- Given an arbitrary point P1 in the Cartesian product
+ -- of the Component_Bounds sets, we want to be able
+ -- to map that to a point P2 in the (smaller) Cartesian product
+ -- of the Representative_Values sets that has the property
+ -- that for every choice of the case statement, P1 matches
+ -- the choice if and only if P2 also matches. Given that,
+ -- we can implement the overlapping/containment/etc. rules
+ -- safely by just looking at (using brute force enumeration)
+ -- the (smaller) Cartesian product of the R_V sets.
+ -- We are never going to actually perform this point-to-point
+ -- mapping - just the fact that it exists is enough to ensure
+ -- we can safely look at just the R_V sets.
+ --
+ -- The desired mapping can be implemented by mapping a point
+ -- P1 to a point P2 by reducing each of P1's coordinates down
+ -- to the largest element of the corresponding R_V set that is
+ -- less than or equal to the original coordinate value (such
+ -- an element Y will always exist because the R_V set for a
+ -- given component always includes the low bound of the
+ -- component subtype). It then suffices to show that every
+ -- choice in the case statement yields the same Boolean result
+ -- for P1 as for P2.
+ --
+ -- Suppose the contrary. Then there is some particular
+ -- coordinate position X (i.e., a Part_Id value) and some
+ -- choice C where exactly one of P1(X) and P2(X) belongs to
+ -- the (contiguous) range associated with C(X); call that
+ -- range L .. H. We know that P2(X) <= P1(X) because the
+ -- mapping never increases coordinate values. Consider three
+ -- cases: P1(X) lies within the L .. H range, or it is greater
+ -- than H, or it is lower than L.
+ -- The third case is impossible because reducing a value that
+ -- is less than L can only produce another such value,
+ -- violating the "exactly one" assumption. The second
+ -- case is impossible because L belongs to the corresponding
+ -- R_V set, so P2(X) >= L and both values belong to the
+ -- range, again violating the "exactly one" assumption.
+ -- Finally, the third case is impossible because H+1 belongs
+ -- to the corresponding R_V set, so P2(X) > H, so neither
+ -- value belongs to the range, again violating the "exactly
+ -- one" assumption. So our initial supposition was wrong. QED.
+
+ use Uint_Sets;
+
+ Result : constant Representative_Values_Array
+ := (others => Uint_Sets.Create (Initial_Size => 32));
+
+ procedure Insert_Representative (Value : Uint; P : Part_Id);
+ -- Insert the given Value into the representative values set
+ -- for the given component if it belongs to the component's
+ -- subtype. Otherwise, do nothing.
+
+ ---------------------------
+ -- Insert_Representative --
+ ---------------------------
+
+ procedure Insert_Representative (Value : Uint; P : Part_Id) is
+ begin
+ if Value >= Component_Bounds (P).Low and
+ Value <= Component_Bounds (P).High
+ then
+ Insert (Result (P), Value);
+ end if;
+ end Insert_Representative;
+
+ begin
+ for P in Part_Id loop
+ Insert_Representative (Component_Bounds (P).Low, P);
+ end loop;
+ for C of Choices_Bounds loop
+ if not C.Is_Others then
+ for P in Part_Id loop
+ if C.Ranges (P).Low <= C.Ranges (P).High then
+ Insert_Representative (C.Ranges (P).Low, P);
+ Insert_Representative (C.Ranges (P).High + 1, P);
+ end if;
+ end loop;
+ end if;
+ end loop;
+ return Result;
+ end Representative_Values_Init;
+
+ Representative_Values : constant Representative_Values_Array
+ := Representative_Values_Init;
+ -- We want to avoid looking at every point in the Cartesian
+ -- product of all component values. Instead we select, for each
+ -- component, a set of representative values and then look only
+ -- at the Cartesian product of those sets. A single value can
+ -- safely represent a larger enclosing interval if every choice
+ -- for that component either completely includes or completely
+ -- excludes the interval. The elements of this array will be
+ -- populated by a call to Initialize_Representative_Values and
+ -- will remain constant after that.
+
+ type Value_Index_Base is new Natural;
+
+ function Value_Index_Count return Value_Index_Base;
+ -- Returns the product of the sizes of the Representative_Values
+ -- sets (i.e., the size of the Cartesian product of the sets).
+ -- May return zero if one of the sets is empty.
+ -- This function is called exactly once, immediately after it
+ -- is declared.
+
+ -----------------------
+ -- Value_Index_Count --
+ -----------------------
+
+ function Value_Index_Count return Value_Index_Base is
+ Result : Value_Index_Base := 1;
+ begin
+ for Set of Representative_Values loop
+ Result := Result * Value_Index_Base (Uint_Sets.Size (Set));
+ end loop;
+ return Result;
+ end Value_Index_Count;
+
+ Max_Value_Index : constant Value_Index_Base := Value_Index_Count;
+
+ subtype Value_Index is Value_Index_Base range 1 .. Max_Value_Index;
+ type Value_Index_Set is array (Value_Index) of Boolean;
+
+ package Value_Index_Set_Table is new Table.Table
+ (Table_Component_Type => Value_Index_Set,
+ Table_Index_Type => Value_Set,
+ Table_Low_Bound => 1,
+ Table_Initial => 16,
+ Table_Increment => 100,
+ Table_Name => "Composite_Case_Ops.Value_Sets");
+ -- A nonzero Value_Set value is an index into this table.
+
+ function Indexed (Index : Value_Set) return Value_Index_Set
+ is (Value_Index_Set_Table.Table.all (Index));
+
+ function Allocate_Table_Element (Initial_Value : Value_Index_Set)
+ return Value_Set;
+ -- Allocate and initialize a new table element; return its index.
+
+ ----------------------------
+ -- Allocate_Table_Element --
+ ----------------------------
+
+ function Allocate_Table_Element (Initial_Value : Value_Index_Set)
+ return Value_Set
+ is
+ use Value_Index_Set_Table;
+ begin
+ Append (Initial_Value);
+ return Last;
+ end Allocate_Table_Element;
+
+ procedure Assign_Table_Element (Index : Value_Set;
+ Value : Value_Index_Set);
+ -- Assign specified value to specified table element.
+
+ --------------------------
+ -- Assign_Table_Element --
+ --------------------------
+
+ procedure Assign_Table_Element (Index : Value_Set;
+ Value : Value_Index_Set)
+ is
+ begin
+ Value_Index_Set_Table.Table.all (Index) := Value;
+ end Assign_Table_Element;
+
+ -------------
+ -- Compare --
+ -------------
+
+ function Compare (S1, S2 : Value_Set) return Set_Comparison is
+ begin
+ if S1 = Empty or S2 = Empty then
+ return Disjoint;
+ elsif Indexed (S1) = Indexed (S2) then
+ return Equal;
+ else
+ declare
+ Intersection : constant Value_Index_Set
+ := Indexed (S1) and Indexed (S2);
+ begin
+ if (for all Flag of Intersection => not Flag) then
+ return Disjoint;
+ elsif Intersection = Indexed (S1) then
+ return Contained_By;
+ elsif Intersection = Indexed (S2) then
+ return Contains;
+ else
+ return Overlaps;
+ end if;
+ end;
+ end if;
+ end Compare;
+
+ -------------------------
+ -- Complement_Is_Empty --
+ -------------------------
+
+ function Complement_Is_Empty (Set : Value_Set) return Boolean
+ is (Set /= Empty
+ and then (for all Flag of Indexed (Set) => Flag));
+
+ ---------------------
+ -- Free_Value_Sets --
+ ---------------------
+ procedure Free_Value_Sets is
+ begin
+ Value_Index_Set_Table.Free;
+ end Free_Value_Sets;
+
+ -----------
+ -- Union --
+ -----------
+
+ procedure Union (Target : in out Value_Set; Source : Value_Set) is
+ begin
+ if Source /= Empty then
+ if Target = Empty then
+ Target := Allocate_Table_Element (Indexed (Source));
+ else
+ Assign_Table_Element
+ (Target, Indexed (Target) or Indexed (Source));
+ end if;
+ end if;
+ end Union;
+
+ ------------
+ -- Remove --
+ ------------
+
+ procedure Remove (Target : in out Value_Set; Source : Value_Set) is
+ begin
+ if Source /= Empty and Target /= Empty then
+ Assign_Table_Element
+ (Target, Indexed (Target) and not Indexed (Source));
+ if (for all V of Indexed (Target) => not V) then
+ Target := Empty;
+ end if;
+ end if;
+ end Remove;
+
+ ---------------------
+ -- Matching_Values --
+ ---------------------
+
+ function Matching_Values
+ (Info : Composite_Range_Info) return Value_Set
+ is
+ Matches : Value_Index_Set;
+ Next_Index : Value_Index := 1;
+ Done : Boolean := False;
+ Point : array (Part_Id) of Uint;
+
+ procedure Test_Point_For_Match;
+ -- Point identifies a point in the Cartesian product of the
+ -- representative value sets. Record whether that Point
+ -- belongs to the product-of-ranges specified by Info.
+
+ --------------------------
+ -- Test_Point_For_Match --
+ --------------------------
+
+ procedure Test_Point_For_Match is
+ function In_Range (Val : Uint; Rang : Discrete_Range_Info)
+ return Boolean is
+ ((Rang.Low <= Val) and then (Val <= Rang.High));
+ begin
+ pragma Assert (not Done);
+ Matches (Next_Index) :=
+ (for all P in Part_Id => In_Range (Point (P), Info (P)));
+ if Next_Index = Matches'Last then
+ Done := True;
+ else
+ Next_Index := Next_Index + 1;
+ end if;
+ end Test_Point_For_Match;
+
+ procedure Test_Points (P : Part_Id);
+ -- Iterate over the Cartesian product of the representative
+ -- value sets, calling Test_Point_For_Match for each point.
+
+ -----------------
+ -- Test_Points --
+ -----------------
+
+ procedure Test_Points (P : Part_Id) is
+ use Uint_Sets;
+ Iter : Iterator := Iterate (Representative_Values (P));
+ begin
+ -- We could traverse here in sorted order, as opposed to
+ -- whatever order the set iterator gives us.
+ -- No need for that as long as every iteration over
+ -- a given representative values set yields the same order.
+ -- Not sorting is more efficient, but it makes it harder to
+ -- interpret a Value_Index_Set bit vector when debugging.
+
+ while Has_Next (Iter) loop
+ Next (Iter, Point (P));
+
+ -- If we have finished building up a Point value, then
+ -- test it for matching. Otherwise, recurse to continue
+ -- building up a point value.
+
+ if P = Part_Id'Last then
+ Test_Point_For_Match;
+ else
+ Test_Points (P + 1);
+ end if;
+ end loop;
+ end Test_Points;
+
+ begin
+ Test_Points (1);
+ if (for all Flag of Matches => not Flag) then
+ return Empty;
+ end if;
+ return Allocate_Table_Element (Matches);
+ end Matching_Values;
+
+ end Value_Sets;
+
+ --------------
+ -- Analysis --
+ --------------
+
+ function Analysis return Choices_Info is
+ Result : Choices_Info;
+ Alt : Node_Id := First (Alternatives (Case_Statement));
+ A_Id : Alternative_Id := 1;
+ C_Id : Choice_Id := 1;
+ begin
+ while Present (Alt) loop
+ declare
+ Choice : Node_Id := First (Discrete_Choices (Alt));
+ begin
+ while Present (Choice) loop
+ if Nkind (Choice) = N_Others_Choice then
+ pragma Assert (Choices_Bounds (C_Id).Is_Others);
+ Result (C_Id) :=
+ (Alternative => A_Id,
+ Is_Others => True);
+ else
+ Result (C_Id) :=
+ (Alternative => A_Id,
+ Is_Others => False,
+ Matches => Value_Sets.Matching_Values
+ (Choices_Bounds (C_Id).Ranges));
+ end if;
+ Next (Choice);
+ if C_Id /= Choice_Id'Last then
+ C_Id := C_Id + 1;
+ end if;
+ end loop;
+ end;
+
+ Next (Alt);
+ if A_Id /= Alternative_Id'Last then
+ A_Id := A_Id + 1;
+ end if;
+ end loop;
+
+ pragma Assert (A_Id = Alternative_Id'Last);
+ pragma Assert (C_Id = Choice_Id'Last);
+
+ return Result;
+ end Analysis;
+
+ end Choice_Analysis;
+
+ end Composite_Case_Ops;
+
--------------------------
-- Expand_Others_Choice --
--------------------------
@@ -1065,9 +2447,10 @@ package body Sem_Case is
if Is_Standard_Character_Type (Choice_Type) then
Set_Character_Literal_Name (Char_Code (UI_To_Int (Value)));
- Lit := New_Node (N_Character_Literal, Loc);
- Set_Chars (Lit, Name_Find);
- Set_Char_Literal_Value (Lit, Value);
+ Lit :=
+ Make_Character_Literal (Loc,
+ Chars => Name_Find,
+ Char_Literal_Value => Value);
Set_Etype (Lit, Choice_Type);
Set_Is_Static_Expression (Lit, True);
return Lit;
@@ -1315,10 +2698,10 @@ package body Sem_Case is
-------------------
procedure Check_Choices
- (N : Node_Id;
- Alternatives : List_Id;
- Subtyp : Entity_Id;
- Others_Present : out Boolean)
+ (N : Node_Id;
+ Alternatives : List_Id;
+ Subtyp : Entity_Id;
+ Others_Present : out Boolean)
is
E : Entity_Id;
@@ -1370,6 +2753,15 @@ package body Sem_Case is
-- later entry into the choices table so that they can be sorted
-- later on.
+ procedure Check_Case_Pattern_Choices;
+ -- Check choices validity for the Ada extension case where the
+ -- selecting expression is not of a discrete type and so the
+ -- choices are patterns.
+
+ procedure Check_Composite_Case_Selector;
+ -- Check that the (non-discrete) type of the expression being
+ -- cased on is suitable.
+
procedure Handle_Static_Predicate
(Typ : Entity_Id;
Lo : Node_Id;
@@ -1491,6 +2883,209 @@ package body Sem_Case is
Num_Choices := Num_Choices + 1;
end Check;
+ --------------------------------
+ -- Check_Case_Pattern_Choices --
+ --------------------------------
+
+ procedure Check_Case_Pattern_Choices is
+ -- ??? Need to Free/Finalize value sets allocated here.
+
+ package Ops is new Composite_Case_Ops.Choice_Analysis
+ (Case_Statement => N);
+ use Ops;
+ use Ops.Value_Sets;
+
+ Empty : Value_Set renames Value_Sets.Empty;
+ -- Cope with hiding due to multiple use clauses
+
+ Info : constant Choices_Info := Analysis;
+ Others_Seen : Boolean := False;
+
+ begin
+ declare
+ Matches : array (Alternative_Id) of Value_Sets.Value_Set :=
+ (others => Empty);
+
+ Flag_Overlapping_Within_One_Alternative : constant Boolean :=
+ False;
+ -- We may want to flag overlapping (perhaps with only a
+ -- warning) if the pattern binds an identifier, as in
+ -- when (Positive, <X>) | (Integer, <X>) =>
+
+ Covered : Value_Set := Empty;
+ -- The union of all alternatives seen so far
+
+ begin
+ for Choice of Info loop
+ if Choice.Is_Others then
+ Others_Seen := True;
+ else
+ if Flag_Overlapping_Within_One_Alternative
+ and then (Compare (Matches (Choice.Alternative),
+ Choice.Matches) /= Disjoint)
+ then
+ Error_Msg_N
+ ("bad overlapping within one alternative", N);
+ end if;
+
+ Union (Target => Matches (Choice.Alternative),
+ Source => Choice.Matches);
+ end if;
+ end loop;
+
+ for A1 in Alternative_Id loop
+ for A2 in Alternative_Id
+ range A1 + 1 .. Alternative_Id'Last
+ loop
+ case Compare (Matches (A1), Matches (A2)) is
+ when Disjoint | Contained_By =>
+ null; -- OK
+ when Overlaps =>
+ declare
+ Uncovered_1, Uncovered_2 : Value_Set := Empty;
+ begin
+ Union (Uncovered_1, Matches (A1));
+ Remove (Uncovered_1, Covered);
+ Union (Uncovered_2, Matches (A2));
+ Remove (Uncovered_2, Covered);
+
+ -- Recheck for overlap after removing choices
+ -- covered by earlier alternatives.
+
+ case Compare (Uncovered_1, Uncovered_2) is
+ when Disjoint | Contained_By =>
+ null;
+ when Contains | Overlaps | Equal =>
+ Error_Msg_N
+ ("bad alternative overlapping", N);
+ end case;
+ end;
+
+ when Equal =>
+ Error_Msg_N ("alternatives match same values", N);
+ when Contains =>
+ Error_Msg_N ("alternatives in wrong order", N);
+ end case;
+ end loop;
+
+ Union (Target => Covered, Source => Matches (A1));
+ end loop;
+
+ if (not Others_Seen) and then not Complement_Is_Empty (Covered)
+ then
+ Error_Msg_N ("not all values are covered", N);
+ end if;
+ end;
+
+ Ops.Value_Sets.Free_Value_Sets;
+ end Check_Case_Pattern_Choices;
+
+ -----------------------------------
+ -- Check_Composite_Case_Selector --
+ -----------------------------------
+
+ procedure Check_Composite_Case_Selector is
+ -- Some of these restrictions will be relaxed eventually, but best
+ -- to initially err in the direction of being too restrictive.
+
+ procedure Check_Component_Subtype (Subtyp : Entity_Id);
+ -- Recursively traverse subcomponent types to perform checks.
+
+ -----------------------------
+ -- Check_Component_Subtype --
+ -----------------------------
+
+ procedure Check_Component_Subtype (Subtyp : Entity_Id) is
+ begin
+ if Has_Predicates (Subtyp) then
+ Error_Msg_N
+ ("subtype of case selector (or subcomponent thereof) " &
+ "has predicate", N);
+ elsif Is_Discrete_Type (Subtyp) then
+ if not Is_Static_Subtype (Subtyp) then
+ Error_Msg_N
+ ("discrete subtype of selector subcomponent is not " &
+ "a static subtype", N);
+ elsif Is_Enumeration_Type (Subtyp)
+ and then Has_Enumeration_Rep_Clause (Subtyp)
+ then
+ Error_Msg_N
+ ("enumeration type of selector subcomponent has " &
+ "an enumeration representation clause", N);
+ end if;
+ elsif Is_Array_Type (Subtyp) then
+ pragma Assert (Is_Constrained (Subtyp));
+
+ if Number_Dimensions (Subtyp) /= 1 then
+ Error_Msg_N
+ ("dimensionality of array type of case selector (or " &
+ "subcomponent thereof) is greater than 1", N);
+ elsif not Is_OK_Static_Range (First_Index (Subtyp)) then
+ Error_Msg_N
+ ("array subtype of case selector (or " &
+ "subcomponent thereof) has nonstatic constraint", N);
+ end if;
+ Check_Component_Subtype (Component_Type (Subtyp));
+ elsif Is_Record_Type (Subtyp) then
+
+ if Has_Discriminants (Subtyp)
+ and then Is_Constrained (Subtyp)
+ and then not Has_Static_Discriminant_Constraint (Subtyp)
+ then
+ -- We are only disallowing nonstatic constraints for
+ -- subcomponent subtypes, not for the subtype of the
+ -- expression we are casing on. This test could be
+ -- implemented via an Is_Recursive_Call parameter if
+ -- that seems preferable.
+
+ if Subtyp /= Check_Choices.Subtyp then
+ Error_Msg_N
+ ("constrained discriminated subtype of case " &
+ "selector subcomponent has nonstatic " &
+ "constraint", N);
+ end if;
+ end if;
+
+ declare
+ Comp : Entity_Id :=
+ First_Component_Or_Discriminant (Base_Type (Subtyp));
+ begin
+ while Present (Comp) loop
+ Check_Component_Subtype (Etype (Comp));
+ Next_Component_Or_Discriminant (Comp);
+ end loop;
+ end;
+ else
+ Error_Msg_N
+ ("type of case selector (or subcomponent thereof) is " &
+ "not a discrete type, a record type, or an array type",
+ N);
+ end if;
+ end Check_Component_Subtype;
+
+ begin
+ if not Is_Composite_Type (Subtyp) then
+ Error_Msg_N
+ ("case selector type neither discrete nor composite", N);
+
+ elsif Is_Limited_Type (Subtyp) then
+ Error_Msg_N ("case selector type is limited", N);
+
+ elsif Is_Class_Wide_Type (Subtyp) then
+ Error_Msg_N ("case selector type is class-wide", N);
+
+ elsif Needs_Finalization (Subtyp) then
+ Error_Msg_N ("case selector type requires finalization", N);
+
+ elsif Is_Array_Type (Subtyp) and not Is_Constrained (Subtyp) then
+ Error_Msg_N
+ ("case selector subtype is unconstrained array subtype", N);
+
+ else
+ Check_Component_Subtype (Subtyp);
+ end if;
+ end Check_Composite_Case_Selector;
+
-----------------------------
-- Handle_Static_Predicate --
-----------------------------
@@ -1523,6 +3118,7 @@ package body Sem_Case is
then
C := New_Copy (P);
Set_Sloc (C, Sloc (Choice));
+ Set_Original_Node (C, Choice);
if Expr_Value (Low_Bound (C)) < Expr_Value (Lo) then
Set_Low_Bound (C, Lo);
@@ -1552,6 +3148,14 @@ package body Sem_Case is
-- a complete mess.
if not Is_Discrete_Type (Subtyp) or else Subtyp = Any_Type then
+
+ -- Hold on, maybe it isn't a complete mess after all.
+
+ if Extensions_Allowed and then Subtyp /= Any_Type then
+ Check_Composite_Case_Selector;
+ Check_Case_Pattern_Choices;
+ end if;
+
return;
end if;
@@ -1559,7 +3163,7 @@ package body Sem_Case is
-- bounds of its base type to determine the values covered by the
-- discrete choices.
- -- In Ada 2012, if the subtype has a non-static predicate the full
+ -- In Ada 2012, if the subtype has a nonstatic predicate the full
-- range of the base type must be covered as well.
if Is_OK_Static_Subtype (Subtyp) then
@@ -1576,7 +3180,7 @@ package body Sem_Case is
end if;
-- Obtain static bounds of type, unless this is a generic formal
- -- discrete type for which all choices will be non-static.
+ -- discrete type for which all choices will be nonstatic.
if not Is_Generic_Type (Root_Type (Bounds_Type))
or else Ekind (Bounds_Type) /= E_Enumeration_Type
@@ -1638,7 +3242,7 @@ package body Sem_Case is
if Has_Predicates (E) then
- -- Use of non-static predicate is an error
+ -- Use of nonstatic predicate is an error
if not Is_Discrete_Type (E)
or else not Has_Static_Predicate (E)
@@ -1799,4 +3403,61 @@ package body Sem_Case is
end Generic_Check_Choices;
+ -----------------------------------------
+ -- Has_Static_Discriminant_Constraint --
+ -----------------------------------------
+
+ function Has_Static_Discriminant_Constraint
+ (Subtyp : Entity_Id) return Boolean
+ is
+ begin
+ if Has_Discriminants (Subtyp) and then Is_Constrained (Subtyp) then
+ declare
+ DC_Elmt : Elmt_Id := First_Elmt (Discriminant_Constraint (Subtyp));
+ begin
+ while Present (DC_Elmt) loop
+ if not All_Composite_Constraints_Static (Node (DC_Elmt)) then
+ return False;
+ end if;
+ Next_Elmt (DC_Elmt);
+ end loop;
+ return True;
+ end;
+ end if;
+ return False;
+ end Has_Static_Discriminant_Constraint;
+
+ ----------------------------
+ -- Is_Case_Choice_Pattern --
+ ----------------------------
+
+ function Is_Case_Choice_Pattern (Expr : Node_Id) return Boolean is
+ E : Node_Id := Expr;
+ begin
+ if not Extensions_Allowed then
+ return False;
+ end if;
+
+ loop
+ case Nkind (E) is
+ when N_Case_Statement_Alternative
+ | N_Case_Expression_Alternative
+ =>
+ -- We could return False if selecting expression is discrete,
+ -- but this doesn't seem to be worth the bother.
+ return True;
+
+ when N_Empty
+ | N_Statement_Other_Than_Procedure_Call
+ | N_Procedure_Call_Statement
+ | N_Declaration
+ =>
+ return False;
+
+ when others =>
+ E := Parent (E);
+ end case;
+ end loop;
+ end Is_Case_Choice_Pattern;
+
end Sem_Case;
diff --git a/gcc/ada/sem_case.ads b/gcc/ada/sem_case.ads
index 16fa243..3943cf2 100644
--- a/gcc/ada/sem_case.ads
+++ b/gcc/ada/sem_case.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1996-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1996-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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,8 +44,8 @@
-- till the freeze point in this case.
-- 3. Set the Others_Discrete_Choices list for an others choice. This is
--- used in various ways, e.g. to construct the disriminant checking function
--- for the case of a variant with an others choice.
+-- used in various ways, e.g. to construct the discriminant checking
+-- function for the case of a variant with an others choice.
-- 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
@@ -125,10 +125,10 @@ package Sem_Case is
package Generic_Check_Choices is
procedure Check_Choices
- (N : Node_Id;
- Alternatives : List_Id;
- Subtyp : Entity_Id;
- Others_Present : out Boolean);
+ (N : Node_Id;
+ Alternatives : List_Id;
+ Subtyp : Entity_Id;
+ Others_Present : out Boolean);
-- From a case expression, case statement, or record variant N, this
-- routine analyzes the corresponding list of discrete choices which
-- appear in each element of the list Alternatives (for the variant
@@ -147,4 +147,10 @@ package Sem_Case is
-- the parent node (N_Variant, N_Case_Expression/Statement_Alternative).
end Generic_Check_Choices;
+
+ function Is_Case_Choice_Pattern (Expr : Node_Id) return Boolean;
+ -- GNAT language extensions allow casing on a non-discrete value, with
+ -- patterns as case choices. Return True iff Expr is such a pattern, or
+ -- a subexpression thereof.
+
end Sem_Case;
diff --git a/gcc/ada/sem_cat.adb b/gcc/ada/sem_cat.adb
index ee22113..92aa7ec 100644
--- a/gcc/ada/sem_cat.adb
+++ b/gcc/ada/sem_cat.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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,24 +23,28 @@
-- --
------------------------------------------------------------------------------
-with Atree; use Atree;
-with Debug; use Debug;
-with Einfo; use Einfo;
-with Elists; use Elists;
-with Errout; use Errout;
-with Lib; use Lib;
-with Namet; use Namet;
-with Nlists; use Nlists;
-with Opt; use Opt;
-with Sem; use Sem;
-with Sem_Attr; use Sem_Attr;
-with Sem_Aux; use Sem_Aux;
-with Sem_Dist; use Sem_Dist;
-with Sem_Eval; use Sem_Eval;
-with Sem_Util; use Sem_Util;
-with Sinfo; use Sinfo;
-with Snames; use Snames;
-with Stand; use Stand;
+with Atree; use Atree;
+with Debug; use Debug;
+with Einfo; use Einfo;
+with Einfo.Entities; use Einfo.Entities;
+with Einfo.Utils; use Einfo.Utils;
+with Elists; use Elists;
+with Errout; use Errout;
+with Lib; use Lib;
+with Namet; use Namet;
+with Nlists; use Nlists;
+with Opt; use Opt;
+with Sem; use Sem;
+with Sem_Attr; use Sem_Attr;
+with Sem_Aux; use Sem_Aux;
+with Sem_Dist; use Sem_Dist;
+with Sem_Eval; use Sem_Eval;
+with Sem_Util; use Sem_Util;
+with Sinfo; use Sinfo;
+with Sinfo.Nodes; use Sinfo.Nodes;
+with Sinfo.Utils; use Sinfo.Utils;
+with Snames; use Snames;
+with Stand; use Stand;
package body Sem_Cat is
@@ -275,7 +279,7 @@ package body Sem_Cat is
and then Is_Preelaborated (Depended_Entity)
then
Error_Msg_NE
- ("<<must use private with clause for preelaborated unit& ",
+ ("<<must use private with clause for preelaborated unit&",
N, Depended_Entity);
-- Subunit case
@@ -296,18 +300,16 @@ package body Sem_Cat is
-- Add further explanation for Pure/Preelaborate common cases
if Unit_Category = Pure then
- Error_Msg_NE
- ("\<<pure unit cannot depend on non-pure unit",
- N, Depended_Entity);
+ Error_Msg_N
+ ("\<<pure unit cannot depend on non-pure unit", N);
elsif Is_Preelaborated (Unit_Entity)
and then not Is_Preelaborated (Depended_Entity)
and then not Is_Pure (Depended_Entity)
then
- Error_Msg_NE
+ Error_Msg_N
("\<<preelaborated unit cannot depend on "
- & "non-preelaborated unit",
- N, Depended_Entity);
+ & "non-preelaborated unit", N);
end if;
end if;
end Check_Categorization_Dependencies;
@@ -354,6 +356,14 @@ package body Sem_Cat is
if Present (Expression (Component_Decl))
and then Nkind (Expression (Component_Decl)) /= N_Null
and then not Is_OK_Static_Expression (Expression (Component_Decl))
+
+ -- If we're in a predefined unit, we can put whatever we like in a
+ -- preelaborated package, and in fact in some cases it's necessary
+ -- to bend the rules. Ada.Containers.Bounded_Hashed_Maps contains
+ -- some code that would not be considered preelaborable in user
+ -- code, for example.
+
+ and then not In_Predefined_Unit (Component_Decl)
then
Error_Msg_Sloc := Sloc (Component_Decl);
Error_Msg_F
@@ -691,56 +701,25 @@ package body Sem_Cat is
-------------------------------------
procedure Set_Categorization_From_Pragmas (N : Node_Id) is
- P : constant Node_Id := Parent (N);
- S : constant Entity_Id := Current_Scope;
-
- procedure Set_Parents (Visibility : Boolean);
- -- If this is a child instance, the parents are not immediately
- -- visible during analysis. Make them momentarily visible so that
- -- the argument of the pragma can be resolved properly, and reset
- -- afterwards.
+ P : constant Node_Id := Parent (N);
- -----------------
- -- Set_Parents --
- -----------------
-
- procedure Set_Parents (Visibility : Boolean) is
- Par : Entity_Id;
- begin
- Par := Scope (S);
- while Present (Par) and then Par /= Standard_Standard loop
- Set_Is_Immediately_Visible (Par, Visibility);
- Par := Scope (Par);
- end loop;
- end Set_Parents;
+ procedure Make_Parents_Visible_And_Process_Pragmas (Par : Entity_Id);
+ -- Parents might not be immediately visible during analysis. Make
+ -- them momentarily visible so that the argument of the pragma can
+ -- be resolved properly, process pragmas and restore the previous
+ -- visibility.
- -- Start of processing for Set_Categorization_From_Pragmas
+ procedure Process_Categorization_Pragmas;
+ -- Process categorization pragmas, if any
- begin
- -- Deal with categorization pragmas in Pragmas of Compilation_Unit.
- -- The purpose is to set categorization flags before analyzing the
- -- unit itself, so as to diagnose violations of categorization as
- -- we process each declaration, even though the pragma appears after
- -- the unit. This processing is only needed if compilation unit pragmas
- -- are present.
- -- Note: This code may be incorrect in the unlikely case a child generic
- -- unit is instantiated as a child of its (nongeneric) parent, so that
- -- generic and instance are siblings.
-
- if Nkind (P) /= N_Compilation_Unit
- or else No (First (Pragmas_After (Aux_Decls_Node (P))))
- then
- return;
- end if;
+ ------------------------------------
+ -- Process_Categorization_Pragmas --
+ ------------------------------------
- declare
+ procedure Process_Categorization_Pragmas is
PN : Node_Id;
begin
- if Is_Child_Unit (S) and then Is_Generic_Instance (S) then
- Set_Parents (True);
- end if;
-
PN := First (Pragmas_After (Aux_Decls_Node (P)));
while Present (PN) loop
@@ -765,11 +744,49 @@ package body Sem_Cat is
Next (PN);
end loop;
+ end Process_Categorization_Pragmas;
- if Is_Child_Unit (S) and then Is_Generic_Instance (S) then
- Set_Parents (False);
+ ----------------------------------------------
+ -- Make_Parents_Visible_And_Process_Pragmas --
+ ----------------------------------------------
+
+ procedure Make_Parents_Visible_And_Process_Pragmas (Par : Entity_Id) is
+ begin
+ -- When we reached the Standard scope, then just process pragmas
+
+ if Par = Standard_Standard then
+ Process_Categorization_Pragmas;
+
+ -- Otherwise make the current scope momentarily visible, recurse
+ -- into its enclosing scope, and restore the visibility. This is
+ -- required for child units that are instances of generic parents.
+
+ else
+ declare
+ Save_Is_Immediately_Visible : constant Boolean :=
+ Is_Immediately_Visible (Par);
+ begin
+ Set_Is_Immediately_Visible (Par);
+ Make_Parents_Visible_And_Process_Pragmas (Scope (Par));
+ Set_Is_Immediately_Visible (Par, Save_Is_Immediately_Visible);
+ end;
end if;
- end;
+ end Make_Parents_Visible_And_Process_Pragmas;
+
+ -- Start of processing for Set_Categorization_From_Pragmas
+
+ begin
+ -- Deal with categorization pragmas in Pragmas of Compilation_Unit.
+ -- The purpose is to set categorization flags before analyzing the
+ -- unit itself, so as to diagnose violations of categorization as
+ -- we process each declaration, even though the pragma appears after
+ -- the unit.
+
+ if Nkind (P) /= N_Compilation_Unit then
+ return;
+ end if;
+
+ Make_Parents_Visible_And_Process_Pragmas (Scope (Current_Scope));
end Set_Categorization_From_Pragmas;
-----------------------------------
diff --git a/gcc/ada/sem_cat.ads b/gcc/ada/sem_cat.ads
index 2c95897..90a713b 100644
--- a/gcc/ada/sem_cat.ads
+++ b/gcc/ada/sem_cat.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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,7 @@
-- the semantic restrictions required for the categorization pragmas:
--
-- Preelaborate
--- Pure,
+-- Pure
-- Remote_Call_Interface
-- Remote_Types
-- Shared_Passive
diff --git a/gcc/ada/sem_ch10.adb b/gcc/ada/sem_ch10.adb
index e5519bf..1e7b93c 100644
--- a/gcc/ada/sem_ch10.adb
+++ b/gcc/ada/sem_ch10.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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,52 +23,56 @@
-- --
------------------------------------------------------------------------------
-with Aspects; use Aspects;
-with Atree; use Atree;
-with Contracts; use Contracts;
-with Debug; use Debug;
-with Einfo; use Einfo;
-with Errout; use Errout;
+with Aspects; use Aspects;
+with Atree; use Atree;
+with Contracts; use Contracts;
+with Debug; use Debug;
+with Einfo; use Einfo;
+with Einfo.Entities; use Einfo.Entities;
+with Einfo.Utils; use Einfo.Utils;
+with Errout; use Errout;
with Exp_Put_Image;
-with Exp_Util; use Exp_Util;
-with Elists; use Elists;
-with Fname; use Fname;
-with Fname.UF; use Fname.UF;
-with Freeze; use Freeze;
-with Impunit; use Impunit;
-with Inline; use Inline;
-with Lib; use Lib;
-with Lib.Load; use Lib.Load;
-with Lib.Xref; use Lib.Xref;
-with Namet; use Namet;
-with Nlists; use Nlists;
-with Nmake; use Nmake;
-with Opt; use Opt;
-with Output; use Output;
-with Par_SCO; use Par_SCO;
-with Restrict; use Restrict;
-with Rident; use Rident;
-with Rtsfind; use Rtsfind;
-with Sem; use Sem;
-with Sem_Aux; use Sem_Aux;
-with Sem_Ch3; use Sem_Ch3;
-with Sem_Ch6; use Sem_Ch6;
-with Sem_Ch7; use Sem_Ch7;
-with Sem_Ch8; use Sem_Ch8;
-with Sem_Ch13; use Sem_Ch13;
-with Sem_Dist; use Sem_Dist;
-with Sem_Prag; use Sem_Prag;
-with Sem_Util; use Sem_Util;
-with Sem_Warn; use Sem_Warn;
-with Stand; use Stand;
-with Sinfo; use Sinfo;
-with Sinfo.CN; use Sinfo.CN;
-with Sinput; use Sinput;
-with Snames; use Snames;
-with Style; use Style;
-with Stylesw; use Stylesw;
-with Tbuild; use Tbuild;
-with Uname; use Uname;
+with Exp_Util; use Exp_Util;
+with Elists; use Elists;
+with Fname; use Fname;
+with Fname.UF; use Fname.UF;
+with Freeze; use Freeze;
+with Impunit; use Impunit;
+with Inline; use Inline;
+with Lib; use Lib;
+with Lib.Load; use Lib.Load;
+with Lib.Xref; use Lib.Xref;
+with Namet; use Namet;
+with Nlists; use Nlists;
+with Nmake; use Nmake;
+with Opt; use Opt;
+with Output; use Output;
+with Par_SCO; use Par_SCO;
+with Restrict; use Restrict;
+with Rident; use Rident;
+with Rtsfind; use Rtsfind;
+with Sem; use Sem;
+with Sem_Aux; use Sem_Aux;
+with Sem_Ch3; use Sem_Ch3;
+with Sem_Ch6; use Sem_Ch6;
+with Sem_Ch7; use Sem_Ch7;
+with Sem_Ch8; use Sem_Ch8;
+with Sem_Ch13; use Sem_Ch13;
+with Sem_Dist; use Sem_Dist;
+with Sem_Prag; use Sem_Prag;
+with Sem_Util; use Sem_Util;
+with Sem_Warn; use Sem_Warn;
+with Stand; use Stand;
+with Sinfo; use Sinfo;
+with Sinfo.Nodes; use Sinfo.Nodes;
+with Sinfo.Utils; use Sinfo.Utils;
+with Sinfo.CN; use Sinfo.CN;
+with Sinput; use Sinput;
+with Snames; use Snames;
+with Style; use Style;
+with Stylesw; use Stylesw;
+with Tbuild; use Tbuild;
+with Uname; use Uname;
package body Sem_Ch10 is
@@ -622,7 +626,7 @@ package body Sem_Ch10 is
-- Start of processing for Analyze_Compilation_Unit
begin
- Exp_Put_Image.Preload_Sink (N);
+ Exp_Put_Image.Preload_Root_Buffer_Type (N);
Process_Compilation_Unit_Pragmas (N);
@@ -1561,9 +1565,9 @@ package body Sem_Ch10 is
Error_Msg_N
("simultaneous visibility of limited and "
& "unlimited views not allowed", Item);
- Error_Msg_NE
+ Error_Msg_N
("\unlimited view visible through context "
- & "clause #", Item, It);
+ & "clause #", Item);
exit;
elsif Nkind (Unit_Name) = N_Identifier then
@@ -1643,7 +1647,7 @@ package body Sem_Ch10 is
-- when we load the proper body.
Set_Scope (Id, Current_Scope);
- Set_Ekind (Id, E_Package_Body);
+ Mutate_Ekind (Id, E_Package_Body);
Set_Etype (Id, Standard_Void_Type);
if Has_Aspects (N) then
@@ -1985,7 +1989,7 @@ package body Sem_Ch10 is
Opts := Save_Config_Switches;
Set_Scope (Id, Current_Scope);
- Set_Ekind (Id, E_Protected_Body);
+ Mutate_Ekind (Id, E_Protected_Body);
Set_Etype (Id, Standard_Void_Type);
if Has_Aspects (N) then
@@ -2433,8 +2437,10 @@ package body Sem_Ch10 is
-- The syntax rules require a proper body for a subprogram subunit
- if Nkind (Proper_Body (Sinfo.Unit (N))) = N_Subprogram_Declaration then
- if Null_Present (Specification (Proper_Body (Sinfo.Unit (N)))) then
+ if Nkind (Proper_Body (Sinfo.Nodes.Unit (N))) = N_Subprogram_Declaration
+ then
+ if Null_Present (Specification (Proper_Body (Sinfo.Nodes.Unit (N))))
+ then
Error_Msg_N
("null procedure not allowed as subunit",
Proper_Body (Unit (N)));
@@ -2494,7 +2500,7 @@ package body Sem_Ch10 is
else
Set_Scope (Id, Current_Scope);
- Set_Ekind (Id, E_Task_Body);
+ Mutate_Ekind (Id, E_Task_Body);
Set_Etype (Id, Standard_Void_Type);
if Has_Aspects (N) then
@@ -2702,11 +2708,11 @@ package body Sem_Ch10 is
Error_Msg_N ("& is an Ada 2012 unit?i?", Name (N));
end if;
- when Ada_202X_Unit =>
- if Ada_Version < Ada_2020
- and then Warn_On_Ada_202X_Compatibility
+ when Ada_2022_Unit =>
+ if Ada_Version < Ada_2022
+ and then Warn_On_Ada_2022_Compatibility
then
- Error_Msg_N ("& is an Ada 202x unit?i?", Name (N));
+ Error_Msg_N ("& is an Ada 2022 unit?i?", Name (N));
end if;
end case;
end if;
@@ -3832,7 +3838,7 @@ package body Sem_Ch10 is
if E2 = WEnt then
Error_Msg_N
- ("unlimited view visible through use clause ", W);
+ ("unlimited view visible through use clause", W);
return;
end if;
end if;
@@ -4114,7 +4120,8 @@ package body Sem_Ch10 is
Set_Subtype_Indication (Decl,
New_Occurrence_Of (Non_Lim_View, Sloc (Def_Id)));
Set_Etype (Def_Id, Non_Lim_View);
- Set_Ekind (Def_Id, Subtype_Kind (Ekind (Non_Lim_View)));
+ Mutate_Ekind
+ (Def_Id, Subtype_Kind (Ekind (Non_Lim_View)));
Set_Analyzed (Decl, False);
-- Reanalyze the declaration, suppressing the call to
@@ -4980,7 +4987,7 @@ package body Sem_Ch10 is
-- Minimum decoration
- Set_Ekind (P, E_Package);
+ Mutate_Ekind (P, E_Package);
Set_Etype (P, Standard_Void_Type);
Set_Scope (P, Standard_Standard);
Set_Is_Visible_Lib_Unit (P);
@@ -5732,9 +5739,9 @@ package body Sem_Ch10 is
-- The abstract view of a variable is a state, not another variable
if Ekind (Ent) = E_Variable then
- Set_Ekind (Shadow, E_Abstract_State);
+ Mutate_Ekind (Shadow, E_Abstract_State);
else
- Set_Ekind (Shadow, Ekind (Ent));
+ Mutate_Ekind (Shadow, Ekind (Ent));
end if;
Set_Is_Internal (Shadow);
@@ -5779,7 +5786,7 @@ package body Sem_Ch10 is
procedure Decorate_Package (Ent : Entity_Id; Scop : Entity_Id) is
begin
- Set_Ekind (Ent, E_Package);
+ Mutate_Ekind (Ent, E_Package);
Set_Etype (Ent, Standard_Void_Type);
Set_Scope (Ent, Scop);
end Decorate_Package;
@@ -5790,7 +5797,7 @@ package body Sem_Ch10 is
procedure Decorate_State (Ent : Entity_Id; Scop : Entity_Id) is
begin
- Set_Ekind (Ent, E_Abstract_State);
+ Mutate_Ekind (Ent, E_Abstract_State);
Set_Etype (Ent, Standard_Void_Type);
Set_Scope (Ent, Scop);
Set_Encapsulating_State (Ent, Empty);
@@ -5812,7 +5819,7 @@ package body Sem_Ch10 is
-- An unanalyzed type or a shadow entity of a type is treated as an
-- incomplete type, and carries the corresponding attributes.
- Set_Ekind (Ent, E_Incomplete_Type);
+ Mutate_Ekind (Ent, E_Incomplete_Type);
Set_Etype (Ent, Ent);
Set_Full_View (Ent, Empty);
Set_Is_First_Subtype (Ent);
@@ -5848,7 +5855,7 @@ package body Sem_Ch10 is
Set_Parent (CW_Typ, Parent (Ent));
- Set_Ekind (CW_Typ, E_Class_Wide_Type);
+ Mutate_Ekind (CW_Typ, E_Class_Wide_Type);
Set_Class_Wide_Type (CW_Typ, CW_Typ);
Set_Etype (CW_Typ, Ent);
Set_Equivalent_Type (CW_Typ, Empty);
@@ -5868,7 +5875,7 @@ package body Sem_Ch10 is
procedure Decorate_Variable (Ent : Entity_Id; Scop : Entity_Id) is
begin
- Set_Ekind (Ent, E_Variable);
+ Mutate_Ekind (Ent, E_Variable);
Set_Etype (Ent, Standard_Void_Type);
Set_Scope (Ent, Scop);
end Decorate_Variable;
@@ -6223,7 +6230,7 @@ package body Sem_Ch10 is
-- must be minimally decorated. This ensures that the checks on unused
-- with clauses also process limieted withs.
- Set_Ekind (Pack, E_Package);
+ Mutate_Ekind (Pack, E_Package);
Set_Etype (Pack, Standard_Void_Type);
if Is_Entity_Name (Nam) then
@@ -6245,7 +6252,7 @@ package body Sem_Ch10 is
-- incomplete view of all types and packages declared within.
Shadow_Pack := Make_Temporary (Sloc (N), 'Z');
- Set_Ekind (Shadow_Pack, E_Package);
+ Mutate_Ekind (Shadow_Pack, E_Package);
Set_Is_Internal (Shadow_Pack);
Set_Limited_View (Pack, Shadow_Pack);
diff --git a/gcc/ada/sem_ch10.ads b/gcc/ada/sem_ch10.ads
index b0946a4..fbaf3ca 100644
--- a/gcc/ada/sem_ch10.ads
+++ b/gcc/ada/sem_ch10.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute 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 48c9855..2af65ae 100644
--- a/gcc/ada/sem_ch11.adb
+++ b/gcc/ada/sem_ch11.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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,30 +23,34 @@
-- --
------------------------------------------------------------------------------
-with Atree; use Atree;
-with Checks; use Checks;
-with Einfo; use Einfo;
-with Errout; use Errout;
-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;
-with Rident; use Rident;
-with Rtsfind; use Rtsfind;
-with Sem; use Sem;
-with Sem_Aux; use Sem_Aux;
-with Sem_Ch5; use Sem_Ch5;
-with Sem_Ch8; use Sem_Ch8;
-with Sem_Ch13; use Sem_Ch13;
-with Sem_Res; use Sem_Res;
-with Sem_Util; use Sem_Util;
-with Sem_Warn; use Sem_Warn;
-with Sinfo; use Sinfo;
-with Snames; use Snames;
-with Stand; use Stand;
+with Atree; use Atree;
+with Checks; use Checks;
+with Einfo; use Einfo;
+with Einfo.Entities; use Einfo.Entities;
+with Einfo.Utils; use Einfo.Utils;
+with Errout; use Errout;
+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;
+with Rident; use Rident;
+with Rtsfind; use Rtsfind;
+with Sem; use Sem;
+with Sem_Aux; use Sem_Aux;
+with Sem_Ch5; use Sem_Ch5;
+with Sem_Ch8; use Sem_Ch8;
+with Sem_Ch13; use Sem_Ch13;
+with Sem_Res; use Sem_Res;
+with Sem_Util; use Sem_Util;
+with Sem_Warn; use Sem_Warn;
+with Sinfo; use Sinfo;
+with Sinfo.Nodes; use Sinfo.Nodes;
+with Sinfo.Utils; use Sinfo.Utils;
+with Snames; use Snames;
+with Stand; use Stand;
package body Sem_Ch11 is
@@ -61,7 +65,7 @@ package body Sem_Ch11 is
begin
Generate_Definition (Id);
Enter_Name (Id);
- Set_Ekind (Id, E_Exception);
+ Mutate_Ekind (Id, E_Exception);
Set_Etype (Id, Standard_Exception_Type);
Set_Is_Statically_Allocated (Id);
Set_Is_Pure (Id, PF);
@@ -229,7 +233,7 @@ package body Sem_Ch11 is
Set_Etype (H_Scope, Standard_Void_Type);
Enter_Name (Choice);
- Set_Ekind (Choice, E_Variable);
+ Mutate_Ekind (Choice, E_Variable);
if RTE_Available (RE_Exception_Occurrence) then
Set_Etype (Choice, RTE (RE_Exception_Occurrence));
@@ -431,7 +435,7 @@ package body Sem_Ch11 is
-- postcondition, since in that case there are no source references, and
-- we need to preserve deferred references from the enclosing scope.
- if ((Is_Subprogram (Current_Scope) or else Is_Entry (Current_Scope))
+ if (Is_Subprogram_Or_Entry (Current_Scope)
and then Chars (Current_Scope) /= Name_uPostconditions)
or else Ekind (Current_Scope) in E_Block | E_Task_Type
then
@@ -658,6 +662,18 @@ package body Sem_Ch11 is
Kill_Current_Values (Last_Assignment_Only => True);
end Analyze_Raise_Statement;
+ ----------------------------------
+ -- Analyze_Raise_When_Statement --
+ ----------------------------------
+
+ procedure Analyze_Raise_When_Statement (N : Node_Id) is
+ begin
+ -- Verify the condition is a Boolean expression
+
+ Analyze_And_Resolve (Condition (N), Any_Boolean);
+ Check_Unset_Reference (Condition (N));
+ end Analyze_Raise_When_Statement;
+
-----------------------------
-- Analyze_Raise_xxx_Error --
-----------------------------
diff --git a/gcc/ada/sem_ch11.ads b/gcc/ada/sem_ch11.ads
index b10bc9d..9b027d9 100644
--- a/gcc/ada/sem_ch11.ads
+++ b/gcc/ada/sem_ch11.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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 @@ package Sem_Ch11 is
procedure Analyze_Handled_Statements (N : Node_Id);
procedure Analyze_Raise_Expression (N : Node_Id);
procedure Analyze_Raise_Statement (N : Node_Id);
+ procedure Analyze_Raise_When_Statement (N : Node_Id);
procedure Analyze_Raise_xxx_Error (N : Node_Id);
procedure Analyze_Exception_Handlers (L : List_Id);
diff --git a/gcc/ada/sem_ch12.adb b/gcc/ada/sem_ch12.adb
index 7e6aa8f..85c854f 100644
--- a/gcc/ada/sem_ch12.adb
+++ b/gcc/ada/sem_ch12.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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,60 +23,64 @@
-- --
------------------------------------------------------------------------------
-with Aspects; use Aspects;
-with Atree; use Atree;
-with Contracts; use Contracts;
-with Einfo; use Einfo;
-with Elists; use Elists;
-with Errout; use Errout;
-with Expander; use Expander;
-with Fname; use Fname;
-with Fname.UF; use Fname.UF;
-with Freeze; use Freeze;
-with Ghost; use Ghost;
-with Itypes; use Itypes;
-with Lib; use Lib;
-with Lib.Load; use Lib.Load;
-with Lib.Xref; use Lib.Xref;
-with Nlists; use Nlists;
-with Namet; use Namet;
-with Nmake; use Nmake;
-with Opt; use Opt;
-with Rident; use Rident;
-with Restrict; use Restrict;
-with Rtsfind; use Rtsfind;
-with Sem; use Sem;
-with Sem_Aux; use Sem_Aux;
-with Sem_Cat; use Sem_Cat;
-with Sem_Ch3; use Sem_Ch3;
-with Sem_Ch6; use Sem_Ch6;
-with Sem_Ch7; use Sem_Ch7;
-with Sem_Ch8; use Sem_Ch8;
-with Sem_Ch10; use Sem_Ch10;
-with Sem_Ch13; use Sem_Ch13;
-with Sem_Dim; use Sem_Dim;
-with Sem_Disp; use Sem_Disp;
-with Sem_Elab; use Sem_Elab;
-with Sem_Elim; use Sem_Elim;
-with Sem_Eval; use Sem_Eval;
-with Sem_Prag; use Sem_Prag;
-with Sem_Res; use Sem_Res;
-with Sem_Type; use Sem_Type;
-with Sem_Util; use Sem_Util;
-with Sem_Warn; use Sem_Warn;
-with Stand; use Stand;
-with Sinfo; use Sinfo;
-with Sinfo.CN; use Sinfo.CN;
-with Sinput; use Sinput;
-with Sinput.L; use Sinput.L;
-with Snames; use Snames;
-with Stringt; use Stringt;
-with Uname; use Uname;
+with Aspects; use Aspects;
+with Atree; use Atree;
+with Contracts; use Contracts;
+with Einfo; use Einfo;
+with Einfo.Entities; use Einfo.Entities;
+with Einfo.Utils; use Einfo.Utils;
+with Elists; use Elists;
+with Errout; use Errout;
+with Expander; use Expander;
+with Fname; use Fname;
+with Fname.UF; use Fname.UF;
+with Freeze; use Freeze;
+with Ghost; use Ghost;
+with Itypes; use Itypes;
+with Lib; use Lib;
+with Lib.Load; use Lib.Load;
+with Lib.Xref; use Lib.Xref;
+with Nlists; use Nlists;
+with Namet; use Namet;
+with Nmake; use Nmake;
+with Opt; use Opt;
+with Rident; use Rident;
+with Restrict; use Restrict;
+with Rtsfind; use Rtsfind;
+with Sem; use Sem;
+with Sem_Aux; use Sem_Aux;
+with Sem_Cat; use Sem_Cat;
+with Sem_Ch3; use Sem_Ch3;
+with Sem_Ch6; use Sem_Ch6;
+with Sem_Ch7; use Sem_Ch7;
+with Sem_Ch8; use Sem_Ch8;
+with Sem_Ch10; use Sem_Ch10;
+with Sem_Ch13; use Sem_Ch13;
+with Sem_Dim; use Sem_Dim;
+with Sem_Disp; use Sem_Disp;
+with Sem_Elab; use Sem_Elab;
+with Sem_Elim; use Sem_Elim;
+with Sem_Eval; use Sem_Eval;
+with Sem_Prag; use Sem_Prag;
+with Sem_Res; use Sem_Res;
+with Sem_Type; use Sem_Type;
+with Sem_Util; use Sem_Util;
+with Sem_Warn; use Sem_Warn;
+with Stand; use Stand;
+with Sinfo; use Sinfo;
+with Sinfo.Nodes; use Sinfo.Nodes;
+with Sinfo.Utils; use Sinfo.Utils;
+with Sinfo.CN; use Sinfo.CN;
+with Sinput; use Sinput;
+with Sinput.L; use Sinput.L;
+with Snames; use Snames;
+with Stringt; use Stringt;
+with Uname; use Uname;
with Table;
-with Tbuild; use Tbuild;
-with Uintp; use Uintp;
-with Urealp; use Urealp;
-with Warnsw; use Warnsw;
+with Tbuild; use Tbuild;
+with Uintp; use Uintp;
+with Urealp; use Urealp;
+with Warnsw; use Warnsw;
with GNAT.HTable;
@@ -498,7 +502,7 @@ package body Sem_Ch12 is
function Build_Subprogram_Decl_Wrapper
(Formal_Subp : Entity_Id) return Node_Id;
- -- Ada 2020 allows formal subprograms to carry pre/postconditions.
+ -- Ada 2022 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
@@ -884,6 +888,17 @@ package body Sem_Ch12 is
-- Verify that an attribute that appears as the default for a formal
-- subprogram is a function or procedure with the correct profile.
+ procedure Validate_Formal_Type_Default (Decl : Node_Id);
+ -- Ada_2022 AI12-205: if a default subtype_mark is present, verify
+ -- that it is the name of a type in the same class as the formal.
+ -- The treatment parallels what is done in Instantiate_Type but differs
+ -- in a few ways so that this machinery cannot be reused as is: on one
+ -- hand there are no visibility issues for a default, because it is
+ -- analyzed in the same context as the formal type definition; on the
+ -- other hand the check needs to take into acount the use of a previous
+ -- formal type in the current formal type definition (see details in
+ -- AI12-0205).
+
-------------------------------------------
-- Data Structures for Generic Renamings --
-------------------------------------------
@@ -1100,7 +1115,7 @@ package body Sem_Ch12 is
-- 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
+ -- Ada 2022: 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
@@ -1758,6 +1773,14 @@ package body Sem_Ch12 is
if Partial_Parameterization then
Process_Default (Formal);
+ elsif Present (Default_Subtype_Mark (Formal)) then
+ Match := New_Copy (Default_Subtype_Mark (Formal));
+ Append_List
+ (Instantiate_Type
+ (Formal, Match, Analyzed_Formal, Assoc_List),
+ Assoc_List);
+ Append_Elmt (Entity (Match), Actuals_To_Freeze);
+
else
Error_Msg_Sloc := Sloc (Gen_Unit);
Error_Msg_NE
@@ -2347,7 +2370,7 @@ package body Sem_Ch12 is
Set_Is_Generic_Type (Base);
Set_Parent (Base, Parent (Def));
- Set_Ekind (T, E_Decimal_Fixed_Point_Subtype);
+ Mutate_Ekind (T, E_Decimal_Fixed_Point_Subtype);
Set_Etype (T, Base);
Set_Size_Info (T, Int_Base);
Set_RM_Size (T, RM_Size (Int_Base));
@@ -2469,7 +2492,7 @@ package body Sem_Ch12 is
begin
Enter_Name (T);
- Set_Ekind (T, E_Enumeration_Subtype);
+ Mutate_Ekind (T, E_Enumeration_Subtype);
Set_Etype (T, Base);
Init_Size (T, 8);
Init_Alignment (T);
@@ -2498,7 +2521,7 @@ package body Sem_Ch12 is
Low_Bound => Lo,
High_Bound => Hi));
- Set_Ekind (Base, E_Enumeration_Type);
+ Mutate_Ekind (Base, E_Enumeration_Type);
Set_Etype (Base, Base);
Init_Size (Base, 8);
Init_Alignment (Base);
@@ -2524,7 +2547,7 @@ package body Sem_Ch12 is
-- the generic itself.
Enter_Name (T);
- Set_Ekind (T, E_Floating_Point_Subtype);
+ Mutate_Ekind (T, E_Floating_Point_Subtype);
Set_Etype (T, Base);
Set_Size_Info (T, (Standard_Float));
Set_RM_Size (T, RM_Size (Standard_Float));
@@ -2576,8 +2599,8 @@ package body Sem_Ch12 is
-- signed integer types, and have the same attributes.
Analyze_Formal_Signed_Integer_Type (T, Def);
- Set_Ekind (T, E_Modular_Integer_Subtype);
- Set_Ekind (Etype (T), E_Modular_Integer_Type);
+ Mutate_Ekind (T, E_Modular_Integer_Subtype);
+ Mutate_Ekind (Etype (T), E_Modular_Integer_Type);
end Analyze_Formal_Modular_Type;
@@ -2674,7 +2697,7 @@ package body Sem_Ch12 is
end if;
end if;
- Set_Ekind (Id, K);
+ Mutate_Ekind (Id, K);
Set_Etype (Id, T);
-- Case of generic IN OUT parameter
@@ -2684,7 +2707,7 @@ package body Sem_Ch12 is
-- subtype, as is done for subprogram formals. In this fashion, all
-- its uses can refer to specific bounds.
- Set_Ekind (Id, K);
+ Mutate_Ekind (Id, K);
Set_Etype (Id, T);
if (Is_Array_Type (T) and then not Is_Constrained (T))
@@ -2737,7 +2760,7 @@ package body Sem_Ch12 is
-- will never be used, since all properties of the type are non-static.
Enter_Name (T);
- Set_Ekind (T, E_Ordinary_Fixed_Point_Subtype);
+ Mutate_Ekind (T, E_Ordinary_Fixed_Point_Subtype);
Set_Etype (T, Base);
Set_Size_Info (T, Standard_Integer);
Set_RM_Size (T, RM_Size (Standard_Integer));
@@ -3013,8 +3036,8 @@ package body Sem_Ch12 is
exception
when Instantiation_Error =>
Enter_Name (Formal);
- Set_Ekind (Formal, E_Variable);
- Set_Etype (Formal, Any_Type);
+ Mutate_Ekind (Formal, E_Variable);
+ Set_Etype (Formal, Any_Type);
Restore_Hidden_Primitives (Vis_Prims_List);
if Parent_Installed then
@@ -3031,8 +3054,8 @@ package body Sem_Ch12 is
Set_Is_Generic_Instance (Formal);
Enter_Name (Formal);
- Set_Ekind (Formal, E_Package);
- Set_Etype (Formal, Standard_Void_Type);
+ Mutate_Ekind (Formal, E_Package);
+ Set_Etype (Formal, Standard_Void_Type);
Set_Inner_Instances (Formal, New_Elmt_List);
-- It is unclear that any aspects can apply to a formal package
@@ -3090,7 +3113,7 @@ package body Sem_Ch12 is
Renaming_In_Par :=
Make_Defining_Identifier (Loc, Chars (Gen_Unit));
- Set_Ekind (Renaming_In_Par, E_Package);
+ Mutate_Ekind (Renaming_In_Par, E_Package);
Set_Etype (Renaming_In_Par, Standard_Void_Type);
Set_Scope (Renaming_In_Par, Parent_Instance);
Set_Parent (Renaming_In_Par, Parent (Formal));
@@ -3159,7 +3182,7 @@ package body Sem_Ch12 is
-- Add semantic information to the original defining identifier.
- Set_Ekind (Pack_Id, E_Package);
+ Mutate_Ekind (Pack_Id, E_Package);
Set_Etype (Pack_Id, Standard_Void_Type);
Set_Scope (Pack_Id, Scope (Formal));
Set_Has_Completion (Pack_Id, True);
@@ -3203,7 +3226,7 @@ package body Sem_Ch12 is
is
begin
Enter_Name (T);
- Set_Ekind (T, E_Incomplete_Type);
+ Mutate_Ekind (T, E_Incomplete_Type);
Set_Etype (T, T);
Set_Private_Dependents (T, New_Elmt_List);
@@ -3231,7 +3254,7 @@ package body Sem_Ch12 is
begin
Enter_Name (T);
- Set_Ekind (T, E_Signed_Integer_Subtype);
+ Mutate_Ekind (T, E_Signed_Integer_Subtype);
Set_Etype (T, Base);
Set_Size_Info (T, Standard_Integer);
Set_RM_Size (T, RM_Size (Standard_Integer));
@@ -3524,6 +3547,10 @@ package body Sem_Ch12 is
Set_Is_Generic_Type (T);
Set_Is_First_Subtype (T);
+ if Present (Default_Subtype_Mark (Original_Node (N))) then
+ Validate_Formal_Type_Default (N);
+ end if;
+
if Has_Aspects (N) then
Analyze_Aspect_Specifications (N, T);
end if;
@@ -3585,7 +3612,7 @@ package body Sem_Ch12 is
Generate_Reference_To_Generic_Formals (Current_Scope);
- -- For Ada 2020, some formal parameters can carry aspects, which must
+ -- For Ada 2022, 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).
@@ -3689,8 +3716,8 @@ package body Sem_Ch12 is
Start_Generic;
Enter_Name (Id);
- Set_Ekind (Id, E_Generic_Package);
- Set_Etype (Id, Standard_Void_Type);
+ Mutate_Ekind (Id, E_Generic_Package);
+ Set_Etype (Id, Standard_Void_Type);
-- Set SPARK_Mode from context
@@ -3866,9 +3893,9 @@ package body Sem_Ch12 is
Analyze_Generic_Formal_Part (N);
if Nkind (Spec) = N_Function_Specification then
- Set_Ekind (Id, E_Generic_Function);
+ Mutate_Ekind (Id, E_Generic_Function);
else
- Set_Ekind (Id, E_Generic_Procedure);
+ Mutate_Ekind (Id, E_Generic_Procedure);
end if;
-- Set SPARK_Mode from context
@@ -3899,12 +3926,7 @@ package body Sem_Ch12 is
-- Check restriction imposed by AI05-073: a generic function
-- cannot return an abstract type or an access to such.
- -- This is a binding interpretation should it apply to earlier
- -- versions of Ada as well as Ada 2012???
-
- if Is_Abstract_Type (Designated_Type (Result_Type))
- and then Ada_Version >= Ada_2012
- then
+ if Is_Abstract_Type (Designated_Type (Result_Type)) then
Error_Msg_N
("generic function cannot have an access result "
& "that designates an abstract type", Spec);
@@ -4185,7 +4207,7 @@ package body Sem_Ch12 is
end if;
Generate_Definition (Act_Decl_Id);
- Set_Ekind (Act_Decl_Id, E_Package);
+ Mutate_Ekind (Act_Decl_Id, E_Package);
-- Initialize list of incomplete actuals before analysis
@@ -4283,7 +4305,7 @@ package body Sem_Ch12 is
and then Chars (Act_Decl_Id) = Chars (Prefix (Gen_Id))
then
Error_Msg_N
- ("& is hidden within declaration of instance ", Prefix (Gen_Id));
+ ("& is hidden within declaration of instance", Prefix (Gen_Id));
end if;
Set_Entity (Gen_Id, Gen_Unit);
@@ -4312,7 +4334,7 @@ package body Sem_Ch12 is
goto Leave;
else
- Set_Ekind (Inst_Id, E_Package);
+ Mutate_Ekind (Inst_Id, E_Package);
Set_Scope (Inst_Id, Current_Scope);
-- If the context of the instance is subject to SPARK_Mode "off" or
@@ -4535,10 +4557,7 @@ package body Sem_Ch12 is
-- If the current scope is itself an instance within a child
-- unit, there will be duplications in the scope stack, and the
-- unstacking mechanism in Inline_Instance_Body will fail.
- -- This loses some rare cases of optimization, and might be
- -- improved some day, if we can find a proper abstraction for
- -- "the complete compilation context" that can be saved and
- -- restored. ???
+ -- This loses some rare cases of optimization.
if Is_Generic_Instance (Current_Scope) then
declare
@@ -4983,17 +5002,20 @@ package body Sem_Ch12 is
if Gen_Comp /= Cunit_Entity (Current_Sem_Unit) then
- -- Add some comments for the following two loops ???
+ -- Loop through enclosing scopes until we reach a generic instance,
+ -- package body, or subprogram.
S := Current_Scope;
while Present (S) and then S /= Standard_Standard loop
+
+ -- Save use clauses from enclosing scopes into Use_Clauses
+
loop
Num_Scopes := Num_Scopes + 1;
Use_Clauses (Num_Scopes) :=
(Scope_Stack.Table
- (Scope_Stack.Last - Num_Scopes + 1).
- First_Use_Clause);
+ (Scope_Stack.Last - Num_Scopes + 1).First_Use_Clause);
End_Use_Clauses (Use_Clauses (Num_Scopes));
exit when Scope_Stack.Last - Num_Scopes + 1 = Scope_Stack.First
@@ -5550,7 +5572,6 @@ package body Sem_Ch12 is
-- If there is a formal subprogram with the same name as the unit
-- itself, do not add this renaming declaration, to prevent
-- ambiguities when there is a call with that name in the body.
- -- This is a partial and ugly fix for one ACATS test. ???
Renaming_Decl := First (Renaming_List);
while Present (Renaming_Decl) loop
@@ -5659,7 +5680,7 @@ package body Sem_Ch12 is
Error_Msg_NE ("instantiation of & within itself", N, Gen_Unit);
else
- Set_Ekind (Inst_Id, K);
+ Mutate_Ekind (Inst_Id, K);
Set_Scope (Inst_Id, Current_Scope);
Set_Entity (Gen_Id, Gen_Unit);
@@ -5775,6 +5796,14 @@ package body Sem_Ch12 is
Set_SPARK_Mode (Gen_Unit);
end if;
+ -- Need to mark Anon_Id intrinsic before calling
+ -- Analyze_Instance_And_Renamings because this flag may be propagated
+ -- to other nodes.
+
+ if Is_Intrinsic_Subprogram (Gen_Unit) then
+ Set_Is_Intrinsic_Subprogram (Anon_Id);
+ end if;
+
Analyze_Instance_And_Renamings;
-- Restore SPARK_Mode from the context after analysis of the package
@@ -5796,7 +5825,6 @@ package body Sem_Ch12 is
-- not within the main unit.
if Is_Intrinsic_Subprogram (Gen_Unit) then
- Set_Is_Intrinsic_Subprogram (Anon_Id);
Set_Is_Intrinsic_Subprogram (Act_Decl_Id);
if Chars (Gen_Unit) = Name_Unchecked_Conversion then
@@ -6051,7 +6079,7 @@ package body Sem_Ch12 is
Func_Name := New_Occurrence_Of (Actual_Subp, Loc);
Func := Make_Defining_Identifier (Loc, Chars (Formal_Subp));
- Set_Ekind (Func, E_Function);
+ Mutate_Ekind (Func, E_Function);
Set_Is_Generic_Actual_Subprogram (Func);
Actuals := New_List;
@@ -6136,7 +6164,7 @@ package body Sem_Ch12 is
R := New_Occurrence_Of (F2, Loc);
Func := Make_Defining_Identifier (Loc, Chars (Formal_Subp));
- Set_Ekind (Func, E_Function);
+ Mutate_Ekind (Func, E_Function);
Set_Is_Generic_Actual_Subprogram (Func);
Spec :=
@@ -6251,7 +6279,7 @@ package body Sem_Ch12 is
begin
Subp := Make_Defining_Identifier (Loc, Chars (Formal_Subp));
- Set_Ekind (Subp, Ekind (Formal_Subp));
+ Mutate_Ekind (Subp, Ekind (Formal_Subp));
Set_Is_Generic_Actual_Subprogram (Subp);
Profile := Parameter_Specifications (
@@ -7872,16 +7900,10 @@ package body Sem_Ch12 is
----------------------
procedure Copy_Descendants is
- use Atree.Unchecked_Access;
- -- This code section is part of the implementation of an untyped
- -- tree traversal, so it needs direct access to node fields.
-
+ procedure Walk is new
+ Walk_Sinfo_Fields_Pairwise (Copy_Generic_Descendant);
begin
- Set_Field1 (New_N, Copy_Generic_Descendant (Field1 (N)));
- Set_Field2 (New_N, Copy_Generic_Descendant (Field2 (N)));
- Set_Field3 (New_N, Copy_Generic_Descendant (Field3 (N)));
- Set_Field4 (New_N, Copy_Generic_Descendant (Field4 (N)));
- Set_Field5 (New_N, Copy_Generic_Descendant (Field5 (N)));
+ Walk (New_N, N);
end Copy_Descendants;
-----------------------------
@@ -8482,17 +8504,31 @@ package body Sem_Ch12 is
-- Do not copy the associated node, which points to the generic copy
-- of the aggregate.
- declare
- use Atree.Unchecked_Access;
- -- This code section is part of the implementation of an untyped
- -- tree traversal, so it needs direct access to node fields.
+ if Nkind (N) = N_Aggregate then
+ Set_Aggregate_Bounds
+ (New_N,
+ Node_Id (Copy_Generic_Descendant
+ (Union_Id (Aggregate_Bounds (N)))));
- begin
- Set_Field1 (New_N, Copy_Generic_Descendant (Field1 (N)));
- Set_Field2 (New_N, Copy_Generic_Descendant (Field2 (N)));
- Set_Field3 (New_N, Copy_Generic_Descendant (Field3 (N)));
- Set_Field5 (New_N, Copy_Generic_Descendant (Field5 (N)));
- end;
+ elsif Nkind (N) = N_Extension_Aggregate then
+ Set_Ancestor_Part
+ (New_N,
+ Node_Id (Copy_Generic_Descendant
+ (Union_Id (Ancestor_Part (N)))));
+
+ else
+ pragma Assert (False);
+ end if;
+
+ Set_Expressions
+ (New_N,
+ List_Id (Copy_Generic_Descendant (Union_Id (Expressions (N)))));
+ Set_Component_Associations
+ (New_N,
+ List_Id (Copy_Generic_Descendant
+ (Union_Id (Component_Associations (N)))));
+ Set_Etype
+ (New_N, Node_Id (Copy_Generic_Descendant (Union_Id (Etype (N)))));
-- Allocators do not have an identifier denoting the access type, so we
-- must locate it through the expression to check whether the views are
@@ -9077,7 +9113,7 @@ package body Sem_Ch12 is
-- Handle the following case:
--
-- package Parent_Inst is new ...
- -- Parent_Inst []
+ -- freeze Parent_Inst []
--
-- procedure P ... -- this body freezes Parent_Inst
--
@@ -9688,7 +9724,6 @@ package body Sem_Ch12 is
if Nkind (Par_N) = N_Package_Specification
and then Decls = Visible_Declarations (Par_N)
- and then Present (Private_Declarations (Par_N))
and then not Is_Empty_List (Private_Declarations (Par_N))
then
Decls := Private_Declarations (Par_N);
@@ -9752,6 +9787,7 @@ package body Sem_Ch12 is
-- point of the current enclosing instance. Pending a better usage of
-- Slocs to indicate instantiation places, we determine the place of
-- origin of a node by finding the maximum sloc of any ancestor node.
+
-- Why is this not equivalent to Top_Level_Location ???
-------------------
@@ -9912,7 +9948,7 @@ package body Sem_Ch12 is
-- Handle the following case:
-- package Parent_Inst is new ...
- -- Parent_Inst []
+ -- freeze Parent_Inst []
-- procedure P ... -- this body freezes Parent_Inst
@@ -10872,7 +10908,7 @@ package body Sem_Ch12 is
begin
Set_Is_Internal (I_Pack);
- Set_Ekind (I_Pack, E_Package);
+ Mutate_Ekind (I_Pack, E_Package);
Set_Hidden_In_Formal_Instance (I_Pack, Hidden_Formals);
Append_To (Decls,
@@ -10998,7 +11034,7 @@ package body Sem_Ch12 is
-- 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
+ if Ada_Version >= Ada_2022
and then Has_Contracts (Analyzed_Formal)
and then not Is_Entity_Name (Actual)
and then Expander_Active
@@ -11009,7 +11045,7 @@ package body Sem_Ch12 is
New_Subp := Make_Defining_Identifier (Loc, Chars (Formal_Sub));
end if;
- Set_Ekind (New_Subp, Ekind (Analyzed_S));
+ Mutate_Ekind (New_Subp, Ekind (Analyzed_S));
Set_Is_Generic_Actual_Subprogram (New_Subp);
Set_Defining_Unit_Name (New_Spec, New_Subp);
@@ -11228,7 +11264,8 @@ package body Sem_Ch12 is
A_Gen_Obj : constant Entity_Id :=
Defining_Identifier (Analyzed_Formal);
Acc_Def : Node_Id := Empty;
- Act_Assoc : constant Node_Id := Parent (Actual);
+ Act_Assoc : constant Node_Id :=
+ (if No (Actual) then Empty else Parent (Actual));
Actual_Decl : Node_Id := Empty;
Decl_Node : Node_Id;
Def : Node_Id;
@@ -11259,7 +11296,7 @@ package body Sem_Ch12 is
Error_Msg_N ("duplicate instantiation of generic parameter", Actual);
end if;
- Set_Parent (List, Parent (Actual));
+ Set_Parent (List, Act_Assoc);
-- OUT present
@@ -11403,14 +11440,15 @@ package body Sem_Ch12 is
Actual, Gen_Obj);
Error_Msg_N ("\with atomic object actual (RM C.6(12))", Actual);
- elsif Is_Volatile_Object (Actual) and then not Is_Volatile (Orig_Ftyp)
+ elsif Is_Volatile_Object_Ref (Actual)
+ and then not Is_Volatile (Orig_Ftyp)
then
Error_Msg_NE
("cannot instantiate nonvolatile formal & of mode in out",
Actual, Gen_Obj);
Error_Msg_N ("\with volatile object actual (RM C.6(12))", Actual);
- elsif Is_Volatile_Full_Access_Object (Actual)
+ elsif Is_Volatile_Full_Access_Object_Ref (Actual)
and then not Is_Volatile_Full_Access (Orig_Ftyp)
then
Error_Msg_NE
@@ -11421,9 +11459,9 @@ package body Sem_Ch12 is
end if;
-- Check for instantiation on nonatomic subcomponent of a full access
- -- object in Ada 2020 (RM C.6 (12)).
+ -- object in Ada 2022 (RM C.6 (12)).
- if Ada_Version >= Ada_2020
+ if Ada_Version >= Ada_2022
and then Is_Subcomponent_Of_Full_Access_Object (Actual)
and then not Is_Atomic_Object (Actual)
then
@@ -11623,7 +11661,9 @@ package body Sem_Ch12 is
end if;
end if;
- if Nkind (Actual) in N_Has_Entity then
+ if Nkind (Actual) in N_Has_Entity
+ and then Present (Entity (Actual))
+ then
Actual_Decl := Parent (Entity (Actual));
end if;
@@ -12563,9 +12603,7 @@ package body Sem_Ch12 is
-- errors, this may be an instance whose scope is a premature instance.
-- In that case we must insure that the (legal) program does raise
-- program error if executed. We generate a subprogram body for this
- -- purpose. See DEC ac30vso.
-
- -- Should not reference proprietary DEC tests in comments ???
+ -- purpose.
elsif Serious_Errors_Detected = 0
and then Nkind (Parent (Inst_Node)) /= N_Compilation_Unit
@@ -12667,7 +12705,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 2022: 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;
@@ -12677,6 +12715,11 @@ package body Sem_Ch12 is
-- declaration, it carries the flag No_Predicate_On_Actual. it is part
-- of the generic contract that the actual cannot have predicates.
+ function Subtypes_Match (Gen_T, Act_T : Entity_Id) return Boolean;
+ -- Check that base types are the same and that the subtypes match
+ -- statically. Used in several of the validation subprograms for
+ -- actuals in instantiations.
+
procedure Validate_Array_Type_Instance;
procedure Validate_Access_Subprogram_Instance;
procedure Validate_Access_Type_Instance;
@@ -12690,15 +12733,11 @@ package body Sem_Ch12 is
-- Validate_Discriminated_Formal_Type is shared by formal private
-- types and Ada 2012 formal incomplete types.
- function Subtypes_Match (Gen_T, Act_T : Entity_Id) return Boolean;
- -- Check that base types are the same and that the subtypes match
- -- statically. Used in several of the above.
-
--------------------------------------------
-- Check_Shared_Variable_Control_Aspects --
--------------------------------------------
- -- Ada 2020: Verify that shared variable control aspects (RM C.6)
+ -- Ada 2022: 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
@@ -12709,7 +12748,7 @@ package body Sem_Ch12 is
procedure Check_Shared_Variable_Control_Aspects is
begin
- if Ada_Version >= Ada_2020 then
+ if Ada_Version >= Ada_2022 then
if Is_Atomic (A_Gen_T) and then not Is_Atomic (Act_T) then
Error_Msg_NE
("actual for& must have Atomic aspect", Actual, A_Gen_T);
@@ -12792,7 +12831,7 @@ package body Sem_Ch12 is
Check_Volatility_Compatibility
(Act_T, A_Gen_T,
"actual type", "its corresponding formal type",
- Srcpos_Bearer => Act_T);
+ Srcpos_Bearer => Actual);
end if;
end Check_Shared_Variable_Control_Aspects;
@@ -12827,7 +12866,9 @@ package body Sem_Ch12 is
T : constant Entity_Id := Get_Instance_Of (Gen_T);
begin
- -- Some detailed comments would be useful here ???
+ -- Check that the base types, root types (when dealing with class
+ -- wide types), or designated types (when dealing with anonymous
+ -- access types) of Gen_T and Act_T are statically matching subtypes.
return ((Base_Type (T) = Act_T
or else Base_Type (T) = Base_Type (Act_T))
@@ -12839,9 +12880,7 @@ package body Sem_Ch12 is
(Get_Instance_Of (Root_Type (Gen_T)),
Root_Type (Act_T)))
- or else
- (Ekind (Gen_T) in E_Anonymous_Access_Subprogram_Type
- | E_Anonymous_Access_Type
+ or else (Is_Anonymous_Access_Type (Gen_T)
and then Ekind (Act_T) = Ekind (Gen_T)
and then Subtypes_Statically_Match
(Designated_Type (Gen_T), Designated_Type (Act_T)));
@@ -13399,7 +13438,7 @@ 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".
- -- For Ada 2020, the aspect may be specified explicitly for the
+ -- For Ada 2022, the aspect may be specified explicitly for the
-- formal regardless of whether an ancestor obeys it.
if Is_Atomic (Act_T)
@@ -13682,8 +13721,8 @@ package body Sem_Ch12 is
exit;
end if;
- Next_Entity (Anc_Formal);
- Next_Entity (Act_Formal);
+ Next_Formal (Anc_Formal);
+ Next_Formal (Act_Formal);
end loop;
-- If we traversed through all of the formals
@@ -13828,9 +13867,9 @@ package body Sem_Ch12 is
Actual_Discr := First_Discriminant (Act_T);
while Formal_Discr /= Empty loop
if Actual_Discr = Empty then
- Error_Msg_NE
+ Error_Msg_N
("discriminants on actual do not match formal",
- Actual, Gen_T);
+ Actual);
Abandon_Instantiation (Actual);
end if;
@@ -13851,18 +13890,18 @@ package body Sem_Ch12 is
elsif Base_Type (Formal_Subt) /=
Base_Type (Etype (Actual_Discr))
then
- Error_Msg_NE
+ Error_Msg_N
("types of actual discriminants must match formal",
- Actual, Gen_T);
+ Actual);
Abandon_Instantiation (Actual);
elsif not Subtypes_Statically_Match
(Formal_Subt, Etype (Actual_Discr))
and then Ada_Version >= Ada_95
then
- Error_Msg_NE
+ Error_Msg_N
("subtypes of actual discriminants must match formal",
- Actual, Gen_T);
+ Actual);
Abandon_Instantiation (Actual);
end if;
@@ -14016,9 +14055,12 @@ package body Sem_Ch12 is
and then Ekind (Root_Type (Act_T)) = E_Incomplete_Type)
then
-- If the formal is an incomplete type, the actual can be
- -- incomplete as well.
+ -- incomplete as well, but if an actual incomplete type has
+ -- a full view, then we'll retrieve that.
- if Ekind (A_Gen_T) = E_Incomplete_Type then
+ if Ekind (A_Gen_T) = E_Incomplete_Type
+ and then not Present (Full_View (Act_T))
+ then
null;
elsif Is_Class_Wide_Type (Act_T)
@@ -14026,6 +14068,7 @@ package body Sem_Ch12 is
then
Error_Msg_N ("premature use of incomplete type", Actual);
Abandon_Instantiation (Actual);
+
else
Act_T := Full_View (Act_T);
Set_Entity (Actual, Act_T);
@@ -14200,7 +14243,7 @@ package body Sem_Ch12 is
-- the local subtype must be treated as such.
if From_Limited_With (Act_T) then
- Set_Ekind (Subt, E_Incomplete_Subtype);
+ Mutate_Ekind (Subt, E_Incomplete_Subtype);
Set_From_Limited_With (Subt);
end if;
@@ -14259,9 +14302,9 @@ package body Sem_Ch12 is
Append_To (Decl_Nodes, Corr_Decl);
if Ekind (Act_T) = E_Task_Type then
- Set_Ekind (Subt, E_Task_Subtype);
+ Mutate_Ekind (Subt, E_Task_Subtype);
else
- Set_Ekind (Subt, E_Protected_Subtype);
+ Mutate_Ekind (Subt, E_Protected_Subtype);
end if;
Set_Corresponding_Record_Type (Subt, Corr_Rec);
@@ -15212,14 +15255,15 @@ package body Sem_Ch12 is
-- subunit of a generic contains an instance of a child unit of
-- its generic parent unit.
- elsif S = Current_Scope and then Is_Generic_Instance (S) then
+ elsif S = Current_Scope and then Is_Generic_Instance (S)
+ and then (In_Package_Body (S) or else In_Private_Part (S))
+ then
declare
Par : constant Entity_Id :=
Generic_Parent (Package_Specification (S));
begin
if Present (Par)
and then P = Scope (Par)
- and then (In_Package_Body (S) or else In_Private_Part (S))
then
Set_In_Private_Part (P);
Install_Private_Declarations (P);
@@ -15608,7 +15652,13 @@ package body Sem_Ch12 is
elsif E = Standard_Standard then
return True;
- elsif Is_Child_Unit (E)
+ -- E should be an entity, but it is not always
+
+ elsif Nkind (E) not in N_Entity then
+ return False;
+
+ elsif Nkind (E) /= N_Expanded_Name
+ and then Is_Child_Unit (E)
and then (Is_Instance_Node (Parent (N2))
or else (Nkind (Parent (N2)) = N_Expanded_Name
and then N2 = Selector_Name (Parent (N2))
@@ -15618,7 +15668,19 @@ package body Sem_Ch12 is
return True;
else
- Se := Scope (E);
+ -- E may be an expanded name - typically an operator - in which
+ -- case we must find its enclosing scope since expanded names
+ -- don't have corresponding scopes.
+
+ if Nkind (E) = N_Expanded_Name then
+ Se := Find_Enclosing_Scope (E);
+
+ -- Otherwise, E is an entity and will have Scope set
+
+ else
+ Se := Scope (E);
+ end if;
+
while Se /= Gen_Scope loop
if Se = Standard_Standard then
return True;
@@ -16169,16 +16231,11 @@ package body Sem_Ch12 is
pragma Assert (D /= Union_Id (No_List));
-- Because No_List = Empty, which is in Node_Range above
- if Is_Empty_List (List_Id (D)) then
- null;
-
- else
- N1 := First (List_Id (D));
- while Present (N1) loop
- Save_References (N1);
- Next (N1);
- end loop;
- end if;
+ N1 := First (List_Id (D));
+ while Present (N1) loop
+ Save_References (N1);
+ Next (N1);
+ end loop;
-- Element list or other non-node field, nothing to do
@@ -16280,10 +16337,6 @@ package body Sem_Ch12 is
Qual : Node_Id := Empty;
Typ : Entity_Id := Empty;
- use Atree.Unchecked_Access;
- -- This code section is part of implementing an untyped tree
- -- traversal, so it needs direct access to node fields.
-
begin
N2 := Get_Associated_Node (N);
@@ -16295,7 +16348,7 @@ package body Sem_Ch12 is
-- global in the current generic it must be preserved for its
-- instantiation.
- if Nkind (Parent (Typ)) = N_Subtype_Declaration
+ if Parent_Kind (Typ) = N_Subtype_Declaration
and then Present (Generic_Parent_Type (Parent (Typ)))
then
Typ := Base_Type (Typ);
@@ -16346,10 +16399,19 @@ package body Sem_Ch12 is
end if;
end if;
- Save_Global_Descendant (Field1 (N));
- Save_Global_Descendant (Field2 (N));
- Save_Global_Descendant (Field3 (N));
- Save_Global_Descendant (Field5 (N));
+ if Nkind (N) = N_Aggregate then
+ Save_Global_Descendant (Union_Id (Aggregate_Bounds (N)));
+
+ elsif Nkind (N) = N_Extension_Aggregate then
+ Save_Global_Descendant (Union_Id (Ancestor_Part (N)));
+
+ else
+ pragma Assert (False);
+ end if;
+
+ Save_Global_Descendant (Union_Id (Expressions (N)));
+ Save_Global_Descendant (Union_Id (Component_Associations (N)));
+ Save_Global_Descendant (Union_Id (Etype (N)));
if Present (Qual) then
Rewrite (N, Qual);
@@ -16377,16 +16439,9 @@ package body Sem_Ch12 is
------------------------------------
procedure Save_References_In_Descendants (N : Node_Id) is
- use Atree.Unchecked_Access;
- -- This code section is part of implementing an untyped tree
- -- traversal, so it needs direct access to node fields.
-
+ procedure Walk is new Walk_Sinfo_Fields (Save_Global_Descendant);
begin
- Save_Global_Descendant (Field1 (N));
- Save_Global_Descendant (Field2 (N));
- Save_Global_Descendant (Field3 (N));
- Save_Global_Descendant (Field4 (N));
- Save_Global_Descendant (Field5 (N));
+ Walk (N);
end Save_References_In_Descendants;
-----------------------------------
@@ -16591,10 +16646,6 @@ package body Sem_Ch12 is
Context : Node_Id;
Do_Save : Boolean := True;
- use Atree.Unchecked_Access;
- -- This code section is part of implementing an untyped tree
- -- traversal, so it needs direct access to node fields.
-
begin
-- Do not save global references in pragmas generated from aspects
-- because the pragmas will be regenerated at instantiation time.
@@ -16626,14 +16677,12 @@ package body Sem_Ch12 is
-- For all other cases, save all global references within the
-- descendants, but skip the following semantic fields:
-
- -- Field1 - Next_Pragma
- -- Field3 - Corresponding_Aspect
- -- Field5 - Next_Rep_Item
+ -- Next_Pragma, Corresponding_Aspect, Next_Rep_Item.
if Do_Save then
- Save_Global_Descendant (Field2 (Prag));
- Save_Global_Descendant (Field4 (Prag));
+ Save_Global_Descendant
+ (Union_Id (Pragma_Argument_Associations (N)));
+ Save_Global_Descendant (Union_Id (Pragma_Identifier (N)));
end if;
end Save_References_In_Pragma;
@@ -16975,4 +17024,424 @@ package body Sem_Ch12 is
end if;
end Valid_Default_Attribute;
+ ----------------------------------
+ -- Validate_Formal_Type_Default --
+ ----------------------------------
+
+ procedure Validate_Formal_Type_Default (Decl : Node_Id) is
+ Default : constant Node_Id :=
+ Default_Subtype_Mark (Original_Node (Decl));
+ Formal : constant Entity_Id := Defining_Identifier (Decl);
+
+ Def_Sub : Entity_Id; -- Default subtype mark
+ Type_Def : Node_Id;
+
+ procedure Check_Discriminated_Formal;
+ -- Check that discriminants of default for private or incomplete
+ -- type match those of formal type.
+
+ function Reference_Formal (N : Node_Id) return Traverse_Result;
+ -- Check whether formal type definition mentions a previous formal
+ -- type of the same generic.
+
+ ----------------------
+ -- Reference_Formal --
+ ----------------------
+
+ function Reference_Formal (N : Node_Id) return Traverse_Result is
+ begin
+ if Is_Entity_Name (N)
+ and then Scope (Entity (N)) = Current_Scope
+ then
+ return Abandon;
+ else
+ return OK;
+ end if;
+ end Reference_Formal;
+
+ function Depends_On_Other_Formals is
+ new Traverse_Func (Reference_Formal);
+
+ function Default_Subtype_Matches
+ (Gen_T, Def_T : Entity_Id) return Boolean;
+
+ procedure Validate_Array_Type_Default;
+ -- Verify that dimension, indices, and component types of default
+ -- are compatible with formal array type definition.
+
+ procedure Validate_Derived_Type_Default;
+ -- Verify that ancestor and progenitor types match.
+
+ ---------------------------------
+ -- Check_Discriminated_Formal --
+ ---------------------------------
+
+ procedure Check_Discriminated_Formal is
+ Formal_Discr : Entity_Id;
+ Actual_Discr : Entity_Id;
+ Formal_Subt : Entity_Id;
+
+ begin
+ if Has_Discriminants (Formal) then
+ if not Has_Discriminants (Def_Sub) then
+ Error_Msg_NE
+ ("default for & must have discriminants", Default, Formal);
+
+ elsif Is_Constrained (Def_Sub) then
+ Error_Msg_NE
+ ("default for & must be unconstrained", Default, Formal);
+
+ else
+ Formal_Discr := First_Discriminant (Formal);
+ Actual_Discr := First_Discriminant (Def_Sub);
+ while Formal_Discr /= Empty loop
+ if Actual_Discr = Empty then
+ Error_Msg_N
+ ("discriminants on Formal do not match formal",
+ Default);
+ end if;
+
+ Formal_Subt := Etype (Formal_Discr);
+
+ -- Access discriminants match if designated types do
+
+ if Ekind (Base_Type (Formal_Subt)) = E_Anonymous_Access_Type
+ and then (Ekind (Base_Type (Etype (Actual_Discr)))) =
+ E_Anonymous_Access_Type
+ and then
+ Designated_Type (Base_Type (Formal_Subt)) =
+ Designated_Type (Base_Type (Etype (Actual_Discr)))
+ then
+ null;
+
+ elsif Base_Type (Formal_Subt) /=
+ Base_Type (Etype (Actual_Discr))
+ then
+ Error_Msg_N
+ ("types of discriminants of default must match formal",
+ Default);
+
+ elsif not Subtypes_Statically_Match
+ (Formal_Subt, Etype (Actual_Discr))
+ and then Ada_Version >= Ada_95
+ then
+ Error_Msg_N
+ ("subtypes of discriminants of default "
+ & "must match formal",
+ Default);
+ end if;
+
+ Next_Discriminant (Formal_Discr);
+ Next_Discriminant (Actual_Discr);
+ end loop;
+
+ if Actual_Discr /= Empty then
+ Error_Msg_NE
+ ("discriminants on default do not match formal",
+ Default, Formal);
+ end if;
+ end if;
+ end if;
+ end Check_Discriminated_Formal;
+
+ ---------------------------
+ -- Default_Subtype_Matches --
+ ---------------------------
+
+ function Default_Subtype_Matches
+ (Gen_T, Def_T : Entity_Id) return Boolean
+ is
+ begin
+ -- Check that the base types, root types (when dealing with class
+ -- wide types), or designated types (when dealing with anonymous
+ -- access types) of Gen_T and Def_T are statically matching subtypes.
+
+ return (Base_Type (Gen_T) = Base_Type (Def_T)
+ and then Subtypes_Statically_Match (Gen_T, Def_T))
+
+ or else (Is_Class_Wide_Type (Gen_T)
+ and then Is_Class_Wide_Type (Def_T)
+ and then Default_Subtype_Matches
+ (Root_Type (Gen_T), Root_Type (Def_T)))
+
+ or else (Is_Anonymous_Access_Type (Gen_T)
+ and then Ekind (Def_T) = Ekind (Gen_T)
+ and then Subtypes_Statically_Match
+ (Designated_Type (Gen_T), Designated_Type (Def_T)));
+
+ end Default_Subtype_Matches;
+
+ ----------------------------------
+ -- Validate_Array_Type_Default --
+ ----------------------------------
+
+ procedure Validate_Array_Type_Default is
+ I1, I2 : Node_Id;
+ T2 : Entity_Id;
+ begin
+ if not Is_Array_Type (Def_Sub) then
+ Error_Msg_NE ("default for& must be an array type ",
+ Default, Formal);
+ return;
+
+ elsif Number_Dimensions (Def_Sub) /= Number_Dimensions (Formal)
+ or else Is_Constrained (Def_Sub) /=
+ Is_Constrained (Formal)
+ then
+ Error_Msg_NE ("default array type does not match&",
+ Default, Formal);
+ return;
+ end if;
+
+ I1 := First_Index (Formal);
+ I2 := First_Index (Def_Sub);
+ for J in 1 .. Number_Dimensions (Formal) loop
+
+ -- If the indexes of the actual were given by a subtype_mark,
+ -- the index was transformed into a range attribute. Retrieve
+ -- the original type mark for checking.
+
+ if Is_Entity_Name (Original_Node (I2)) then
+ T2 := Entity (Original_Node (I2));
+ else
+ T2 := Etype (I2);
+ end if;
+
+ if not Subtypes_Statically_Match (Etype (I1), T2) then
+ Error_Msg_NE
+ ("index types of default do not match those of formal &",
+ Default, Formal);
+ end if;
+
+ Next_Index (I1);
+ Next_Index (I2);
+ end loop;
+
+ if not Default_Subtype_Matches
+ (Component_Type (Formal), Component_Type (Def_Sub))
+ then
+ Error_Msg_NE
+ ("component subtype of default does not match that of formal &",
+ Default, Formal);
+ end if;
+
+ if Has_Aliased_Components (Formal)
+ and then not Has_Aliased_Components (Default)
+ then
+ Error_Msg_NE
+ ("default must have aliased components to match formal type &",
+ Default, Formal);
+ end if;
+ end Validate_Array_Type_Default;
+
+ -----------------------------------
+ -- Validate_Derived_Type_Default --
+ -----------------------------------
+
+ procedure Validate_Derived_Type_Default is
+ begin
+ if not Is_Ancestor (Etype (Formal), Def_Sub) then
+ Error_Msg_NE ("default must be a descendent of&",
+ Default, Etype (Formal));
+ end if;
+
+ if Has_Interfaces (Formal) then
+ if not Has_Interfaces (Def_Sub) then
+ Error_Msg_NE
+ ("default must implement all interfaces of formal&",
+ Default, Formal);
+
+ else
+ declare
+ Act_Iface_List : Elist_Id;
+ Iface : Node_Id;
+ Iface_Ent : Entity_Id;
+
+ begin
+ Iface := First (Abstract_Interface_List (Formal));
+ Collect_Interfaces (Def_Sub, Act_Iface_List);
+
+ while Present (Iface) loop
+ Iface_Ent := Entity (Iface);
+
+ if Is_Ancestor (Iface_Ent, Def_Sub)
+ or else Is_Progenitor (Iface_Ent, Def_Sub)
+ then
+ null;
+
+ else
+ Error_Msg_NE
+ ("Default must implement interface&",
+ Default, Etype (Iface));
+ end if;
+
+ Next (Iface);
+ end loop;
+ end;
+ end if;
+ end if;
+ end Validate_Derived_Type_Default;
+
+ -- Start of processing for Validate_Formal_Type_Default
+
+ begin
+ Analyze (Default);
+ if not Is_Entity_Name (Default)
+ or else not Is_Type (Entity (Default))
+ then
+ Error_Msg_N
+ ("Expect type name for default of formal type", Default);
+ return;
+ else
+ Def_Sub := Entity (Default);
+ end if;
+
+ -- Formal derived_type declarations are transformed into full
+ -- type declarations or Private_Type_Extensions for ease of processing.
+
+ if Nkind (Decl) = N_Full_Type_Declaration then
+ Type_Def := Type_Definition (Decl);
+
+ elsif Nkind (Decl) = N_Private_Extension_Declaration then
+ Type_Def := Subtype_Indication (Decl);
+
+ else
+ Type_Def := Formal_Type_Definition (Decl);
+ end if;
+
+ if Depends_On_Other_Formals (Type_Def) = Abandon
+ and then Scope (Def_Sub) /= Current_Scope
+ then
+ Error_Msg_N ("default of formal type that depends on "
+ & "other formals must be a previous formal type", Default);
+ return;
+
+ elsif Def_Sub = Formal then
+ Error_Msg_N
+ ("default for formal type cannot be formal itsef", Default);
+ return;
+ end if;
+
+ case Nkind (Type_Def) is
+
+ when N_Formal_Private_Type_Definition =>
+ if (Is_Abstract_Type (Formal)
+ and then not Is_Abstract_Type (Def_Sub))
+ or else (Is_Limited_Type (Formal)
+ and then not Is_Limited_Type (Def_Sub))
+ then
+ Error_Msg_NE
+ ("default for private type$ does not match",
+ Default, Formal);
+ end if;
+
+ Check_Discriminated_Formal;
+
+ when N_Formal_Derived_Type_Definition =>
+ Check_Discriminated_Formal;
+ Validate_Derived_Type_Default;
+
+ when N_Formal_Incomplete_Type_Definition =>
+ if Is_Tagged_Type (Formal)
+ and then not Is_Tagged_Type (Def_Sub)
+ then
+ Error_Msg_NE
+ ("default for & must be a tagged type", Default, Formal);
+ end if;
+
+ Check_Discriminated_Formal;
+
+ when N_Formal_Discrete_Type_Definition =>
+ if not Is_Discrete_Type (Def_Sub) then
+ Error_Msg_NE ("default for& must be a discrete type",
+ Default, Formal);
+ end if;
+
+ when N_Formal_Signed_Integer_Type_Definition =>
+ if not Is_Integer_Type (Def_Sub) then
+ Error_Msg_NE ("default for& must be a discrete type",
+ Default, Formal);
+ end if;
+
+ when N_Formal_Modular_Type_Definition =>
+ if not Is_Modular_Integer_Type (Def_Sub) then
+ Error_Msg_NE ("default for& must be a modular_integer Type",
+ Default, Formal);
+ end if;
+
+ when N_Formal_Floating_Point_Definition =>
+ if not Is_Floating_Point_Type (Def_Sub) then
+ Error_Msg_NE ("default for& must be a floating_point type",
+ Default, Formal);
+ end if;
+
+ when N_Formal_Ordinary_Fixed_Point_Definition =>
+ if not Is_Ordinary_Fixed_Point_Type (Def_Sub) then
+ Error_Msg_NE ("default for& must be "
+ & "an ordinary_fixed_point type ",
+ Default, Formal);
+ end if;
+
+ when N_Formal_Decimal_Fixed_Point_Definition =>
+ if not Is_Decimal_Fixed_Point_Type (Def_Sub) then
+ Error_Msg_NE ("default for& must be "
+ & "an Decimal_fixed_point type ",
+ Default, Formal);
+ end if;
+
+ when N_Array_Type_Definition =>
+ Validate_Array_Type_Default;
+
+ when N_Access_Function_Definition |
+ N_Access_Procedure_Definition =>
+ if Ekind (Def_Sub) /= E_Access_Subprogram_Type then
+ Error_Msg_NE ("default for& must be an Access_To_Subprogram",
+ Default, Formal);
+ end if;
+ Check_Subtype_Conformant
+ (Designated_Type (Formal), Designated_Type (Def_Sub));
+
+ when N_Access_To_Object_Definition =>
+ if not Is_Access_Object_Type (Def_Sub) then
+ Error_Msg_NE ("default for& must be an Access_To_Object",
+ Default, Formal);
+
+ elsif not Default_Subtype_Matches
+ (Designated_Type (Formal), Designated_Type (Def_Sub))
+ then
+ Error_Msg_NE ("designated type of defaul does not match "
+ & "designated type of formal type",
+ Default, Formal);
+ end if;
+
+ when N_Record_Definition => -- Formal interface type
+ if not Is_Interface (Def_Sub) then
+ Error_Msg_NE
+ ("default for formal interface type must be an interface",
+ Default, Formal);
+
+ elsif Is_Limited_Type (Def_Sub) /= Is_Limited_Type (Formal)
+ or else Is_Task_Interface (Formal) /= Is_Task_Interface (Def_Sub)
+ or else Is_Protected_Interface (Formal) /=
+ Is_Protected_Interface (Def_Sub)
+ or else Is_Synchronized_Interface (Formal) /=
+ Is_Synchronized_Interface (Def_Sub)
+ then
+ Error_Msg_NE
+ ("default for interface& does not match", Def_Sub, Formal);
+ end if;
+
+ when N_Derived_Type_Definition =>
+ Validate_Derived_Type_Default;
+
+ when N_Identifier => -- case of a private extension
+ Validate_Derived_Type_Default;
+
+ when N_Error =>
+ null;
+
+ when others =>
+ raise Program_Error;
+ end case;
+ end Validate_Formal_Type_Default;
end Sem_Ch12;
diff --git a/gcc/ada/sem_ch12.ads b/gcc/ada/sem_ch12.ads
index a568b26..2aee27c 100644
--- a/gcc/ada/sem_ch12.ads
+++ b/gcc/ada/sem_ch12.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute 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 4724e0e..76859c5 100644
--- a/gcc/ada/sem_ch13.adb
+++ b/gcc/ada/sem_ch13.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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,53 +23,57 @@
-- --
------------------------------------------------------------------------------
-with Aspects; use Aspects;
-with Atree; use Atree;
-with Checks; use Checks;
-with Debug; use Debug;
-with Einfo; use Einfo;
-with Elists; use Elists;
-with Errout; use Errout;
-with Exp_Disp; use Exp_Disp;
-with Exp_Tss; use Exp_Tss;
-with Exp_Util; use Exp_Util;
-with Freeze; use Freeze;
-with Ghost; use Ghost;
-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 Par_SCO; use Par_SCO;
-with Restrict; use Restrict;
-with Rident; use Rident;
-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;
-with Sem_Ch8; use Sem_Ch8;
-with Sem_Dim; use Sem_Dim;
-with Sem_Eval; use Sem_Eval;
-with Sem_Prag; use Sem_Prag;
-with Sem_Res; use Sem_Res;
-with Sem_Type; use Sem_Type;
-with Sem_Util; use Sem_Util;
-with Sem_Warn; use Sem_Warn;
-with Sinfo; use Sinfo;
-with Sinput; use Sinput;
-with Snames; use Snames;
-with Stand; use Stand;
+with Aspects; use Aspects;
+with Atree; use Atree;
+with Checks; use Checks;
+with Debug; use Debug;
+with Einfo; use Einfo;
+with Einfo.Entities; use Einfo.Entities;
+with Einfo.Utils; use Einfo.Utils;
+with Elists; use Elists;
+with Errout; use Errout;
+with Exp_Disp; use Exp_Disp;
+with Exp_Tss; use Exp_Tss;
+with Exp_Util; use Exp_Util;
+with Freeze; use Freeze;
+with Ghost; use Ghost;
+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 Par_SCO; use Par_SCO;
+with Restrict; use Restrict;
+with Rident; use Rident;
+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;
+with Sem_Ch8; use Sem_Ch8;
+with Sem_Dim; use Sem_Dim;
+with Sem_Eval; use Sem_Eval;
+with Sem_Prag; use Sem_Prag;
+with Sem_Res; use Sem_Res;
+with Sem_Type; use Sem_Type;
+with Sem_Util; use Sem_Util;
+with Sem_Warn; use Sem_Warn;
+with Sinfo; use Sinfo;
+with Sinfo.Nodes; use Sinfo.Nodes;
+with Sinfo.Utils; use Sinfo.Utils;
+with Sinput; use Sinput;
+with Snames; use Snames;
+with Stand; use Stand;
with Table;
-with Targparm; use Targparm;
-with Ttypes; use Ttypes;
-with Tbuild; use Tbuild;
-with Urealp; use Urealp;
-with Warnsw; use Warnsw;
+with Targparm; use Targparm;
+with Ttypes; use Ttypes;
+with Tbuild; use Tbuild;
+with Urealp; use Urealp;
+with Warnsw; use Warnsw;
with GNAT.Heap_Sort_G;
@@ -243,7 +247,7 @@ package body Sem_Ch13 is
-- 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
+ -- Check legality of operations given in the Ada 2022 Aggregate aspect for
-- containers.
procedure Resolve_Aspect_Aggregate
@@ -254,7 +258,7 @@ package body Sem_Ch13 is
procedure Validate_Aspect_Stable_Properties
(E : Entity_Id; N : Node_Id; Class_Present : Boolean);
- -- Check legality of functions given in the Ada 202x Stable_Properties
+ -- Check legality of functions given in the Ada 2022 Stable_Properties
-- (or Stable_Properties'Class) aspect.
procedure Resolve_Aspect_Stable_Properties
@@ -1029,7 +1033,7 @@ package body Sem_Ch13 is
end if;
-- For representation aspects, check for case of untagged derived
- -- type whose parent either has primitive operations (pre Ada 202x),
+ -- type whose parent either has primitive operations (pre Ada 2022),
-- 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.
@@ -1045,8 +1049,8 @@ package body Sem_Ch13 is
and then Has_Primitive_Operations (Parent_Type)
then
Error_Msg_N
- ("|representation aspect not permitted before Ada 202x: " &
- "use -gnat2020!", N);
+ ("|representation aspect not permitted before Ada 2022: " &
+ "use -gnat2022!", N);
Error_Msg_NE
("\parent type & has primitive operations!", N, Parent_Type);
@@ -1816,6 +1820,13 @@ package body Sem_Ch13 is
Aspect := First (L);
Aspect_Loop : while Present (Aspect) loop
Analyze_One_Aspect : declare
+
+ Aspect_Exit : exception;
+ -- This exception is used to exit aspect processing completely. It
+ -- is used when an error is detected, and no further processing is
+ -- required. It is also used if an earlier error has left the tree
+ -- in a state where the aspect should not be processed.
+
Expr : constant Node_Id := Expression (Aspect);
Id : constant Node_Id := Identifier (Aspect);
Loc : constant Source_Ptr := Sloc (Aspect);
@@ -1852,7 +1863,18 @@ package body Sem_Ch13 is
-- Perform analysis of aspect Yield
procedure Analyze_Aspect_Static;
- -- Ada 202x (AI12-0075): Perform analysis of aspect Static
+ -- Ada 2022 (AI12-0075): Perform analysis of aspect Static
+
+ procedure Check_Expr_Is_OK_Static_Expression
+ (Expr : Node_Id;
+ Typ : Entity_Id := Empty);
+ -- Check the specified expression Expr to make sure that it is a
+ -- static expression of the given type (i.e. it will be analyzed
+ -- and resolved using this type, which can be any valid argument
+ -- to Resolve, e.g. Any_Integer is OK). If not, give an error
+ -- and raise Aspect_Exit. If Typ is left Empty, then any static
+ -- expression is allowed. Includes checking that the expression
+ -- does not raise Constraint_Error.
function Make_Aitem_Pragma
(Pragma_Argument_Associations : List_Id;
@@ -2499,11 +2521,8 @@ package body Sem_Ch13 is
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);
-
+ if Ada_Version < Ada_2022 then
+ Error_Msg_Ada_2022_Feature ("aspect %", Sloc (Aspect));
return;
end if;
@@ -2539,14 +2558,14 @@ package body Sem_Ch13 is
return;
- -- Ada 202x (AI12-0075): Check that the function satisfies
+ -- Ada 2022 (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)).
+ -- potentially static expression (RM 2022 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
@@ -2594,8 +2613,9 @@ package body Sem_Ch13 is
for Asp in Pre_Post_Aspects loop
if Has_Aspect (E, Asp) then
+ Error_Msg_Name_1 := Aspect_Names (Asp);
Error_Msg_N
- ("this aspect is not allowed for a static "
+ ("aspect % is not allowed for a static "
& "expression function",
Find_Aspect (E, Asp));
@@ -2603,31 +2623,29 @@ package body Sem_Ch13 is
end if;
end loop;
- -- ??? TBD: Must check that "for result type R, if the
+ -- ??? 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. ???)
+ -- When the expression is present, it must be static. If it
+ -- evaluates to True, the expression function is treated as
+ -- a static function. Otherwise the aspect appears without
+ -- an expression and defaults to True.
- if Inside_A_Generic then
- if Present (Expr) then
- Preanalyze_And_Resolve (Expr, Any_Boolean);
- end if;
+ if Present (Expr) then
+ -- Preanalyze the expression 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. ???)
- -- Otherwise the aspect resides in a nongeneric context
+ if Inside_A_Generic then
+ Preanalyze_And_Resolve (Expr, Any_Boolean);
- 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.
+ -- Otherwise the aspect resides in a nongeneric context
- if Present (Expr) then
+ else
Analyze_And_Resolve (Expr, Any_Boolean);
-- Error if the boolean expression is not static
@@ -2715,6 +2733,42 @@ package body Sem_Ch13 is
end if;
end Analyze_Aspect_Yield;
+ ----------------------------------------
+ -- Check_Expr_Is_OK_Static_Expression --
+ ----------------------------------------
+
+ procedure Check_Expr_Is_OK_Static_Expression
+ (Expr : Node_Id;
+ Typ : Entity_Id := Empty)
+ is
+ begin
+ if Present (Typ) then
+ Analyze_And_Resolve (Expr, Typ);
+ else
+ Analyze_And_Resolve (Expr);
+ end if;
+
+ -- An expression cannot be considered static if its resolution
+ -- failed or if it's erroneous. Stop the analysis of the
+ -- related aspect.
+
+ if Etype (Expr) = Any_Type or else Error_Posted (Expr) then
+ raise Aspect_Exit;
+
+ elsif Is_OK_Static_Expression (Expr) then
+ return;
+
+ -- Finally, we have a real error
+
+ else
+ Error_Msg_Name_1 := Nam;
+ Flag_Non_Static_Expr
+ ("entity for aspect% must be a static expression",
+ Expr);
+ raise Aspect_Exit;
+ end if;
+ end Check_Expr_Is_OK_Static_Expression;
+
-----------------------
-- Make_Aitem_Pragma --
-----------------------
@@ -2878,8 +2932,11 @@ package body Sem_Ch13 is
-- versions of the language. Allowed for them only for
-- shared variable control aspects.
- if Nkind (N) = N_Formal_Type_Declaration then
- if Ada_Version < Ada_2020 then
+ -- Original node is used in case expansion rewrote the node -
+ -- as is the case with generic derived types.
+
+ if Nkind (Original_Node (N)) = N_Formal_Type_Declaration then
+ if Ada_Version < Ada_2022 then
Error_Msg_N
("aspect % not allowed for formal type declaration",
Aspect);
@@ -3325,6 +3382,13 @@ package body Sem_Ch13 is
| Aspect_Interrupt_Priority
| Aspect_Priority
=>
+ -- Verify the expression is static when Static_Priorities is
+ -- enabled.
+
+ if not Is_OK_Static_Expression (Expr) then
+ Check_Restriction (Static_Priorities, Expr);
+ end if;
+
if Nkind (N) in N_Subprogram_Body | N_Subprogram_Declaration
then
-- Analyze the aspect expression
@@ -3887,6 +3951,32 @@ package body Sem_Ch13 is
Insert_Pragma (Aitem);
goto Continue;
+ -- No_Controlled_Parts, No_Task_Parts
+
+ when Aspect_No_Controlled_Parts | Aspect_No_Task_Parts =>
+
+ -- Check appropriate type argument
+
+ if not Is_Type (E) then
+ Error_Msg_N
+ ("aspect % can only be applied to types", E);
+ end if;
+
+ -- Disallow subtypes
+
+ if Nkind (Declaration_Node (E)) = N_Subtype_Declaration then
+ Error_Msg_N
+ ("aspect % cannot be applied to subtypes", E);
+ end if;
+
+ -- Resolve the expression to a boolean
+
+ if Present (Expr) then
+ Check_Expr_Is_OK_Static_Expression (Expr, Any_Boolean);
+ end if;
+
+ goto Continue;
+
-- Obsolescent
when Aspect_Obsolescent => declare
@@ -4109,7 +4199,7 @@ package body Sem_Ch13 is
-- Case 2e: Annotate aspect
- when Aspect_Annotate =>
+ when Aspect_Annotate | Aspect_GNAT_Annotate =>
declare
Args : List_Id;
Pargs : List_Id;
@@ -4147,8 +4237,8 @@ package body Sem_Ch13 is
-- Must not be parenthesized
if Paren_Count (Expr) /= 0 then
- Error_Msg -- CODEFIX
- ("redundant parentheses", First_Sloc (Expr));
+ Error_Msg_F -- CODEFIX
+ ("redundant parentheses", Expr);
end if;
-- List of arguments is list of aggregate expressions
@@ -4243,7 +4333,7 @@ package body Sem_Ch13 is
goto Continue;
end if;
- if Ada_Version < Ada_2020 then
+ if Ada_Version < Ada_2022 then
Check_Restriction
(No_Implementation_Aspect_Specifications, N);
end if;
@@ -4442,8 +4532,8 @@ package body Sem_Ch13 is
-- parentheses).
if Paren_Count (Expr) /= 0 then
- Error_Msg -- CODEFIX
- ("redundant parentheses", First_Sloc (Expr));
+ Error_Msg_F -- CODEFIX
+ ("redundant parentheses", Expr);
goto Continue;
end if;
@@ -4560,7 +4650,7 @@ package body Sem_Ch13 is
Analyze_Aspect_Disable_Controlled;
goto Continue;
- -- Ada 202x (AI12-0129): Exclusive_Functions
+ -- Ada 2022 (AI12-0129): Exclusive_Functions
elsif A_Id = Aspect_Exclusive_Functions then
if Ekind (E) /= E_Protected_Type then
@@ -4573,22 +4663,18 @@ package body Sem_Ch13 is
goto Continue;
- -- Ada 202x (AI12-0363): Full_Access_Only
+ -- Ada 2022 (AI12-0363): Full_Access_Only
elsif A_Id = Aspect_Full_Access_Only then
- if Ada_Version < Ada_2020 then
- Error_Msg_N
- ("aspect % is an Ada 202x feature", Aspect);
- Error_Msg_N ("\compile with -gnat2020", Aspect);
- end if;
+ Error_Msg_Ada_2022_Feature ("aspect %", Sloc (Aspect));
- -- Ada 202x (AI12-0075): static expression functions
+ -- Ada 2022 (AI12-0075): static expression functions
elsif A_Id = Aspect_Static then
Analyze_Aspect_Static;
goto Continue;
- -- Ada 2020 (AI12-0279)
+ -- Ada 2022 (AI12-0279)
elsif A_Id = Aspect_Yield then
Analyze_Aspect_Yield;
@@ -4860,14 +4946,16 @@ package body Sem_Ch13 is
Error_Msg_Name_1 := Aspect_Names (A_Id);
Error_Msg_Sloc := Sloc (Inherited_Aspect);
- Error_Msg
+ Error_Msg_N
("overriding aspect specification for "
& "nonoverridable aspect % does not confirm "
& "aspect specification inherited from #",
- Sloc (Aspect));
+ Aspect);
end if;
end;
end if;
+ exception
+ when Aspect_Exit => null;
end Analyze_One_Aspect;
Next (Aspect);
@@ -5093,7 +5181,9 @@ package body Sem_Ch13 is
-- This routine checks if the aspect for U_Ent being given by attribute
-- definition clause N is for an aspect that has already been specified,
-- and if so gives an error message. If there is a duplicate, True is
- -- returned, otherwise if there is no error, False is returned.
+ -- returned, otherwise there is no error, and False is returned. Size
+ -- and Value_Size are considered to conflict, but for compatibility,
+ -- this is merely a warning.
procedure Check_Indexing_Functions;
-- Check that the function in Constant_Indexing or Variable_Indexing
@@ -5142,42 +5232,64 @@ package body Sem_Ch13 is
F := First_Formal (Subp);
- if No (F) or else Etype (F) /= Class_Wide_Type (RTE (RE_Sink)) then
+ if No (F) then
return False;
end if;
- Next_Formal (F);
+ if Base_Type (Etype (F))
+ /= Class_Wide_Type (RTE (RE_Root_Buffer_Type))
+ then
+ if Report then
+ Error_Msg_N
+ ("wrong type for Put_Image procedure''s first parameter",
+ Parameter_Type (Parent (F)));
+ end if;
- if Parameter_Mode (F) /= E_In_Parameter then
return False;
end if;
+ if Parameter_Mode (F) /= E_In_Out_Parameter then
+ if Report then
+ Error_Msg_N
+ ("wrong mode for Put_Image procedure''s first parameter",
+ Parent (F));
+ end if;
+
+ return False;
+ end if;
+
+ Next_Formal (F);
+
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 Base_Type (Typ) /= Base_Type (Ent) then
+ if Report then
+ Error_Msg_N
+ ("wrong type for Put_Image procedure''s second parameter",
+ Parameter_Type (Parent (F)));
+ end if;
- if Present (Next_Formal (F)) then
return False;
+ end if;
- elsif not Is_Scalar_Type (Typ)
- and then not Is_First_Subtype (Typ)
- then
- if Report and not Is_First_Subtype (Typ) then
+ if Parameter_Mode (F) /= E_In_Parameter then
+ if Report then
Error_Msg_N
- ("subtype of formal in Put_Image operation must be a "
- & "first subtype", Parameter_Type (Parent (F)));
+ ("wrong mode for Put_Image procedure''s second parameter",
+ Parent (F));
end if;
return False;
+ end if;
- else
- return True;
+ if Present (Next_Formal (F)) then
+ return False;
end if;
+
+ return True;
end Has_Good_Profile;
-- Start of processing for Analyze_Put_Image_TSS_Definition
@@ -5296,7 +5408,7 @@ package body Sem_Ch13 is
if No (F)
or else Ekind (Etype (F)) /= E_Anonymous_Access_Type
- or else Designated_Type (Etype (F)) /=
+ or else Base_Type (Designated_Type (Etype (F))) /=
Class_Wide_Type (RTE (RE_Root_Stream_Type))
then
return False;
@@ -5897,7 +6009,47 @@ package body Sem_Ch13 is
----------------------
function Duplicate_Clause return Boolean is
- A : Node_Id;
+
+ function Check_One_Attr (Attr_1, Attr_2 : Name_Id) return Boolean;
+ -- Check for one attribute; Attr_1 is the attribute_designator we are
+ -- looking for. Attr_2 is the attribute_designator of the current
+ -- node. Normally, this is called just once by Duplicate_Clause, with
+ -- Attr_1 = Attr_2. However, it needs to be called twice for Size and
+ -- Value_Size, because these mean the same thing. For compatibility,
+ -- we allow specifying both Size and Value_Size, but only if the two
+ -- sizes are equal.
+
+ --------------------
+ -- Check_One_Attr --
+ --------------------
+
+ function Check_One_Attr (Attr_1, Attr_2 : Name_Id) return Boolean is
+ A : constant Node_Id :=
+ Get_Rep_Item (U_Ent, Attr_1, Check_Parents => False);
+ begin
+ if Present (A) then
+ if Attr_1 = Attr_2 then
+ Error_Msg_Name_1 := Attr_1;
+ Error_Msg_Sloc := Sloc (A);
+ Error_Msg_NE ("aspect% for & previously given#", N, U_Ent);
+
+ else
+ pragma Assert (Attr_1 in Name_Size | Name_Value_Size);
+ pragma Assert (Attr_2 in Name_Size | Name_Value_Size);
+
+ Error_Msg_Name_1 := Attr_2;
+ Error_Msg_Name_2 := Attr_1;
+ Error_Msg_Sloc := Sloc (A);
+ Error_Msg_NE ("?% for & conflicts with % #", N, U_Ent);
+ end if;
+
+ return True;
+ end if;
+
+ return False;
+ end Check_One_Attr;
+
+ -- Start of processing for Duplicate_Clause
begin
-- Nothing to do if this attribute definition clause comes from
@@ -5909,21 +6061,20 @@ package body Sem_Ch13 is
return False;
end if;
- -- Otherwise current clause may duplicate previous clause, or a
- -- previously given pragma or aspect specification for the same
- -- aspect.
-
- A := Get_Rep_Item (U_Ent, Chars (N), Check_Parents => False);
-
- if Present (A) then
- Error_Msg_Name_1 := Chars (N);
- Error_Msg_Sloc := Sloc (A);
+ -- Special cases for Size and Value_Size
- Error_Msg_NE ("aspect% for & previously given#", N, U_Ent);
+ if (Chars (N) = Name_Size
+ and then Check_One_Attr (Name_Value_Size, Name_Size))
+ or else
+ (Chars (N) = Name_Value_Size
+ and then Check_One_Attr (Name_Size, Name_Value_Size))
+ then
return True;
end if;
- return False;
+ -- Normal case (including Size and Value_Size)
+
+ return Check_One_Attr (Chars (N), Chars (N));
end Duplicate_Clause;
-- Start of processing for Analyze_Attribute_Definition_Clause
@@ -7070,109 +7221,136 @@ package body Sem_Ch13 is
Set_SSO_Set_High_By_Default (Base_Type (U_Ent), False);
end if;
- ----------
- -- Size --
- ----------
+ ------------------------
+ -- Size or Value_Size --
+ ------------------------
- -- Size attribute definition clause
+ -- Size or Value_Size attribute definition clause. These are treated
+ -- the same, except that Size is allowed on objects, and Value_Size
+ -- is allowed on nonfirst subtypes. First subtypes allow both Size
+ -- and Value_Size; the treatment is the same for both.
- when Attribute_Size => Size : declare
+ when Attribute_Size | Attribute_Value_Size => Size : declare
Size : constant Uint := Static_Integer (Expr);
- Etyp : Entity_Id;
- Biased : Boolean;
+
+ Attr_Name : constant String :=
+ (if Id = Attribute_Size then "size"
+ elsif Id = Attribute_Value_Size then "value size"
+ else ""); -- can't happen
+ -- Name of the attribute for printing in messages
+
+ OK_Prefix : constant Boolean :=
+ (if Id = Attribute_Size then
+ Ekind (U_Ent) in Type_Kind | Constant_Or_Variable_Kind
+ elsif Id = Attribute_Value_Size then
+ Ekind (U_Ent) in Type_Kind
+ else False); -- can't happen
+ -- For X'Size, X can be a type or object; for X'Value_Size,
+ -- X can be a type. Note that we already checked that 'Size
+ -- can be specified only for a first subytype.
begin
FOnly := True;
- if Duplicate_Clause then
- null;
+ if not OK_Prefix then
+ Error_Msg_N (Attr_Name & " cannot be given for &", Nam);
- elsif not Is_Type (U_Ent)
- and then Ekind (U_Ent) /= E_Variable
- and then Ekind (U_Ent) /= E_Constant
- then
- Error_Msg_N ("size cannot be given for &", Nam);
+ elsif Duplicate_Clause then
+ null;
elsif Is_Array_Type (U_Ent)
and then not Is_Constrained (U_Ent)
then
Error_Msg_N
- ("size cannot be given for unconstrained array", Nam);
+ (Attr_Name & " cannot be given for unconstrained array", Nam);
elsif Size /= No_Uint then
- if Is_Type (U_Ent) then
- Etyp := U_Ent;
- else
- Etyp := Etype (U_Ent);
- end if;
+ declare
+ Etyp : constant Entity_Id :=
+ (if Is_Type (U_Ent) then U_Ent else Etype (U_Ent));
+
+ begin
+ -- Check size, note that Gigi is in charge of checking that
+ -- the size of an array or record type is OK. Also we do not
+ -- check the size in the ordinary fixed-point case, since
+ -- it is too early to do so (there may be subsequent small
+ -- clause that affects the size). We can check the size if
+ -- a small clause has already been given.
+
+ if not Is_Ordinary_Fixed_Point_Type (U_Ent)
+ or else Has_Small_Clause (U_Ent)
+ then
+ declare
+ Biased : Boolean;
+ begin
+ Check_Size (Expr, Etyp, Size, Biased);
+ Set_Biased (U_Ent, N, Attr_Name & " clause", Biased);
+ end;
+ end if;
- -- Check size, note that Gigi is in charge of checking that the
- -- size of an array or record type is OK. Also we do not check
- -- the size in the ordinary fixed-point case, since it is too
- -- early to do so (there may be subsequent small clause that
- -- affects the size). We can check the size if a small clause
- -- has already been given.
+ -- For types, set RM_Size and Esize if appropriate
- if not Is_Ordinary_Fixed_Point_Type (U_Ent)
- or else Has_Small_Clause (U_Ent)
- then
- Check_Size (Expr, Etyp, Size, Biased);
- Set_Biased (U_Ent, N, "size clause", Biased);
- end if;
+ if Is_Type (U_Ent) then
+ Set_RM_Size (U_Ent, Size);
- -- For types set RM_Size and Esize if possible
+ -- If we are specifying the Size or Value_Size of a
+ -- first subtype, then for elementary types, increase
+ -- Object_Size to power of 2, but not less than a storage
+ -- unit in any case (normally this means it will be byte
+ -- addressable).
- if Is_Type (U_Ent) then
- Set_RM_Size (U_Ent, Size);
+ -- For all other types, nothing else to do, we leave
+ -- Esize (object size) unset; the back end will set it
+ -- from the size and alignment in an appropriate manner.
- -- For elementary types, increase Object_Size to power of 2,
- -- but not less than a storage unit in any case (normally
- -- this means it will be byte addressable).
+ -- In both cases, we check whether the alignment must be
+ -- reset in the wake of the size change.
- -- For all other types, nothing else to do, we leave Esize
- -- (object size) unset, the back end will set it from the
- -- size and alignment in an appropriate manner.
+ -- For nonfirst subtypes ('Value_Size only), we do
+ -- nothing here.
- -- In both cases, we check whether the alignment must be
- -- reset in the wake of the size change.
+ if Is_First_Subtype (U_Ent) then
+ if Is_Elementary_Type (U_Ent) then
+ if Size <= System_Storage_Unit then
+ Init_Esize (U_Ent, System_Storage_Unit);
+ elsif Size <= 16 then
+ Init_Esize (U_Ent, 16);
+ elsif Size <= 32 then
+ Init_Esize (U_Ent, 32);
+ else
+ Set_Esize (U_Ent, (Size + 63) / 64 * 64);
+ end if;
- if Is_Elementary_Type (U_Ent) then
- if Size <= System_Storage_Unit then
- Init_Esize (U_Ent, System_Storage_Unit);
- elsif Size <= 16 then
- Init_Esize (U_Ent, 16);
- elsif Size <= 32 then
- Init_Esize (U_Ent, 32);
- else
- Set_Esize (U_Ent, (Size + 63) / 64 * 64);
+ Alignment_Check_For_Size_Change
+ (U_Ent, Esize (U_Ent));
+ else
+ Alignment_Check_For_Size_Change (U_Ent, Size);
+ end if;
end if;
- Alignment_Check_For_Size_Change (U_Ent, Esize (U_Ent));
- else
- Alignment_Check_For_Size_Change (U_Ent, Size);
- end if;
+ -- For Object'Size, set Esize only
- -- For objects, set Esize only
+ else
+ if Is_Elementary_Type (Etyp)
+ and then Size /= System_Storage_Unit
+ and then Size /= 16
+ and then Size /= 32
+ and then Size /= 64
+ and then Size /= System_Max_Integer_Size
+ then
+ Error_Msg_Uint_1 := UI_From_Int (System_Storage_Unit);
+ Error_Msg_Uint_2 :=
+ UI_From_Int (System_Max_Integer_Size);
+ Error_Msg_N
+ ("size for primitive object must be a power of 2 in "
+ & "the range ^-^", N);
+ end if;
- else
- if Is_Elementary_Type (Etyp)
- and then Size /= System_Storage_Unit
- and then Size /= 16
- and then Size /= 32
- and then Size /= 64
- and then Size /= System_Max_Integer_Size
- then
- Error_Msg_Uint_1 := UI_From_Int (System_Storage_Unit);
- Error_Msg_Uint_2 := UI_From_Int (System_Max_Integer_Size);
- Error_Msg_N
- ("size for primitive object must be a power of 2 in "
- & "the range ^-^", N);
+ Set_Esize (U_Ent, Size);
end if;
- Set_Esize (U_Ent, Size);
- end if;
-
- Set_Has_Size_Clause (U_Ent);
+ Set_Has_Size_Clause (U_Ent);
+ end;
end if;
end Size;
@@ -7438,9 +7616,7 @@ package body Sem_Ch13 is
-- type Q is access Float;
-- for Q'Storage_Size use T'Storage_Size; -- incorrect
- if RTE_Available (RE_Stack_Bounded_Pool)
- and then Base_Type (T) = RTE (RE_Stack_Bounded_Pool)
- then
+ if Is_RTE (Base_Type (T), RE_Stack_Bounded_Pool) then
Error_Msg_N ("non-shareable internal Pool", Expr);
return;
end if;
@@ -7636,39 +7812,6 @@ package body Sem_Ch13 is
end if;
end Stream_Size;
- ----------------
- -- Value_Size --
- ----------------
-
- -- Value_Size attribute definition clause
-
- when Attribute_Value_Size => Value_Size : declare
- Size : constant Uint := Static_Integer (Expr);
- Biased : Boolean;
-
- begin
- if not Is_Type (U_Ent) then
- Error_Msg_N ("Value_Size cannot be given for &", Nam);
-
- elsif Duplicate_Clause then
- null;
-
- elsif Is_Array_Type (U_Ent)
- and then not Is_Constrained (U_Ent)
- then
- Error_Msg_N
- ("Value_Size cannot be given for unconstrained array", Nam);
-
- else
- if Is_Elementary_Type (U_Ent) then
- Check_Size (Expr, U_Ent, Size, Biased);
- Set_Biased (U_Ent, N, "value size clause", Biased);
- end if;
-
- Set_RM_Size (U_Ent, Size);
- end if;
- end Value_Size;
-
-----------------------
-- Variable_Indexing --
-----------------------
@@ -7730,7 +7873,7 @@ package body Sem_Ch13 is
if Etype (Expression (N)) = Any_Type then
return;
- elsif Etype (Expression (N)) /= RTE (RE_Asm_Insn) then
+ elsif not Is_RTE (Etype (Expression (N)), RE_Asm_Insn) then
Error_Msg_N ("incorrect type for code statement", N);
return;
end if;
@@ -7909,9 +8052,17 @@ package body Sem_Ch13 is
-- Check that the expression is a proper aggregate (no parentheses)
elsif Paren_Count (Aggr) /= 0 then
- Error_Msg
- ("extra parentheses surrounding aggregate not allowed",
- First_Sloc (Aggr));
+ Error_Msg_F
+ ("extra parentheses surrounding aggregate not allowed", Aggr);
+ return;
+
+ -- Reject the mixing of named and positional entries in the aggregate
+
+ elsif Present (Expressions (Aggr))
+ and then Present (Component_Associations (Aggr))
+ then
+ Error_Msg_N ("cannot mix positional and named entries in "
+ & "enumeration rep clause", N);
return;
-- All tests passed, so set rep clause in place
@@ -7928,7 +8079,7 @@ package body Sem_Ch13 is
Elit := First_Literal (Enumtype);
- -- First the positional entries if any
+ -- Process positional entries
if Present (Expressions (Aggr)) then
Expr := First (Expressions (Aggr));
@@ -7950,18 +8101,19 @@ package body Sem_Ch13 is
elsif Val < Lo or else Hi < Val then
Error_Msg_N ("value outside permitted range", Expr);
Err := True;
+
+ else
+ Set_Enumeration_Rep (Elit, Val);
+ Set_Enumeration_Rep_Expr (Elit, Expr);
end if;
- Set_Enumeration_Rep (Elit, Val);
- Set_Enumeration_Rep_Expr (Elit, Expr);
Next (Expr);
Next (Elit);
end loop;
- end if;
- -- Now process the named entries if present
+ -- Process named entries
- if Present (Component_Associations (Aggr)) then
+ elsif Present (Component_Associations (Aggr)) then
Assoc := First (Component_Associations (Aggr));
while Present (Assoc) loop
Choice := First (Choices (Assoc));
@@ -8028,9 +8180,10 @@ package body Sem_Ch13 is
elsif Val < Lo or else Hi < Val then
Error_Msg_N ("value outside permitted range", Expr);
Err := True;
- end if;
- Set_Enumeration_Rep (Elit, Val);
+ else
+ Set_Enumeration_Rep (Elit, Val);
+ end if;
end if;
end if;
end if;
@@ -8124,9 +8277,10 @@ package body Sem_Ch13 is
Set_Enum_Esize (Enumtype);
end if;
- Set_RM_Size (Base_Type (Enumtype), RM_Size (Enumtype));
- Set_Esize (Base_Type (Enumtype), Esize (Enumtype));
- Set_Alignment (Base_Type (Enumtype), Alignment (Enumtype));
+ Set_RM_Size (Base_Type (Enumtype), RM_Size (Enumtype));
+ Set_Esize (Base_Type (Enumtype), Esize (Enumtype));
+
+ Copy_Alignment (To => Base_Type (Enumtype), From => Enumtype);
end;
end if;
@@ -8466,7 +8620,7 @@ package body Sem_Ch13 is
Generate_Reference
(Comp, Component_Name (CC), Set_Ref => False);
- Set_Entity (Component_Name (CC), Comp);
+ Set_Entity_With_Checks (Component_Name (CC), Comp);
-- Update Fbit and Lbit to the actual bit number
@@ -9985,19 +10139,31 @@ package body Sem_Ch13 is
-- Start of processing for Build_Predicate_Functions
begin
- -- Return if already built or if type does not have predicates
+ -- Return if already built, if type does not have predicates,
+ -- or if type is a constructed subtype that will inherit a
+ -- predicate function from its ancestor. In a generic context
+ -- the predicated parent may not have a predicate function yet
+ -- but we don't want to build a new one for the subtype. This can
+ -- happen in an instance body which is nested within a generic
+ -- unit, in which case Within_A_Generic may be false, SId is
+ -- Empty, but uses of Typ will receive a predicate check in a
+ -- context where expansion and tests are enabled.
SId := Predicate_Function (Typ);
if not Has_Predicates (Typ)
or else (Present (SId) and then Has_Completion (SId))
+ or else
+ (Is_Itype (Typ)
+ and then not Comes_From_Source (Typ)
+ and then Present (Predicated_Parent (Typ)))
then
return;
- -- Do not generate predicate bodies within a generic unit. The
- -- expressions have been analyzed already, and the bodies play
- -- no role if not within an executable unit. However, if a statc
- -- predicate is present it must be processed for legality checks
- -- such as case coverage in an expression.
+ -- Do not generate predicate bodies within a generic unit. The
+ -- expressions have been analyzed already, and the bodies play no role
+ -- if not within an executable unit. However, if a static predicate is
+ -- present it must be processed for legality checks such as case
+ -- coverage in an expression.
elsif Inside_A_Generic
and then not Has_Static_Predicate_Aspect (Typ)
@@ -10126,7 +10292,7 @@ package body Sem_Ch13 is
FBody : Node_Id;
begin
- Set_Ekind (SIdB, E_Function);
+ Mutate_Ekind (SIdB, E_Function);
Set_Is_Predicate_Function (SIdB);
-- Build function body
@@ -10260,7 +10426,7 @@ package body Sem_Ch13 is
-- Build function declaration
- Set_Ekind (SId, E_Function);
+ Mutate_Ekind (SId, E_Function);
Set_Is_Predicate_Function_M (SId);
Set_Predicate_Function_M (Typ, SId);
@@ -10475,7 +10641,7 @@ package body Sem_Ch13 is
Make_Defining_Identifier (Loc,
Chars => New_External_Name (Chars (Typ), "Predicate"));
- Set_Ekind (Func_Id, E_Function);
+ Mutate_Ekind (Func_Id, E_Function);
Set_Etype (Func_Id, Standard_Boolean);
Set_Is_Internal (Func_Id);
Set_Is_Predicate_Function (Func_Id);
@@ -10545,7 +10711,7 @@ package body Sem_Ch13 is
-- in particular, it has no type.
Err : Boolean;
- -- Set False if error
+ -- Set True if error
-- On entry to this procedure, Entity (Ident) contains a copy of the
-- original expression from the aspect, saved for this purpose, and
@@ -10661,7 +10827,9 @@ package body Sem_Ch13 is
-- also make its potential components accessible.
if not Analyzed (Freeze_Expr) and then Inside_A_Generic then
- if A_Id in Aspect_Dynamic_Predicate | Aspect_Predicate then
+ if A_Id in Aspect_Dynamic_Predicate | Aspect_Predicate |
+ Aspect_Static_Predicate
+ then
Push_Type (Ent);
Preanalyze_Spec_Expression (Freeze_Expr, Standard_Boolean);
Pop_Type (Ent);
@@ -10679,7 +10847,9 @@ package body Sem_Ch13 is
-- Indicate that the expression comes from an aspect specification,
-- which is used in subsequent analysis even if expansion is off.
- Set_Parent (End_Decl_Expr, ASN);
+ if Present (End_Decl_Expr) then
+ Set_Parent (End_Decl_Expr, ASN);
+ end if;
-- In a generic context the original aspect expressions have not
-- been preanalyzed, so do it now. There are no conformance checks
@@ -10690,6 +10860,7 @@ package body Sem_Ch13 is
if A_Id in Aspect_Dynamic_Predicate
| Aspect_Predicate
| Aspect_Priority
+ | Aspect_Static_Predicate
then
Push_Type (Ent);
Check_Aspect_At_Freeze_Point (ASN);
@@ -10717,6 +10888,7 @@ package body Sem_Ch13 is
| Aspect_Dynamic_Predicate
| Aspect_Predicate
| Aspect_Priority
+ | Aspect_Static_Predicate
then
Push_Type (Ent);
Preanalyze_Spec_Expression (End_Decl_Expr, T);
@@ -10988,6 +11160,7 @@ package body Sem_Ch13 is
| Aspect_Extensions_Visible
| Aspect_Ghost
| Aspect_Global
+ | Aspect_GNAT_Annotate
| Aspect_Implicit_Dereference
| Aspect_Initial_Condition
| Aspect_Initializes
@@ -10995,6 +11168,8 @@ package body Sem_Ch13 is
| Aspect_Max_Entry_Queue_Length
| Aspect_Max_Queue_Length
| Aspect_No_Caching
+ | Aspect_No_Controlled_Parts
+ | Aspect_No_Task_Parts
| Aspect_Obsolescent
| Aspect_Part_Of
| Aspect_Post
@@ -11803,6 +11978,8 @@ package body Sem_Ch13 is
end;
end Check_Component_List;
+ -- Local variables
+
Sbit : Uint;
-- Starting bit for call to Check_Component_List. Zero for an
-- untagged type. The size of the Tag for a nonderived tagged
@@ -12242,7 +12419,7 @@ package body Sem_Ch13 is
-- length (it may for example be appropriate to round up the size
-- to some convenient boundary, based on alignment considerations, etc).
- if Unknown_RM_Size (Rectype)
+ if not Known_RM_Size (Rectype)
and then Hbit + 1 <= 32
and then not Strict_Alignment (Rectype)
then
@@ -12301,7 +12478,7 @@ package body Sem_Ch13 is
-- Reject patently improper size values
if Is_Elementary_Type (T)
- and then Siz > UI_From_Int (Int'Last)
+ and then Siz > Int'Last
then
Error_Msg_N ("Size value too large for elementary type", N);
@@ -12368,8 +12545,6 @@ package body Sem_Ch13 is
else
Size_Too_Small_Error (Asiz);
- Set_Esize (T, Asiz);
- Set_RM_Size (T, Asiz);
end if;
end;
@@ -12407,8 +12582,6 @@ package body Sem_Ch13 is
if Siz < M then
Size_Too_Small_Error (M);
- Set_Esize (T, M);
- Set_RM_Size (T, M);
else
Biased := True;
end if;
@@ -13290,6 +13463,16 @@ package body Sem_Ch13 is
Set_Is_Ada_2012_Only (Typ);
end if;
+ -- Ada_2022
+
+ if not Has_Rep_Item (Typ, Name_Ada_2022, False)
+ and then Has_Rep_Item (Typ, Name_Ada_2022)
+ and then Is_Pragma_Or_Corr_Pragma_Present_In_Rep_Item
+ (Get_Rep_Item (Typ, Name_Ada_2022))
+ then
+ Set_Is_Ada_2022_Only (Typ);
+ end if;
+
-- Atomic/Shared
if not Has_Rep_Item (Typ, Name_Atomic, Name_Shared, False)
@@ -13472,7 +13655,8 @@ package body Sem_Ch13 is
Address_Clause_Checks.Init;
Unchecked_Conversions.Init;
- -- ??? Might be needed in the future for some non GCC back-ends
+ -- The following might be needed in the future for some non-GCC back
+ -- ends:
-- if AAMP_On_Target then
-- Independence_Checks.Init;
-- end if;
@@ -14051,7 +14235,7 @@ package body Sem_Ch13 is
begin
Subp_Id := Make_Defining_Identifier (Loc, Sname);
- -- S : Sink'Class
+ -- S : Root_Buffer_Type'Class
Formals := New_List (
Make_Parameter_Specification (Loc,
@@ -14404,7 +14588,7 @@ package body Sem_Ch13 is
and then (Nkind (N) /= N_Pragma
or else Get_Pragma_Id (N) /= Pragma_Convention)
then
- if Ada_Version < Ada_2020 then
+ if Ada_Version < Ada_2022 then
Error_Msg_N
("representation item not allowed for generic type", N);
return True;
@@ -14526,7 +14710,7 @@ package body Sem_Ch13 is
return True;
-- Check for case of untagged derived type whose parent either has
- -- primitive operations (pre Ada 202x), or is a by-reference type (RM
+ -- primitive operations (pre Ada 2022), 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.
@@ -14546,7 +14730,7 @@ package body Sem_Ch13 is
and then Has_Primitive_Operations (Parent_Type)
then
Error_Msg_N
- ("|representation item not permitted before Ada 202x!", N);
+ ("|representation item not permitted before Ada 2022!", N);
Error_Msg_NE
("\parent type & has primitive operations!", N, Parent_Type);
return True;
@@ -14907,9 +15091,15 @@ package body Sem_Ch13 is
or else N /= Selector_Name (Parent (N)))
then
Find_Direct_Name (N);
- Set_Entity (N, Empty);
- -- The name is component association needs no resolution.
+ -- Reset the Entity if N is overloaded since the entity may not
+ -- be the correct one.
+
+ if Is_Overloaded (N) then
+ Set_Entity (N, Empty);
+ end if;
+
+ -- The name in a component association needs no resolution
elsif Nkind (N) = N_Component_Association then
Dummy := Resolve_Name (Expression (N));
@@ -14931,10 +15121,6 @@ package body Sem_Ch13 is
-- Start of processing for Resolve_Aspect_Expressions
begin
- if No (ASN) then
- return;
- end if;
-
while Present (ASN) loop
if Nkind (ASN) = N_Aspect_Specification and then Entity (ASN) = E then
declare
@@ -14953,34 +15139,29 @@ package body Sem_Ch13 is
-- 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).
+ -- types. These will require special handling???.
when Aspect_Invariant
- | Aspect_Predicate
| Aspect_Predicate_Failure
=>
null;
when Aspect_Dynamic_Predicate
| Aspect_Static_Predicate
+ | Aspect_Predicate
=>
- -- Build predicate function specification and preanalyze
- -- expression after type replacement. The function
- -- declaration must be analyzed in the scope of the type,
- -- but the expression can reference components and
- -- discriminants of the type.
+ -- Preanalyze expression after type replacement to catch
+ -- name resolution errors if the predicate function has
+ -- not been built yet.
+ -- Note that we cannot use Preanalyze_Spec_Expression
+ -- because of the special handling required for
+ -- quantifiers, see comments on Resolve_Aspect_Expression
+ -- above.
if No (Predicate_Function (E)) then
- declare
- FDecl : constant Node_Id :=
- Build_Predicate_Function_Declaration (E);
- pragma Unreferenced (FDecl);
-
- begin
- Push_Type (E);
- Resolve_Aspect_Expression (Expr);
- Pop_Type (E);
- end;
+ Push_Type (E);
+ Resolve_Aspect_Expression (Expr);
+ Pop_Type (E);
end if;
when Pre_Post_Aspects =>
@@ -14994,7 +15175,11 @@ package body Sem_Ch13 is
begin
Assoc := First (Component_Associations (Expr));
while Present (Assoc) loop
- Find_Direct_Name (Expression (Assoc));
+ if Nkind (Expression (Assoc)) in N_Has_Entity
+ then
+ Find_Direct_Name (Expression (Assoc));
+ end if;
+
Next (Assoc);
end loop;
end;
@@ -15167,7 +15352,7 @@ package body Sem_Ch13 is
Assign_Indexed_Subp : Node_Id := Empty;
begin
- Error_Msg_Ada_2020_Feature ("aspect Aggregate", Sloc (N));
+ Error_Msg_Ada_2022_Feature ("aspect Aggregate", Sloc (N));
if Nkind (N) /= N_Aggregate
or else Present (Expressions (N))
@@ -15286,7 +15471,7 @@ package body Sem_Ch13 is
-- Start of processing for Validate_Aspect_Stable_Properties
begin
- Error_Msg_Ada_2020_Feature ("aspect Stable_Properties", Sloc (N));
+ Error_Msg_Ada_2022_Feature ("aspect Stable_Properties", Sloc (N));
if (not Is_Aspect_Of_Type) and then (not Is_Subprogram (E)) then
Error_Msg_N ("Stable_Properties aspect can only be specified for "
@@ -16118,9 +16303,13 @@ package body Sem_Ch13 is
X_Offs : Uint;
begin
- -- Skip processing of this entry if warning already posted
+ -- Skip processing of this entry if warning already posted, or if
+ -- alignments are not set.
- if not Address_Warning_Posted (ACCR.N) then
+ if not Address_Warning_Posted (ACCR.N)
+ and then Known_Alignment (ACCR.X)
+ and then Known_Alignment (ACCR.Y)
+ then
Expr := Original_Node (Expression (ACCR.N));
-- Get alignments, sizes and offset, if any
@@ -16492,18 +16681,7 @@ package body Sem_Ch13 is
-- here because the processing for generic instantiation always makes
-- subtypes, and we want the original frozen actual types.
- -- If we are dealing with private types, then do the check on their
- -- fully declared counterparts if the full declarations have been
- -- encountered (they don't have to be visible, but they must exist).
-
Source := Ancestor_Subtype (Etype (First_Formal (Act_Unit)));
-
- if Is_Private_Type (Source)
- and then Present (Underlying_Type (Source))
- then
- Source := Underlying_Type (Source);
- end if;
-
Target := Ancestor_Subtype (Etype (Act_Unit));
-- If either type is generic, the instantiation happens within a generic
@@ -16514,6 +16692,16 @@ package body Sem_Ch13 is
return;
end if;
+ -- If we are dealing with private types, then do the check on their
+ -- fully declared counterparts if the full declarations have been
+ -- encountered (they don't have to be visible, but they must exist).
+
+ if Is_Private_Type (Source)
+ and then Present (Underlying_Type (Source))
+ then
+ Source := Underlying_Type (Source);
+ end if;
+
if Is_Private_Type (Target)
and then Present (Underlying_Type (Target))
then
@@ -16606,8 +16794,8 @@ package body Sem_Ch13 is
-- in the same unit as the unchecked conversion, then set the flag
-- No_Strict_Aliasing (no strict aliasing is implicit here)
- if Is_Access_Type (Target) and then
- In_Same_Source_Unit (Target, N)
+ if Is_Access_Type (Target)
+ and then In_Same_Source_Unit (Target, N)
then
Set_No_Strict_Aliasing (Implementation_Base_Type (Target));
end if;
diff --git a/gcc/ada/sem_ch13.ads b/gcc/ada/sem_ch13.ads
index e2ea55a..3b21484 100644
--- a/gcc/ada/sem_ch13.ads
+++ b/gcc/ada/sem_ch13.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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,18 +115,17 @@ package Sem_Ch13 is
Siz : Uint;
Biased : out Boolean);
-- Called when size Siz is specified for subtype T. This subprogram checks
- -- that the size is appropriate, posting errors on node N as required.
- -- This check is effective for elementary types and bit-packed arrays.
- -- For other non-elementary types, a check is only made if an explicit
- -- size has been given for the type (and the specified size must match).
- -- The parameter Biased is set False if the size specified did not require
- -- the use of biased representation, and True if biased representation
- -- was required to meet the size requirement. Note that Biased is only
- -- set if the type is not currently biased, but biasing it is the only
- -- way to meet the requirement. If the type is currently biased, then
- -- this biased size is used in the initial check, and Biased is False.
- -- 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.
+ -- that the size is appropriate, posting errors on node N as required. This
+ -- check is effective for elementary types and bit-packed arrays. For
+ -- composite types, a check is only made if an explicit size has been given
+ -- for the type (and the specified size must match). The parameter Biased
+ -- is set False if the size specified did not require the use of biased
+ -- representation, and True if biased representation was required to meet
+ -- the size requirement. Note that Biased is only set if the type is not
+ -- currently biased, but biasing it is the only way to meet the
+ -- requirement. If the type is currently biased, then this biased size is
+ -- used in the initial check, and Biased is False. For a Component_Size
+ -- clause, T is the component type.
function Has_Compatible_Representation
(Target_Type, Operand_Type : Entity_Id) return Boolean;
diff --git a/gcc/ada/sem_ch2.adb b/gcc/ada/sem_ch2.adb
index d57941f..3ba68c4 100644
--- a/gcc/ada/sem_ch2.adb
+++ b/gcc/ada/sem_ch2.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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,17 +23,19 @@
-- --
------------------------------------------------------------------------------
-with Atree; use Atree;
-with Einfo; use Einfo;
-with Namet; use Namet;
-with Opt; use Opt;
-with Restrict; use Restrict;
-with Rident; use Rident;
-with Sem_Ch8; use Sem_Ch8;
-with Sem_Dim; use Sem_Dim;
-with Sinfo; use Sinfo;
-with Stand; use Stand;
-with Uintp; use Uintp;
+with Atree; use Atree;
+with Einfo; use Einfo;
+with Einfo.Utils; use Einfo.Utils;
+with Namet; use Namet;
+with Opt; use Opt;
+with Restrict; use Restrict;
+with Rident; use Rident;
+with Sem_Ch8; use Sem_Ch8;
+with Sem_Dim; use Sem_Dim;
+with Sinfo; use Sinfo;
+with Sinfo.Nodes; use Sinfo.Nodes;
+with Stand; use Stand;
+with Uintp; use Uintp;
package body Sem_Ch2 is
diff --git a/gcc/ada/sem_ch2.ads b/gcc/ada/sem_ch2.ads
index a28d85f..ce116ef 100644
--- a/gcc/ada/sem_ch2.ads
+++ b/gcc/ada/sem_ch2.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute 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 4c7b8e7..e9b4456 100644
--- a/gcc/ada/sem_ch3.adb
+++ b/gcc/ada/sem_ch3.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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,63 +23,67 @@
-- --
------------------------------------------------------------------------------
-with Aspects; use Aspects;
-with Atree; use Atree;
-with Checks; use Checks;
-with Contracts; use Contracts;
-with Debug; use Debug;
-with Elists; use Elists;
-with Einfo; use Einfo;
-with Errout; use Errout;
-with Eval_Fat; use Eval_Fat;
-with Exp_Ch3; use Exp_Ch3;
-with Exp_Ch9; use Exp_Ch9;
-with Exp_Disp; use Exp_Disp;
-with Exp_Dist; use Exp_Dist;
-with Exp_Tss; use Exp_Tss;
-with Exp_Util; use Exp_Util;
-with Freeze; use Freeze;
-with Ghost; use Ghost;
-with Itypes; use Itypes;
-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;
-with Rident; use Rident;
-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_Ch6; use Sem_Ch6;
-with Sem_Ch7; use Sem_Ch7;
-with Sem_Ch8; use Sem_Ch8;
-with Sem_Ch13; use Sem_Ch13;
-with Sem_Dim; use Sem_Dim;
-with Sem_Disp; use Sem_Disp;
-with Sem_Dist; use Sem_Dist;
-with Sem_Elab; use Sem_Elab;
-with Sem_Elim; use Sem_Elim;
-with Sem_Eval; use Sem_Eval;
-with Sem_Mech; use Sem_Mech;
-with Sem_Res; use Sem_Res;
-with Sem_Smem; use Sem_Smem;
-with Sem_Type; use Sem_Type;
-with Sem_Util; use Sem_Util;
-with Sem_Warn; use Sem_Warn;
-with Stand; use Stand;
-with Sinfo; use Sinfo;
-with Sinput; use Sinput;
-with Snames; use Snames;
-with Targparm; use Targparm;
-with Tbuild; use Tbuild;
-with Ttypes; use Ttypes;
-with Uintp; use Uintp;
-with Urealp; use Urealp;
+with Aspects; use Aspects;
+with Atree; use Atree;
+with Checks; use Checks;
+with Contracts; use Contracts;
+with Debug; use Debug;
+with Elists; use Elists;
+with Einfo; use Einfo;
+with Einfo.Entities; use Einfo.Entities;
+with Einfo.Utils; use Einfo.Utils;
+with Errout; use Errout;
+with Eval_Fat; use Eval_Fat;
+with Exp_Ch3; use Exp_Ch3;
+with Exp_Ch9; use Exp_Ch9;
+with Exp_Disp; use Exp_Disp;
+with Exp_Dist; use Exp_Dist;
+with Exp_Tss; use Exp_Tss;
+with Exp_Util; use Exp_Util;
+with Freeze; use Freeze;
+with Ghost; use Ghost;
+with Itypes; use Itypes;
+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;
+with Rident; use Rident;
+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_Ch6; use Sem_Ch6;
+with Sem_Ch7; use Sem_Ch7;
+with Sem_Ch8; use Sem_Ch8;
+with Sem_Ch13; use Sem_Ch13;
+with Sem_Dim; use Sem_Dim;
+with Sem_Disp; use Sem_Disp;
+with Sem_Dist; use Sem_Dist;
+with Sem_Elab; use Sem_Elab;
+with Sem_Elim; use Sem_Elim;
+with Sem_Eval; use Sem_Eval;
+with Sem_Mech; use Sem_Mech;
+with Sem_Res; use Sem_Res;
+with Sem_Smem; use Sem_Smem;
+with Sem_Type; use Sem_Type;
+with Sem_Util; use Sem_Util;
+with Sem_Warn; use Sem_Warn;
+with Stand; use Stand;
+with Sinfo; use Sinfo;
+with Sinfo.Nodes; use Sinfo.Nodes;
+with Sinfo.Utils; use Sinfo.Utils;
+with Sinput; use Sinput;
+with Snames; use Snames;
+with Targparm; use Targparm;
+with Tbuild; use Tbuild;
+with Ttypes; use Ttypes;
+with Uintp; use Uintp;
+with Urealp; use Urealp;
package body Sem_Ch3 is
@@ -245,11 +249,12 @@ package body Sem_Ch3 is
-- belongs must be a concurrent type or a descendant of a type with
-- the reserved word 'limited' in its declaration.
- procedure Check_Anonymous_Access_Components
- (Typ_Decl : Node_Id;
- Typ : Entity_Id;
- Prev : Entity_Id;
- Comp_List : Node_Id);
+ procedure Check_Anonymous_Access_Component
+ (Typ_Decl : Node_Id;
+ Typ : Entity_Id;
+ Prev : Entity_Id;
+ Comp_Def : Node_Id;
+ Access_Def : Node_Id);
-- Ada 2005 AI-382: an access component in a record definition can refer to
-- the enclosing record, in which case it denotes the type itself, and not
-- the current instance of the type. We create an anonymous access type for
@@ -259,6 +264,13 @@ 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_Anonymous_Access_Components
+ (Typ_Decl : Node_Id;
+ Typ : Entity_Id;
+ Prev : Entity_Id;
+ Comp_List : Node_Id);
+ -- Call Check_Anonymous_Access_Component on Comp_List
+
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
@@ -840,22 +852,15 @@ package body Sem_Ch3 is
-- the corresponding semantic routine
if Present (Access_To_Subprogram_Definition (N)) then
-
- -- Compiler runtime units are compiled in Ada 2005 mode when building
- -- the runtime library but must also be compilable in Ada 95 mode
- -- (when bootstrapping the compiler).
-
- Check_Compiler_Unit ("anonymous access to subprogram", N);
-
Access_Subprogram_Declaration
(T_Name => Anon_Type,
T_Def => Access_To_Subprogram_Definition (N));
if Ekind (Anon_Type) = E_Access_Protected_Subprogram_Type then
- Set_Ekind
+ Mutate_Ekind
(Anon_Type, E_Anonymous_Access_Protected_Subprogram_Type);
else
- Set_Ekind (Anon_Type, E_Anonymous_Access_Subprogram_Type);
+ Mutate_Ekind (Anon_Type, E_Anonymous_Access_Subprogram_Type);
end if;
Set_Can_Use_Internal_Rep
@@ -1285,10 +1290,10 @@ package body Sem_Ch3 is
Check_Delayed_Subprogram (Desig_Type);
if Protected_Present (T_Def) then
- Set_Ekind (T_Name, E_Access_Protected_Subprogram_Type);
+ Mutate_Ekind (T_Name, E_Access_Protected_Subprogram_Type);
Set_Convention (Desig_Type, Convention_Protected);
else
- Set_Ekind (T_Name, E_Access_Subprogram_Type);
+ Mutate_Ekind (T_Name, E_Access_Subprogram_Type);
end if;
Set_Can_Use_Internal_Rep (T_Name,
@@ -1312,6 +1317,8 @@ package body Sem_Ch3 is
Set_Can_Never_Be_Null (T_Name, Null_Exclusion_Present (T_Def));
Check_Restriction (No_Access_Subprograms, T_Def);
+
+ Create_Extra_Formals (Desig_Type);
end Access_Subprogram_Declaration;
----------------------------
@@ -1319,22 +1326,48 @@ package body Sem_Ch3 is
----------------------------
procedure Access_Type_Declaration (T : Entity_Id; Def : Node_Id) is
+
+ procedure Setup_Access_Type (Desig_Typ : Entity_Id);
+ -- After type declaration is analysed with T being an incomplete type,
+ -- this routine will mutate the kind of T to the appropriate access type
+ -- and set its directly designated type to Desig_Typ.
+
+ -----------------------
+ -- Setup_Access_Type --
+ -----------------------
+
+ procedure Setup_Access_Type (Desig_Typ : Entity_Id) is
+ begin
+ if All_Present (Def) or else Constant_Present (Def) then
+ Mutate_Ekind (T, E_General_Access_Type);
+ else
+ Mutate_Ekind (T, E_Access_Type);
+ end if;
+
+ Set_Directly_Designated_Type (T, Desig_Typ);
+ end Setup_Access_Type;
+
+ -- Local variables
+
P : constant Node_Id := Parent (Def);
S : constant Node_Id := Subtype_Indication (Def);
Full_Desig : Entity_Id;
+ -- Start of processing for Access_Type_Declaration
+
begin
-- Check for permissible use of incomplete type
if Nkind (S) /= N_Subtype_Indication then
+
Analyze (S);
if Nkind (S) in N_Has_Entity
and then Present (Entity (S))
and then Ekind (Root_Type (Entity (S))) = E_Incomplete_Type
then
- Set_Directly_Designated_Type (T, Entity (S));
+ Setup_Access_Type (Desig_Typ => Entity (S));
-- If the designated type is a limited view, we cannot tell if
-- the full view contains tasks, and there is no way to handle
@@ -1345,13 +1378,12 @@ package body Sem_Ch3 is
if From_Limited_With (Entity (S))
and then not Is_Class_Wide_Type (Entity (S))
then
- Set_Ekind (T, E_Access_Type);
Build_Master_Entity (T);
Build_Master_Renaming (T);
end if;
else
- Set_Directly_Designated_Type (T, Process_Subtype (S, P, T, 'P'));
+ Setup_Access_Type (Desig_Typ => Process_Subtype (S, P, T, 'P'));
end if;
-- If the access definition is of the form: ACCESS NOT NULL ..
@@ -1383,55 +1415,50 @@ package body Sem_Ch3 is
end if;
else
- Set_Directly_Designated_Type (T,
- Process_Subtype (S, P, T, 'P'));
+ Setup_Access_Type (Desig_Typ => Process_Subtype (S, P, T, 'P'));
end if;
- if All_Present (Def) or Constant_Present (Def) then
- Set_Ekind (T, E_General_Access_Type);
- else
- Set_Ekind (T, E_Access_Type);
- end if;
+ if not Error_Posted (T) then
+ Full_Desig := Designated_Type (T);
- Full_Desig := Designated_Type (T);
+ if Base_Type (Full_Desig) = T then
+ Error_Msg_N ("access type cannot designate itself", S);
- if Base_Type (Full_Desig) = T then
- Error_Msg_N ("access type cannot designate itself", S);
+ -- In Ada 2005, the type may have a limited view through some unit in
+ -- its own context, allowing the following circularity that cannot be
+ -- detected earlier.
- -- In Ada 2005, the type may have a limited view through some unit in
- -- its own context, allowing the following circularity that cannot be
- -- detected earlier.
+ elsif Is_Class_Wide_Type (Full_Desig) and then Etype (Full_Desig) = T
+ then
+ Error_Msg_N
+ ("access type cannot designate its own class-wide type", S);
- elsif Is_Class_Wide_Type (Full_Desig) and then Etype (Full_Desig) = T
- then
- Error_Msg_N
- ("access type cannot designate its own class-wide type", S);
+ -- Clean up indication of tagged status to prevent cascaded errors
- -- Clean up indication of tagged status to prevent cascaded errors
+ Set_Is_Tagged_Type (T, False);
+ end if;
- Set_Is_Tagged_Type (T, False);
- end if;
+ Set_Etype (T, T);
- Set_Etype (T, T);
+ -- For SPARK, check that the designated type is compatible with
+ -- respect to volatility with the access type.
- -- 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.
+ 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.
+ -- 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);
+ Check_Volatility_Compatibility
+ (Full_Desig, T, "designated type", "access type",
+ Srcpos_Bearer => T);
+ end if;
end if;
-- If the type has appeared already in a with_type clause, it is frozen
@@ -1519,7 +1546,7 @@ package body Sem_Ch3 is
Analyze_Component_Declaration (Decl);
Set_Analyzed (Decl);
- Set_Ekind (Tag, E_Component);
+ Mutate_Ekind (Tag, E_Component);
Set_Is_Tag (Tag);
Set_Is_Aliased (Tag);
Set_Is_Independent (Tag);
@@ -1560,7 +1587,7 @@ package body Sem_Ch3 is
Analyze_Component_Declaration (Decl);
Set_Analyzed (Decl);
- Set_Ekind (Offset, E_Component);
+ Mutate_Ekind (Offset, E_Component);
Set_Is_Aliased (Offset);
Set_Is_Independent (Offset);
Set_Related_Type (Offset, Iface);
@@ -1580,9 +1607,8 @@ package body Sem_Ch3 is
begin
if not RTE_Available (RE_Interface_Tag) then
- Error_Msg
- ("(Ada 2005) interface types not supported by this run-time!",
- Sloc (N));
+ Error_Msg_N
+ ("(Ada 2005) interface types not supported by this run-time!", N);
return;
end if;
@@ -1775,7 +1801,7 @@ package body Sem_Ch3 is
elsif not Comes_From_Source (Prim) then
Error_Msg_NE
("&inherits non-conforming preconditions and must "
- & "be overridden (RM 6.1.1 (10-16)",
+ & "be overridden (RM 6.1.1 (10-16))",
Parent (Tagged_Type), Prim);
end if;
end if;
@@ -2057,21 +2083,10 @@ package body Sem_Ch3 is
end if;
end if;
- -- Avoid reporting spurious errors if the component is initialized with
- -- a raise expression (which is legal in any expression context)
-
- if Present (E)
- and then
- (Nkind (E) = N_Raise_Expression
- or else (Nkind (E) = N_Qualified_Expression
- and then Nkind (Expression (E)) = N_Raise_Expression))
- then
- null;
-
-- The parent type may be a private view with unknown discriminants,
-- and thus unconstrained. Regular components must be constrained.
- elsif not Is_Definite_Subtype (T)
+ if not Is_Definite_Subtype (T)
and then Chars (Id) /= Name_uParent
then
if Is_Class_Wide_Type (T) then
@@ -2743,7 +2758,6 @@ package body Sem_Ch3 is
Resolve_Aspects;
elsif L /= Visible_Declarations (Parent (L))
- or else No (Private_Declarations (Parent (L)))
or else Is_Empty_List (Private_Declarations (Parent (L)))
then
Adjust_Decl;
@@ -2812,7 +2826,7 @@ package body Sem_Ch3 is
-- to the first encountered body.
-- ??? A cleaner approach may be possible and/or this solution
- -- could be extended to general-purpose late primitives, TBD.
+ -- could be extended to general-purpose late primitives.
if Present (Ctrl_Typ) then
@@ -3040,7 +3054,7 @@ package body Sem_Ch3 is
end if;
end if;
- -- TBD : other nonoverridable aspects.
+ -- What about other nonoverridable aspects???
end Check_Nonoverridable_Aspects;
------------------------------------
@@ -3057,6 +3071,7 @@ package body Sem_Ch3 is
and then Ekind (Prev) = E_Incomplete_Type
and then Is_Tagged_Type (Prev)
and then Is_Tagged_Type (T)
+ and then Present (Primitive_Operations (Prev))
then
Elmt := First_Elmt (Primitive_Operations (Prev));
while Present (Elmt) loop
@@ -3169,7 +3184,7 @@ package body Sem_Ch3 is
-- so that pre/postconditions can be handled directly on the
-- generated wrapper.
- if Ada_Version >= Ada_2020
+ if Ada_Version >= Ada_2022
and then Present (Aspect_Specifications (N))
then
Build_Access_Subprogram_Wrapper (N);
@@ -3246,6 +3261,40 @@ package body Sem_Ch3 is
return;
end if;
+ -- Set the primitives list of the full type and its base type when
+ -- needed. T may be E_Void in cases of earlier errors, and in that
+ -- case we bypass this.
+
+ if Ekind (T) /= E_Void
+ and then not Present (Direct_Primitive_Operations (T))
+ then
+ if Etype (T) = T then
+ Set_Direct_Primitive_Operations (T, New_Elmt_List);
+
+ -- If Etype of T is the base type (as opposed to a parent type) and
+ -- already has an associated list of primitive operations, then set
+ -- T's primitive list to the base type's list. Otherwise, create a
+ -- new empty primitives list and share the list between T and its
+ -- base type. The lists need to be shared in common between the two.
+
+ elsif Etype (T) = Base_Type (T) then
+
+ if not Present (Direct_Primitive_Operations (Base_Type (T))) then
+ Set_Direct_Primitive_Operations
+ (Base_Type (T), New_Elmt_List);
+ end if;
+
+ Set_Direct_Primitive_Operations
+ (T, Direct_Primitive_Operations (Base_Type (T)));
+
+ -- Case where the Etype is a parent type, so we need a new primitives
+ -- list for T.
+
+ else
+ Set_Direct_Primitive_Operations (T, New_Elmt_List);
+ end if;
+ end if;
+
-- Some common processing for all types
Set_Depends_On_Private (T, Has_Private_Component (T));
@@ -3398,7 +3447,7 @@ package body Sem_Ch3 is
T := Find_Type_Name (N);
- Set_Ekind (T, E_Incomplete_Type);
+ Mutate_Ekind (T, E_Incomplete_Type);
Set_Etype (T, T);
Set_Is_First_Subtype (T);
Init_Size_Align (T);
@@ -3478,9 +3527,7 @@ package body Sem_Ch3 is
-- Check runtime support for synchronized interfaces
- if (Is_Task_Interface (T)
- or else Is_Protected_Interface (T)
- or else Is_Synchronized_Interface (T))
+ if Is_Concurrent_Interface (T)
and then not RTE_Available (RE_Select_Specific_Data)
then
Error_Msg_CRT ("synchronized interfaces", T);
@@ -3522,7 +3569,7 @@ package body Sem_Ch3 is
Set_Etype (E, Universal_Integer);
Set_Etype (Id, Universal_Integer);
- Set_Ekind (Id, E_Named_Integer);
+ Mutate_Ekind (Id, E_Named_Integer);
Set_Is_Frozen (Id, True);
Set_Debug_Info_Needed (Id);
@@ -3567,10 +3614,7 @@ package body Sem_Ch3 is
if T = Any_Type then
T := It.Typ;
- elsif It.Typ = Universal_Real
- or else
- It.Typ = Universal_Integer
- then
+ elsif Is_Universal_Numeric_Type (It.Typ) then
-- Choose universal interpretation over any other
T := It.Typ;
@@ -3585,7 +3629,7 @@ package body Sem_Ch3 is
if Is_Integer_Type (T) then
Resolve (E, T);
Set_Etype (Id, Universal_Integer);
- Set_Ekind (Id, E_Named_Integer);
+ Mutate_Ekind (Id, E_Named_Integer);
elsif Is_Real_Type (T) then
@@ -3617,14 +3661,14 @@ package body Sem_Ch3 is
Resolve (E, T);
Set_Etype (Id, Universal_Real);
- Set_Ekind (Id, E_Named_Real);
+ Mutate_Ekind (Id, E_Named_Real);
else
Wrong_Type (E, Any_Numeric);
Resolve (E, T);
Set_Etype (Id, T);
- Set_Ekind (Id, E_Constant);
+ Mutate_Ekind (Id, E_Constant);
Set_Never_Set_In_Source (Id, True);
Set_Is_True_Constant (Id, True);
return;
@@ -4025,7 +4069,7 @@ package body Sem_Ch3 is
T := Find_Type_Of_Object (Object_Definition (N), N);
Set_Etype (Id, T);
- Set_Ekind (Id, E_Variable);
+ Mutate_Ekind (Id, E_Variable);
goto Leave;
end if;
@@ -4051,7 +4095,7 @@ package body Sem_Ch3 is
if Error_Posted (Id) then
Set_Etype (Id, T);
- Set_Ekind (Id, E_Variable);
+ Mutate_Ekind (Id, E_Variable);
goto Leave;
end if;
end if;
@@ -4164,27 +4208,10 @@ package body Sem_Ch3 is
Set_Related_Array_Object (Base_Type (T), Id);
end if;
- -- Special checks for protected objects not at library level
+ -- Check for protected objects not at library level
if Has_Protected (T) and then not Is_Library_Level_Entity (Id) then
Check_Restriction (No_Local_Protected_Objects, Id);
-
- -- Protected objects with interrupt handlers must be at library level
-
- -- Ada 2005: This test is not needed (and the corresponding clause
- -- in the RM is removed) because accessibility checks are sufficient
- -- to make handlers not at the library level illegal.
-
- -- AI05-0303: The AI is in fact a binding interpretation, and thus
- -- applies to the '95 version of the language as well.
-
- if Is_Protected_Type (T)
- and then Has_Interrupt_Handler (T)
- and then Ada_Version < Ada_95
- then
- Error_Msg_N
- ("interrupt object can only be declared at library level", Id);
- end if;
end if;
-- Check for violation of No_Local_Timing_Events
@@ -4370,7 +4397,7 @@ package body Sem_Ch3 is
and then In_Subrange_Of (Etype (Entity (E)), T)
then
Set_Is_Known_Valid (Id);
- Set_Ekind (Id, E_Constant);
+ Mutate_Ekind (Id, E_Constant);
Set_Actual_Subtype (Id, Etype (Entity (E)));
end if;
@@ -4515,7 +4542,7 @@ package body Sem_Ch3 is
elsif Is_Class_Wide_Type (T) then
Error_Msg_N
- ("initialization required in class-wide declaration ", N);
+ ("initialization required in class-wide declaration", N);
else
Error_Msg_N
@@ -4586,9 +4613,9 @@ package body Sem_Ch3 is
elsif Is_Unchecked_Union (T) then
if Constant_Present (N) or else Nkind (E) = N_Function_Call then
- Set_Ekind (Id, E_Constant);
+ Mutate_Ekind (Id, E_Constant);
else
- Set_Ekind (Id, E_Variable);
+ Mutate_Ekind (Id, E_Variable);
end if;
-- If the expression is an aggregate it contains the required
@@ -4625,6 +4652,13 @@ package body Sem_Ch3 is
Related_Id := Empty;
end if;
+ -- If the object has an unconstrained array subtype with fixed
+ -- lower bound, then sliding to that bound may be needed.
+
+ if Is_Fixed_Lower_Bound_Array_Subtype (T) then
+ Expand_Sliding_Conversion (E, T);
+ end if;
+
Expand_Subtype_From_Expr
(N => N,
Unc_Type => T,
@@ -4764,12 +4798,16 @@ package body Sem_Ch3 is
-- Now establish the proper kind and type of the object
+ if Ekind (Id) = E_Void then
+ Reinit_Field_To_Zero (Id, F_Next_Inlined_Subprogram);
+ end if;
+
if Constant_Present (N) then
- Set_Ekind (Id, E_Constant);
+ Mutate_Ekind (Id, E_Constant);
Set_Is_True_Constant (Id);
else
- Set_Ekind (Id, E_Variable);
+ Mutate_Ekind (Id, E_Variable);
-- A variable is set as shared passive if it appears in a shared
-- passive package, and is at the outer level. This is not done for
@@ -5097,13 +5135,13 @@ package body Sem_Ch3 is
Parent_Base := Base_Type (Parent_Type);
if Parent_Type = Any_Type or else Etype (Parent_Type) = Any_Type then
- Set_Ekind (T, Ekind (Parent_Type));
+ Mutate_Ekind (T, Ekind (Parent_Type));
Set_Etype (T, Any_Type);
goto Leave;
elsif not Is_Tagged_Type (Parent_Type) then
Error_Msg_N
- ("parent of type extension must be a tagged type ", Indic);
+ ("parent of type extension must be a tagged type", Indic);
goto Leave;
elsif Ekind (Parent_Type) in E_Void | E_Incomplete_Type then
@@ -5116,12 +5154,14 @@ package body Sem_Ch3 is
& "tagged type (RM 3.9.1 (3/1))", N);
Set_Etype (T, Any_Type);
- Set_Ekind (T, E_Limited_Private_Type);
+ Mutate_Ekind (T, E_Limited_Private_Type);
Set_Private_Dependents (T, New_Elmt_List);
Set_Error_Posted (T);
goto Leave;
end if;
+ Check_Wide_Character_Restriction (Parent_Type, Indic);
+
-- Perhaps the parent type should be changed to the class-wide type's
-- specific type in this case to prevent cascading errors ???
@@ -5142,7 +5182,7 @@ package body Sem_Ch3 is
Set_Is_Pure (T, Is_Pure (Current_Scope));
Set_Scope (T, Current_Scope);
- Set_Ekind (T, E_Record_Type_With_Private);
+ Mutate_Ekind (T, E_Record_Type_With_Private);
Init_Size_Align (T);
Set_Default_SSO (T);
Set_No_Reordering (T, No_Component_Reordering);
@@ -5387,7 +5427,7 @@ package body Sem_Ch3 is
-- (no aspects to examine on the generated declaration).
if not Comes_From_Source (N) then
- Set_Ekind (Id, Ekind (T));
+ Mutate_Ekind (Id, Ekind (T));
if Present (Predicate_Function (Id)) then
null;
@@ -5413,11 +5453,11 @@ package body Sem_Ch3 is
case Ekind (T) is
when Array_Kind =>
- Set_Ekind (Id, E_Array_Subtype);
+ Mutate_Ekind (Id, E_Array_Subtype);
Copy_Array_Subtype_Attributes (Id, T);
when Decimal_Fixed_Point_Kind =>
- Set_Ekind (Id, E_Decimal_Fixed_Point_Subtype);
+ Mutate_Ekind (Id, E_Decimal_Fixed_Point_Subtype);
Set_Digits_Value (Id, Digits_Value (T));
Set_Delta_Value (Id, Delta_Value (T));
Set_Scale_Value (Id, Scale_Value (T));
@@ -5429,7 +5469,7 @@ package body Sem_Ch3 is
Set_RM_Size (Id, RM_Size (T));
when Enumeration_Kind =>
- Set_Ekind (Id, E_Enumeration_Subtype);
+ Mutate_Ekind (Id, E_Enumeration_Subtype);
Set_First_Literal (Id, First_Literal (Base_Type (T)));
Set_Scalar_Range (Id, Scalar_Range (T));
Set_Is_Character_Type (Id, Is_Character_Type (T));
@@ -5438,7 +5478,7 @@ package body Sem_Ch3 is
Set_RM_Size (Id, RM_Size (T));
when Ordinary_Fixed_Point_Kind =>
- Set_Ekind (Id, E_Ordinary_Fixed_Point_Subtype);
+ Mutate_Ekind (Id, E_Ordinary_Fixed_Point_Subtype);
Set_Scalar_Range (Id, Scalar_Range (T));
Set_Small_Value (Id, Small_Value (T));
Set_Delta_Value (Id, Delta_Value (T));
@@ -5447,7 +5487,7 @@ package body Sem_Ch3 is
Set_RM_Size (Id, RM_Size (T));
when Float_Kind =>
- Set_Ekind (Id, E_Floating_Point_Subtype);
+ Mutate_Ekind (Id, E_Floating_Point_Subtype);
Set_Scalar_Range (Id, Scalar_Range (T));
Set_Digits_Value (Id, Digits_Value (T));
Set_Is_Constrained (Id, Is_Constrained (T));
@@ -5456,21 +5496,21 @@ package body Sem_Ch3 is
-- inherited subsequently when Analyze_Dimensions is called.
when Signed_Integer_Kind =>
- Set_Ekind (Id, E_Signed_Integer_Subtype);
+ Mutate_Ekind (Id, E_Signed_Integer_Subtype);
Set_Scalar_Range (Id, Scalar_Range (T));
Set_Is_Constrained (Id, Is_Constrained (T));
Set_Is_Known_Valid (Id, Is_Known_Valid (T));
Set_RM_Size (Id, RM_Size (T));
when Modular_Integer_Kind =>
- Set_Ekind (Id, E_Modular_Integer_Subtype);
+ Mutate_Ekind (Id, E_Modular_Integer_Subtype);
Set_Scalar_Range (Id, Scalar_Range (T));
Set_Is_Constrained (Id, Is_Constrained (T));
Set_Is_Known_Valid (Id, Is_Known_Valid (T));
Set_RM_Size (Id, RM_Size (T));
when Class_Wide_Kind =>
- Set_Ekind (Id, E_Class_Wide_Subtype);
+ Mutate_Ekind (Id, E_Class_Wide_Subtype);
Set_Class_Wide_Type (Id, Class_Wide_Type (T));
Set_Cloned_Subtype (Id, T);
Set_Is_Tagged_Type (Id, True);
@@ -5487,7 +5527,7 @@ package body Sem_Ch3 is
when E_Record_Subtype
| E_Record_Type
=>
- Set_Ekind (Id, E_Record_Subtype);
+ Mutate_Ekind (Id, E_Record_Subtype);
-- Subtype declarations introduced for formal type parameters
-- in generic instantiations should inherit the Size value of
@@ -5540,7 +5580,7 @@ package body Sem_Ch3 is
end if;
when Private_Kind =>
- Set_Ekind (Id, Subtype_Kind (Ekind (T)));
+ Mutate_Ekind (Id, Subtype_Kind (Ekind (T)));
Set_Has_Discriminants (Id, Has_Discriminants (T));
Set_Is_Constrained (Id, Is_Constrained (T));
Set_First_Entity (Id, First_Entity (T));
@@ -5605,7 +5645,7 @@ package body Sem_Ch3 is
end if;
when Access_Kind =>
- Set_Ekind (Id, E_Access_Subtype);
+ Mutate_Ekind (Id, E_Access_Subtype);
Set_Is_Constrained (Id, Is_Constrained (T));
Set_Is_Access_Constant
(Id, Is_Access_Constant (T));
@@ -5628,7 +5668,7 @@ package body Sem_Ch3 is
end if;
when Concurrent_Kind =>
- Set_Ekind (Id, Subtype_Kind (Ekind (T)));
+ Mutate_Ekind (Id, Subtype_Kind (Ekind (T)));
Set_Corresponding_Record_Type (Id,
Corresponding_Record_Type (T));
Set_First_Entity (Id, First_Entity (T));
@@ -5656,7 +5696,7 @@ package body Sem_Ch3 is
-- propagate indication. Note that we also have to include
-- subtypes for Ada 2012 extended use of incomplete types.
- Set_Ekind (Id, E_Incomplete_Subtype);
+ Mutate_Ekind (Id, E_Incomplete_Subtype);
Set_Is_Tagged_Type (Id, Is_Tagged_Type (T));
Set_Private_Dependents (Id, New_Elmt_List);
@@ -5700,6 +5740,14 @@ package body Sem_Ch3 is
Inherit_Predicate_Flags (Id, T);
end if;
+ -- When prefixed calls are enabled for untagged types, the subtype
+ -- shares the primitive operations of its base type.
+
+ if Extensions_Allowed then
+ Set_Direct_Primitive_Operations
+ (Id, Direct_Primitive_Operations (Base_Type (T)));
+ end if;
+
if Etype (Id) = Any_Type then
goto Leave;
end if;
@@ -5731,7 +5779,16 @@ package body Sem_Ch3 is
((In_Instance and then not Comes_From_Source (N))
or else No (Aspect_Specifications (N)))
then
- Set_Subprograms_For_Type (Id, Subprograms_For_Type (T));
+ -- Inherit Subprograms_For_Type from the full view, if present
+
+ if Present (Full_View (T))
+ and then Subprograms_For_Type (Full_View (T)) /= No_Elist
+ then
+ Set_Subprograms_For_Type
+ (Id, Subprograms_For_Type (Full_View (T)));
+ else
+ Set_Subprograms_For_Type (Id, Subprograms_For_Type (T));
+ end if;
-- If the current declaration created both a private and a full view,
-- then propagate Predicate_Function to the latter as well.
@@ -6023,6 +6080,7 @@ package body Sem_Ch3 is
Nb_Index : Pos;
Priv : Entity_Id;
Related_Id : Entity_Id;
+ Has_FLB_Index : Boolean := False;
begin
if Nkind (Def) = N_Constrained_Array_Definition then
@@ -6112,6 +6170,39 @@ package body Sem_Ch3 is
Make_Index (Index, P, Related_Id, Nb_Index);
+ -- In the case where we have an unconstrained array with an index
+ -- given by a subtype_indication, this is necessarily a "fixed lower
+ -- bound" index. We change the upper bound of that index to the upper
+ -- bound of the index's subtype (denoted by the subtype_mark), since
+ -- that upper bound was originally set by the parser to be the same
+ -- as the lower bound. In truth, that upper bound corresponds to
+ -- a box ("<>"), and could be set to Empty, but it's convenient to
+ -- set it to the upper bound to avoid needing to add special tests
+ -- in various places for an Empty upper bound, and in any case that
+ -- accurately characterizes the index's range of values.
+
+ if Nkind (Def) = N_Unconstrained_Array_Definition
+ and then Nkind (Index) = N_Subtype_Indication
+ then
+ declare
+ Index_Subtype_High_Bound : constant Entity_Id :=
+ Type_High_Bound (Entity (Subtype_Mark (Index)));
+ begin
+ Set_High_Bound (Range_Expression (Constraint (Index)),
+ Index_Subtype_High_Bound);
+
+ -- Record that the array type has one or more indexes with
+ -- a fixed lower bound.
+
+ Has_FLB_Index := True;
+
+ -- Mark the index as belonging to an array type with a fixed
+ -- lower bound.
+
+ Set_Is_Fixed_Lower_Bound_Index_Subtype (Etype (Index));
+ end;
+ end if;
+
-- Check error of subtype with predicate for index type
Bad_Predicated_Subtype_Use
@@ -6146,7 +6237,7 @@ package body Sem_Ch3 is
-- the master_id associated with an anonymous access to task type
-- component (see Expand_N_Full_Type_Declaration.Build_Master)
- Set_Parent (Element_Type, Parent (T));
+ Copy_Parent (To => Element_Type, From => T);
-- Ada 2005 (AI-230): In case of components that are anonymous access
-- types the level of accessibility depends on the enclosing type
@@ -6181,6 +6272,12 @@ package body Sem_Ch3 is
if Nkind (Def) = N_Constrained_Array_Definition then
+ if Ekind (T) in Incomplete_Or_Private_Kind then
+ Reinit_Field_To_Zero (T, F_Stored_Constraint);
+ else
+ pragma Assert (Ekind (T) = E_Void);
+ end if;
+
-- Establish Implicit_Base as unconstrained base type
Implicit_Base := Create_Itype (E_Array_Type, P, Related_Id, 'B');
@@ -6192,7 +6289,7 @@ package body Sem_Ch3 is
-- The constrained array type is a subtype of the unconstrained one
- Set_Ekind (T, E_Array_Subtype);
+ Mutate_Ekind (T, E_Array_Subtype);
Init_Size_Align (T);
Set_Etype (T, Implicit_Base);
Set_Scope (T, Current_Scope);
@@ -6222,12 +6319,20 @@ package body Sem_Ch3 is
else pragma Assert (Nkind (Def) = N_Unconstrained_Array_Definition);
- Set_Ekind (T, E_Array_Type);
+ if Ekind (T) in Incomplete_Or_Private_Kind then
+ Reinit_Field_To_Zero (T, F_Stored_Constraint);
+ else
+ pragma Assert (Ekind (T) = E_Void);
+ end if;
+
+ Mutate_Ekind (T, E_Array_Type);
Init_Size_Align (T);
Set_Etype (T, T);
Set_Scope (T, Current_Scope);
Set_Component_Size (T, Uint_0);
Set_Is_Constrained (T, False);
+ Set_Is_Fixed_Lower_Bound_Array_Subtype
+ (T, Has_FLB_Index);
Set_First_Index (T, First (Subtype_Marks (Def)));
Set_Has_Delayed_Freeze (T, True);
Propagate_Concurrent_Flags (T, Element_Type);
@@ -6495,7 +6600,7 @@ package body Sem_Ch3 is
Scope_Stack.Append (Curr_Scope);
end if;
- Set_Ekind (Anon, E_Anonymous_Access_Protected_Subprogram_Type);
+ Mutate_Ekind (Anon, E_Anonymous_Access_Protected_Subprogram_Type);
Set_Can_Use_Internal_Rep (Anon, not Always_Compatible_Rep_On_Target);
return Anon;
end Replace_Anonymous_Access_To_Protected_Subprogram;
@@ -6668,7 +6773,7 @@ package body Sem_Ch3 is
if Nkind (S) /= N_Subtype_Indication
and then Subt /= Base_Type (Subt)
then
- Set_Ekind (Derived_Type, E_Access_Subtype);
+ Mutate_Ekind (Derived_Type, E_Access_Subtype);
end if;
if Ekind (Derived_Type) = E_Access_Subtype then
@@ -6714,7 +6819,9 @@ package body Sem_Ch3 is
Has_Private_Component (Derived_Type));
Conditional_Delay (Derived_Type, Subt);
- if Is_Access_Subprogram_Type (Derived_Type) then
+ if Is_Access_Subprogram_Type (Derived_Type)
+ and then Is_Base_Type (Derived_Type)
+ then
Set_Can_Use_Internal_Rep
(Derived_Type, Can_Use_Internal_Rep (Parent_Type));
end if;
@@ -6783,7 +6890,7 @@ package body Sem_Ch3 is
Implicit_Base :=
Create_Itype (Ekind (Parent_Base), N, Derived_Type, 'B');
- Set_Ekind (Implicit_Base, Ekind (Parent_Base));
+ Mutate_Ekind (Implicit_Base, Ekind (Parent_Base));
Set_Etype (Implicit_Base, Parent_Base);
Copy_Array_Subtype_Attributes (Implicit_Base, Parent_Base);
@@ -6797,7 +6904,7 @@ package body Sem_Ch3 is
begin
if not Is_Constrained (Parent_Type) then
if Nkind (Indic) /= N_Subtype_Indication then
- Set_Ekind (Derived_Type, E_Array_Type);
+ Mutate_Ekind (Derived_Type, E_Array_Type);
Copy_Array_Subtype_Attributes (Derived_Type, Parent_Type);
Copy_Array_Base_Type_Attributes (Derived_Type, Parent_Type);
@@ -6824,7 +6931,7 @@ package body Sem_Ch3 is
if Nkind (Indic) /= N_Subtype_Indication then
Make_Implicit_Base;
- Set_Ekind (Derived_Type, Ekind (Parent_Type));
+ Mutate_Ekind (Derived_Type, Ekind (Parent_Type));
Set_Etype (Derived_Type, Implicit_Base);
Copy_Array_Subtype_Attributes (Derived_Type, Parent_Type);
@@ -7284,7 +7391,7 @@ package body Sem_Ch3 is
New_Lit := Make_Defining_Identifier (Loc, Chars (Literal));
end if;
- Set_Ekind (New_Lit, E_Enumeration_Literal);
+ Mutate_Ekind (New_Lit, E_Enumeration_Literal);
Set_Enumeration_Pos (New_Lit, Enumeration_Pos (Literal));
Set_Enumeration_Rep (New_Lit, Enumeration_Rep (Literal));
Set_Enumeration_Rep_Expr (New_Lit, Empty);
@@ -7304,7 +7411,7 @@ package body Sem_Ch3 is
-- may be hidden by a previous explicit function definition (cf.
-- c83031a).
- Set_Ekind (Derived_Type, E_Enumeration_Subtype);
+ Mutate_Ekind (Derived_Type, E_Enumeration_Subtype);
Set_Etype (Derived_Type, Implicit_Base);
Type_Decl :=
@@ -7476,7 +7583,7 @@ package body Sem_Ch3 is
Create_Itype (Ekind (Parent_Base), N, Derived_Type, 'B');
Set_Etype (Implicit_Base, Parent_Base);
- Set_Ekind (Implicit_Base, Ekind (Parent_Base));
+ Mutate_Ekind (Implicit_Base, Ekind (Parent_Base));
Set_Size_Info (Implicit_Base, Parent_Base);
Set_First_Rep_Item (Implicit_Base, First_Rep_Item (Parent_Base));
Set_Parent (Implicit_Base, Parent (Derived_Type));
@@ -7516,7 +7623,7 @@ package body Sem_Ch3 is
-- parent type (otherwise Process_Subtype has set the bounds)
if No_Constraint then
- Set_Ekind (Derived_Type, Subtype_Kind (Ekind (Parent_Type)));
+ Mutate_Ekind (Derived_Type, Subtype_Kind (Ekind (Parent_Type)));
end if;
-- If we did not have a range constraint, then set the range from the
@@ -7945,7 +8052,7 @@ package body Sem_Ch3 is
-- prevent spurious errors associated with missing overriding
-- of abstract primitives (overridden only for Derived_Type).
- Set_Ekind (Full_Der, E_Record_Type);
+ Mutate_Ekind (Full_Der, E_Record_Type);
Set_Is_Underlying_Record_View (Full_Der);
Set_Default_SSO (Full_Der);
Set_No_Reordering (Full_Der, No_Component_Reordering);
@@ -8845,7 +8952,7 @@ package body Sem_Ch3 is
if Private_Extension then
Type_Def := N;
- Set_Ekind (Derived_Type, E_Record_Type_With_Private);
+ Mutate_Ekind (Derived_Type, E_Record_Type_With_Private);
Set_Default_SSO (Derived_Type);
Set_No_Reordering (Derived_Type, No_Component_Reordering);
@@ -8860,7 +8967,7 @@ package body Sem_Ch3 is
-- For untagged types we preserve the Ekind of the Parent_Base.
if Present (Record_Extension_Part (Type_Def)) then
- Set_Ekind (Derived_Type, E_Record_Type);
+ Mutate_Ekind (Derived_Type, E_Record_Type);
Set_Default_SSO (Derived_Type);
Set_No_Reordering (Derived_Type, No_Component_Reordering);
@@ -8874,7 +8981,7 @@ package body Sem_Ch3 is
end if;
else
- Set_Ekind (Derived_Type, Ekind (Parent_Base));
+ Mutate_Ekind (Derived_Type, Ekind (Parent_Base));
end if;
end if;
@@ -9212,9 +9319,7 @@ package body Sem_Ch3 is
and then Is_Limited_Record (Full_View (Parent_Type)))
then
if not Is_Interface (Parent_Type)
- or else Is_Synchronized_Interface (Parent_Type)
- or else Is_Protected_Interface (Parent_Type)
- or else Is_Task_Interface (Parent_Type)
+ or else Is_Concurrent_Interface (Parent_Type)
then
Set_Is_Limited_Record (Derived_Type);
end if;
@@ -9453,6 +9558,13 @@ package body Sem_Ch3 is
end;
end if;
+ -- When prefixed-call syntax is allowed for untagged types, initialize
+ -- the list of primitive operations to an empty list.
+
+ if Extensions_Allowed and then not Is_Tagged then
+ Set_Direct_Primitive_Operations (Derived_Type, New_Elmt_List);
+ end if;
+
-- Set fields for tagged types
if Is_Tagged then
@@ -9731,9 +9843,15 @@ package body Sem_Ch3 is
begin
-- Set common attributes
+ if Ekind (Derived_Type) in Incomplete_Or_Private_Kind
+ and then Ekind (Parent_Base) in Modular_Integer_Kind | Array_Kind
+ then
+ Reinit_Field_To_Zero (Derived_Type, F_Stored_Constraint);
+ end if;
+
Set_Scope (Derived_Type, Current_Scope);
Set_Etype (Derived_Type, Parent_Base);
- Set_Ekind (Derived_Type, Ekind (Parent_Base));
+ Mutate_Ekind (Derived_Type, Ekind (Parent_Base));
Propagate_Concurrent_Flags (Derived_Type, Parent_Base);
Set_Size_Info (Derived_Type, Parent_Type);
@@ -9925,6 +10043,28 @@ package body Sem_Ch3 is
return;
end if;
+ -- If not already set, initialize the derived type's list of primitive
+ -- operations to an empty element list.
+
+ if not Present (Direct_Primitive_Operations (Derived_Type)) then
+ Set_Direct_Primitive_Operations (Derived_Type, New_Elmt_List);
+
+ -- If Etype of the derived type is the base type (as opposed to
+ -- a parent type) and doesn't have an associated list of primitive
+ -- operations, then set the base type's primitive list to the
+ -- derived type's list. The lists need to be shared in common
+ -- between the two.
+
+ if Etype (Derived_Type) = Base_Type (Derived_Type)
+ and then
+ not Present (Direct_Primitive_Operations (Etype (Derived_Type)))
+ then
+ Set_Direct_Primitive_Operations
+ (Etype (Derived_Type),
+ Direct_Primitive_Operations (Derived_Type));
+ end if;
+ end if;
+
-- Set delayed freeze and then derive subprograms, we need to do this
-- in this order so that derived subprograms inherit the derived freeze
-- if necessary.
@@ -9952,7 +10092,7 @@ package body Sem_Ch3 is
D_Minal := Make_Defining_Identifier (Sloc (Discrim), Chars (Discrim));
- Set_Ekind (D_Minal, E_In_Parameter);
+ Mutate_Ekind (D_Minal, E_In_Parameter);
Set_Mechanism (D_Minal, Default_Mechanism);
Set_Etype (D_Minal, Etype (Discrim));
Set_Scope (D_Minal, Current_Scope);
@@ -9971,7 +10111,7 @@ package body Sem_Ch3 is
then
CR_Disc := Make_Defining_Identifier (Sloc (Discrim), Chars (Discrim));
- Set_Ekind (CR_Disc, E_In_Parameter);
+ Mutate_Ekind (CR_Disc, E_In_Parameter);
Set_Mechanism (CR_Disc, Default_Mechanism);
Set_Etype (CR_Disc, Etype (Discrim));
Set_Scope (CR_Disc, Current_Scope);
@@ -10296,7 +10436,7 @@ package body Sem_Ch3 is
if Discrim_Present then
null;
- elsif Nkind (Parent (Parent (Def))) = N_Component_Declaration
+ elsif Parent_Kind (Parent (Def)) = N_Component_Declaration
and then Has_Per_Object_Constraint
(Defining_Identifier (Parent (Parent (Def))))
then
@@ -10362,7 +10502,7 @@ package body Sem_Ch3 is
begin
if Ekind (T) = E_Record_Type then
- Set_Ekind (Def_Id, E_Record_Subtype);
+ Mutate_Ekind (Def_Id, E_Record_Subtype);
-- Inherit preelaboration flag from base, for types for which it
-- may have been set: records, private types, protected types.
@@ -10371,15 +10511,15 @@ package body Sem_Ch3 is
(Def_Id, Known_To_Have_Preelab_Init (T));
elsif Ekind (T) = E_Task_Type then
- Set_Ekind (Def_Id, E_Task_Subtype);
+ Mutate_Ekind (Def_Id, E_Task_Subtype);
elsif Ekind (T) = E_Protected_Type then
- Set_Ekind (Def_Id, E_Protected_Subtype);
+ Mutate_Ekind (Def_Id, E_Protected_Subtype);
Set_Known_To_Have_Preelab_Init
(Def_Id, Known_To_Have_Preelab_Init (T));
elsif Is_Private_Type (T) then
- Set_Ekind (Def_Id, Subtype_Kind (Ekind (T)));
+ Mutate_Ekind (Def_Id, Subtype_Kind (Ekind (T)));
Set_Known_To_Have_Preelab_Init
(Def_Id, Known_To_Have_Preelab_Init (T));
@@ -10388,7 +10528,7 @@ package body Sem_Ch3 is
Set_Private_Dependents (Def_Id, New_Elmt_List);
elsif Is_Class_Wide_Type (T) then
- Set_Ekind (Def_Id, E_Class_Wide_Subtype);
+ Mutate_Ekind (Def_Id, E_Class_Wide_Subtype);
else
-- Incomplete type. Attach subtype to list of dependents, to be
@@ -10401,9 +10541,9 @@ package body Sem_Ch3 is
-- initialization procedure.
if Ekind (T) = E_Incomplete_Type then
- Set_Ekind (Def_Id, E_Incomplete_Subtype);
+ Mutate_Ekind (Def_Id, E_Incomplete_Subtype);
else
- Set_Ekind (Def_Id, Ekind (T));
+ Mutate_Ekind (Def_Id, Ekind (T));
end if;
if For_Access and then Within_Init_Proc then
@@ -10902,6 +11042,15 @@ package body Sem_Ch3 is
then
null;
+ -- Skip reporting the error on Ada 2022 only subprograms
+ -- that require overriding if we are not in Ada 2022 mode.
+
+ elsif Ada_Version < Ada_2022
+ and then Requires_Overriding (Subp)
+ and then Is_Ada_2022_Only (Ultimate_Alias (Subp))
+ then
+ null;
+
else
Error_Msg_NE
("type must be declared abstract or & overridden",
@@ -11070,18 +11219,35 @@ package body Sem_Ch3 is
end if;
end if;
- -- Ada 2005 (AI95-0414) and Ada 2020 (AI12-0269): Diagnose failure to
+ -- Ada 2005 (AI95-0414) and Ada 2022 (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);
+
+ -- If the subprogram is a renaming, check that the renamed
+ -- subprogram is No_Return.
+
+ if Present (Renamed_Or_Alias (Subp)) then
+ if not No_Return (Renamed_Or_Alias (Subp)) then
+ Error_Msg_NE ("subprogram & must be No_Return",
+ Subp,
+ Renamed_Or_Alias (Subp));
+ Error_Msg_N ("\since renaming & overrides No_Return "
+ & "subprogram (RM 6.5.1(6/2))",
+ Subp);
+ end if;
+
+ -- Make sure that the subprogram itself is No_Return.
+
+ elsif 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;
end if;
-- If the operation is a wrapper for a synchronized primitive, it
@@ -11180,21 +11346,20 @@ package body Sem_Ch3 is
end if;
end Check_Aliased_Component_Types;
- ---------------------------------------
- -- Check_Anonymous_Access_Components --
- ---------------------------------------
+ --------------------------------------
+ -- Check_Anonymous_Access_Component --
+ --------------------------------------
- procedure Check_Anonymous_Access_Components
- (Typ_Decl : Node_Id;
- Typ : Entity_Id;
- Prev : Entity_Id;
- Comp_List : Node_Id)
+ procedure Check_Anonymous_Access_Component
+ (Typ_Decl : Node_Id;
+ Typ : Entity_Id;
+ Prev : Entity_Id;
+ Comp_Def : Node_Id;
+ Access_Def : Node_Id)
is
- Loc : constant Source_Ptr := Sloc (Typ_Decl);
+ Loc : constant Source_Ptr := Sloc (Comp_Def);
Anon_Access : Entity_Id;
Acc_Def : Node_Id;
- Comp : Node_Id;
- Comp_Def : Node_Id;
Decl : Node_Id;
Type_Def : Node_Id;
@@ -11228,13 +11393,18 @@ package body Sem_Ch3 is
-- Is_Tagged indicates whether the type is tagged. It is tagged if
-- it's "is new ... with record" or else "is tagged record ...".
+ Typ_Def : constant Node_Id :=
+ (if Nkind (Typ_Decl) = N_Full_Type_Declaration
+ then Type_Definition (Typ_Decl) else Empty);
Is_Tagged : constant Boolean :=
- (Nkind (Type_Definition (Typ_Decl)) = N_Derived_Type_Definition
- and then
- Present (Record_Extension_Part (Type_Definition (Typ_Decl))))
- or else
- (Nkind (Type_Definition (Typ_Decl)) = N_Record_Definition
- and then Tagged_Present (Type_Definition (Typ_Decl)));
+ Present (Typ_Def)
+ and then
+ ((Nkind (Typ_Def) = N_Derived_Type_Definition
+ and then
+ Present (Record_Extension_Part (Typ_Def)))
+ or else
+ (Nkind (Typ_Def) = N_Record_Definition
+ and then Tagged_Present (Typ_Def)));
begin
-- If there is a previous partial view, no need to create a new one
@@ -11452,88 +11622,104 @@ package body Sem_Ch3 is
return False;
end Mentions_T;
- -- Start of processing for Check_Anonymous_Access_Components
+ -- Start of processing for Check_Anonymous_Access_Component
begin
- if No (Comp_List) then
- return;
- end if;
+ if Present (Access_Def) and then Mentions_T (Access_Def) then
+ Acc_Def := Access_To_Subprogram_Definition (Access_Def);
- Comp := First (Component_Items (Comp_List));
- while Present (Comp) loop
- if Nkind (Comp) = N_Component_Declaration
- and then Present
- (Access_Definition (Component_Definition (Comp)))
- and then
- Mentions_T (Access_Definition (Component_Definition (Comp)))
- then
- Comp_Def := Component_Definition (Comp);
- Acc_Def :=
- Access_To_Subprogram_Definition (Access_Definition (Comp_Def));
-
- Build_Incomplete_Type_Declaration;
- Anon_Access := Make_Temporary (Loc, 'S');
-
- -- Create a declaration for the anonymous access type: either
- -- an access_to_object or an access_to_subprogram.
-
- if Present (Acc_Def) then
- if Nkind (Acc_Def) = N_Access_Function_Definition then
- Type_Def :=
- Make_Access_Function_Definition (Loc,
- Parameter_Specifications =>
- Parameter_Specifications (Acc_Def),
- Result_Definition => Result_Definition (Acc_Def));
- else
- Type_Def :=
- Make_Access_Procedure_Definition (Loc,
- Parameter_Specifications =>
- Parameter_Specifications (Acc_Def));
- end if;
+ Build_Incomplete_Type_Declaration;
+ Anon_Access := Make_Temporary (Loc, 'S');
+
+ -- Create a declaration for the anonymous access type: either
+ -- an access_to_object or an access_to_subprogram.
+ if Present (Acc_Def) then
+ if Nkind (Acc_Def) = N_Access_Function_Definition then
+ Type_Def :=
+ Make_Access_Function_Definition (Loc,
+ Parameter_Specifications =>
+ Parameter_Specifications (Acc_Def),
+ Result_Definition => Result_Definition (Acc_Def));
else
Type_Def :=
- Make_Access_To_Object_Definition (Loc,
- Subtype_Indication =>
- Relocate_Node
- (Subtype_Mark (Access_Definition (Comp_Def))));
-
- Set_Constant_Present
- (Type_Def, Constant_Present (Access_Definition (Comp_Def)));
- Set_All_Present
- (Type_Def, All_Present (Access_Definition (Comp_Def)));
+ Make_Access_Procedure_Definition (Loc,
+ Parameter_Specifications =>
+ Parameter_Specifications (Acc_Def));
end if;
- Set_Null_Exclusion_Present
- (Type_Def,
- Null_Exclusion_Present (Access_Definition (Comp_Def)));
+ else
+ Type_Def :=
+ Make_Access_To_Object_Definition (Loc,
+ Subtype_Indication =>
+ Relocate_Node (Subtype_Mark (Access_Def)));
- Decl :=
- Make_Full_Type_Declaration (Loc,
- Defining_Identifier => Anon_Access,
- Type_Definition => Type_Def);
+ Set_Constant_Present (Type_Def, Constant_Present (Access_Def));
+ Set_All_Present (Type_Def, All_Present (Access_Def));
+ end if;
- Insert_Before (Typ_Decl, Decl);
- Analyze (Decl);
+ Set_Null_Exclusion_Present
+ (Type_Def, Null_Exclusion_Present (Access_Def));
- -- If an access to subprogram, create the extra formals
+ Decl :=
+ Make_Full_Type_Declaration (Loc,
+ Defining_Identifier => Anon_Access,
+ Type_Definition => Type_Def);
- if Present (Acc_Def) then
- Create_Extra_Formals (Designated_Type (Anon_Access));
- end if;
+ Insert_Before (Typ_Decl, Decl);
+ Analyze (Decl);
+
+ -- If an access to subprogram, create the extra formals
+
+ if Present (Acc_Def) then
+ Create_Extra_Formals (Designated_Type (Anon_Access));
+ end if;
+ if Nkind (Comp_Def) = N_Component_Definition then
Rewrite (Comp_Def,
Make_Component_Definition (Loc,
- Subtype_Indication =>
- New_Occurrence_Of (Anon_Access, Loc)));
+ Subtype_Indication => New_Occurrence_Of (Anon_Access, Loc)));
+ else
+ pragma Assert (Nkind (Comp_Def) = N_Discriminant_Specification);
+ Rewrite (Comp_Def,
+ Make_Discriminant_Specification (Loc,
+ Defining_Identifier => Defining_Identifier (Comp_Def),
+ Discriminant_Type => New_Occurrence_Of (Anon_Access, Loc)));
+ end if;
- if Ekind (Designated_Type (Anon_Access)) = E_Subprogram_Type then
- Set_Ekind (Anon_Access, E_Anonymous_Access_Subprogram_Type);
- else
- Set_Ekind (Anon_Access, E_Anonymous_Access_Type);
- end if;
+ if Ekind (Designated_Type (Anon_Access)) = E_Subprogram_Type then
+ Mutate_Ekind (Anon_Access, E_Anonymous_Access_Subprogram_Type);
+ else
+ Mutate_Ekind (Anon_Access, E_Anonymous_Access_Type);
+ end if;
+
+ Set_Is_Local_Anonymous_Access (Anon_Access);
+ end if;
+ end Check_Anonymous_Access_Component;
+
+ ---------------------------------------
+ -- Check_Anonymous_Access_Components --
+ ---------------------------------------
- Set_Is_Local_Anonymous_Access (Anon_Access);
+ procedure Check_Anonymous_Access_Components
+ (Typ_Decl : Node_Id;
+ Typ : Entity_Id;
+ Prev : Entity_Id;
+ Comp_List : Node_Id)
+ is
+ Comp : Node_Id;
+ begin
+ if No (Comp_List) then
+ return;
+ end if;
+
+ Comp := First (Component_Items (Comp_List));
+ while Present (Comp) loop
+ if Nkind (Comp) = N_Component_Declaration then
+ Check_Anonymous_Access_Component
+ (Typ_Decl, Typ, Prev,
+ Component_Definition (Comp),
+ Access_Definition (Component_Definition (Comp)));
end if;
Next (Comp);
@@ -12492,9 +12678,13 @@ package body Sem_Ch3 is
Set_Homonym (Full, Save_Homonym);
Set_Associated_Node_For_Itype (Full, Related_Nod);
+ if Ekind (Full) in Incomplete_Or_Private_Kind then
+ Reinit_Field_To_Zero (Full, F_Private_Dependents);
+ end if;
+
-- Set common attributes for all subtypes: kind, convention, etc.
- Set_Ekind (Full, Subtype_Kind (Ekind (Full_Base)));
+ Mutate_Ekind (Full, Subtype_Kind (Ekind (Full_Base)));
Set_Convention (Full, Convention (Full_Base));
Set_Is_First_Subtype (Full, False);
Set_Scope (Full, Scope (Priv));
@@ -13050,7 +13240,7 @@ package body Sem_Ch3 is
Desig_Subtype :=
Create_Itype
(E_Void, Related_Nod, Scope_Id => Scope (Desig_Type));
- Set_Ekind (Desig_Subtype, E_Record_Subtype);
+ Mutate_Ekind (Desig_Subtype, E_Record_Subtype);
Def_Id := Entity (Subtype_Mark (S));
-- We indicate that the component has a per-object constraint
@@ -13147,7 +13337,7 @@ package body Sem_Ch3 is
if No (Def_Id) then
Def_Id := Create_Itype (E_Access_Subtype, Related_Nod);
else
- Set_Ekind (Def_Id, E_Access_Subtype);
+ Mutate_Ekind (Def_Id, E_Access_Subtype);
end if;
if Constraint_OK then
@@ -13225,6 +13415,7 @@ package body Sem_Ch3 is
Index : Node_Id;
S, T : Entity_Id;
Constraint_OK : Boolean := True;
+ Is_FLB_Array_Subtype : Boolean := False;
begin
T := Entity (Subtype_Mark (SI));
@@ -13268,6 +13459,48 @@ package body Sem_Ch3 is
for J in 1 .. Number_Of_Constraints loop
Constrain_Index (Index, S, Related_Nod, Related_Id, Suffix, J);
+
+ -- If the subtype of the index has been set to indicate that
+ -- it has a fixed lower bound, then record that the subtype's
+ -- entity will need to be marked as being a fixed-lower-bound
+ -- array subtype.
+
+ if S = First (Constraints (C)) then
+ Is_FLB_Array_Subtype :=
+ Is_Fixed_Lower_Bound_Index_Subtype (Etype (S));
+
+ -- If the parent subtype (or should this be Etype of that?)
+ -- is an FLB array subtype, we flag an error, because we
+ -- don't currently allow subtypes of such subtypes to
+ -- specify a fixed lower bound for any of their indexes,
+ -- even if the index of the parent subtype is a "range <>"
+ -- index.
+
+ if Is_FLB_Array_Subtype
+ and then Is_Fixed_Lower_Bound_Array_Subtype (T)
+ then
+ Error_Msg_NE
+ ("index with fixed lower bound not allowed for subtype "
+ & "of fixed-lower-bound }", S, T);
+
+ Is_FLB_Array_Subtype := False;
+ end if;
+
+ elsif Is_FLB_Array_Subtype
+ and then not Is_Fixed_Lower_Bound_Index_Subtype (Etype (S))
+ then
+ Error_Msg_NE
+ ("constrained index not allowed for fixed-lower-bound "
+ & "subtype of}", S, T);
+
+ elsif not Is_FLB_Array_Subtype
+ and then Is_Fixed_Lower_Bound_Index_Subtype (Etype (S))
+ then
+ Error_Msg_NE
+ ("index with fixed lower bound not allowed for "
+ & "constrained subtype of}", S, T);
+ end if;
+
Next (Index);
Next (S);
end loop;
@@ -13281,7 +13514,7 @@ package body Sem_Ch3 is
Set_Parent (Def_Id, Related_Nod);
else
- Set_Ekind (Def_Id, E_Array_Subtype);
+ Mutate_Ekind (Def_Id, E_Array_Subtype);
end if;
Set_Size_Info (Def_Id, (T));
@@ -13294,7 +13527,9 @@ package body Sem_Ch3 is
Set_First_Index (Def_Id, First_Index (T));
end if;
- Set_Is_Constrained (Def_Id, True);
+ Set_Is_Constrained (Def_Id, not Is_FLB_Array_Subtype);
+ Set_Is_Fixed_Lower_Bound_Array_Subtype
+ (Def_Id, Is_FLB_Array_Subtype);
Set_Is_Aliased (Def_Id, Is_Aliased (T));
Set_Is_Independent (Def_Id, Is_Independent (T));
Set_Depends_On_Private (Def_Id, Has_Private_Component (Def_Id));
@@ -13844,7 +14079,7 @@ package body Sem_Ch3 is
Bound_Val : Ureal;
begin
- Set_Ekind (Def_Id, E_Decimal_Fixed_Point_Subtype);
+ Mutate_Ekind (Def_Id, E_Decimal_Fixed_Point_Subtype);
if Nkind (C) = N_Range_Constraint then
Range_Expr := Range_Expression (C);
@@ -13928,7 +14163,7 @@ package body Sem_Ch3 is
begin
-- Set a reasonable Ekind for the entity, including incomplete types.
- Set_Ekind (Def_Id, Subtype_Kind (Ekind (T)));
+ Mutate_Ekind (Def_Id, Subtype_Kind (Ekind (T)));
-- Set Etype to the known type, to reduce chances of cascaded errors
@@ -13969,9 +14204,7 @@ package body Sem_Ch3 is
(Has_Unknown_Discriminants (T)
or else
(not Has_Discriminants (T)
- and then Has_Discriminants (Full_View (T))
- and then Present (Discriminant_Default_Value
- (First_Discriminant (Full_View (T))))))
+ and then Has_Defaulted_Discriminants (Full_View (T))))
then
T := Full_View (T);
E := Full_View (E);
@@ -14056,7 +14289,7 @@ package body Sem_Ch3 is
C : constant Node_Id := Constraint (S);
begin
- Set_Ekind (Def_Id, E_Enumeration_Subtype);
+ Mutate_Ekind (Def_Id, E_Enumeration_Subtype);
Set_First_Literal (Def_Id, First_Literal (Base_Type (T)));
@@ -14081,7 +14314,7 @@ package body Sem_Ch3 is
Rais : Node_Id;
begin
- Set_Ekind (Def_Id, E_Floating_Point_Subtype);
+ Mutate_Ekind (Def_Id, E_Floating_Point_Subtype);
Set_Etype (Def_Id, Base_Type (T));
Set_Size_Info (Def_Id, (T));
@@ -14158,6 +14391,7 @@ package body Sem_Ch3 is
Def_Id : Entity_Id;
R : Node_Id := Empty;
T : constant Entity_Id := Etype (Index);
+ Is_FLB_Index : Boolean := False;
begin
Def_Id :=
@@ -14171,8 +14405,20 @@ package body Sem_Ch3 is
then
-- A Range attribute will be transformed into N_Range by Resolve
- Analyze (S);
- Set_Etype (S, T);
+ -- If a range has an Empty upper bound, then remember that for later
+ -- setting of the index subtype's Is_Fixed_Lower_Bound_Index_Subtype
+ -- flag, and also set the upper bound of the range to the index
+ -- subtype's upper bound rather than leaving it Empty. In truth,
+ -- that upper bound corresponds to a box ("<>"), but it's convenient
+ -- to set it to the upper bound to avoid needing to add special tests
+ -- in various places for an Empty upper bound, and in any case it
+ -- accurately characterizes the index's range of values.
+
+ if Nkind (S) = N_Range and then not Present (High_Bound (S)) then
+ Is_FLB_Index := True;
+ Set_High_Bound (S, Type_High_Bound (T));
+ end if;
+
R := S;
Process_Range_Expr_In_Decl (R, T);
@@ -14258,13 +14504,13 @@ package body Sem_Ch3 is
-- Complete construction of the Itype
if Is_Modular_Integer_Type (T) then
- Set_Ekind (Def_Id, E_Modular_Integer_Subtype);
+ Mutate_Ekind (Def_Id, E_Modular_Integer_Subtype);
elsif Is_Integer_Type (T) then
- Set_Ekind (Def_Id, E_Signed_Integer_Subtype);
+ Mutate_Ekind (Def_Id, E_Signed_Integer_Subtype);
else
- Set_Ekind (Def_Id, E_Enumeration_Subtype);
+ Mutate_Ekind (Def_Id, E_Enumeration_Subtype);
Set_Is_Character_Type (Def_Id, Is_Character_Type (T));
Set_First_Literal (Def_Id, First_Literal (T));
end if;
@@ -14273,7 +14519,22 @@ package body Sem_Ch3 is
Set_RM_Size (Def_Id, RM_Size (T));
Set_First_Rep_Item (Def_Id, First_Rep_Item (T));
- Set_Scalar_Range (Def_Id, R);
+ -- If this is a range for a fixed-lower-bound subtype, then set the
+ -- index itype's low bound to the FLB and the index itype's upper bound
+ -- to the high bound of the parent array type's index subtype. Also,
+ -- mark the itype as an FLB index subtype.
+
+ if Nkind (S) = N_Range and then Is_FLB_Index then
+ Set_Scalar_Range
+ (Def_Id,
+ Make_Range (Sloc (S),
+ Low_Bound => Low_Bound (S),
+ High_Bound => Type_High_Bound (T)));
+ Set_Is_Fixed_Lower_Bound_Index_Subtype (Def_Id);
+
+ else
+ Set_Scalar_Range (Def_Id, R);
+ end if;
Set_Etype (S, Def_Id);
Set_Discrete_RM_Size (Def_Id);
@@ -14291,9 +14552,9 @@ package body Sem_Ch3 is
Set_Scalar_Range_For_Subtype (Def_Id, Range_Expression (C), T);
if Is_Modular_Integer_Type (T) then
- Set_Ekind (Def_Id, E_Modular_Integer_Subtype);
+ Mutate_Ekind (Def_Id, E_Modular_Integer_Subtype);
else
- Set_Ekind (Def_Id, E_Signed_Integer_Subtype);
+ Mutate_Ekind (Def_Id, E_Signed_Integer_Subtype);
end if;
Set_Etype (Def_Id, Base_Type (T));
@@ -14313,7 +14574,7 @@ package body Sem_Ch3 is
Rais : Node_Id;
begin
- Set_Ekind (Def_Id, E_Ordinary_Fixed_Point_Subtype);
+ Mutate_Ekind (Def_Id, E_Ordinary_Fixed_Point_Subtype);
Set_Etype (Def_Id, Base_Type (T));
Set_Size_Info (Def_Id, (T));
Set_First_Rep_Item (Def_Id, First_Rep_Item (T));
@@ -14490,7 +14751,7 @@ package body Sem_Ch3 is
-- appropriate choice, since it allowed the attributes to be set
-- in the first place. This Ekind value will be modified later.
- Set_Ekind (Full, Ekind (Priv));
+ Mutate_Ekind (Full, Ekind (Priv));
-- Also set Etype temporarily to Any_Type, again, in the absence
-- of errors, it will be properly reset, and if there are errors,
@@ -15112,7 +15373,7 @@ package body Sem_Ch3 is
-- chain ensures that SPARK-related pragmas are not clobbered when the
-- decimal fixed point type acts as a full view of a private type.
- Set_Ekind (T, E_Decimal_Fixed_Point_Subtype);
+ Mutate_Ekind (T, E_Decimal_Fixed_Point_Subtype);
Set_Etype (T, Implicit_Base);
Set_Size_Info (T, Implicit_Base);
Inherit_Rep_Item_Chain (T, Implicit_Base);
@@ -15504,7 +15765,7 @@ package body Sem_Ch3 is
begin
New_Subp := New_Entity (Nkind (Parent_Subp), Sloc (Derived_Type));
- Set_Ekind (New_Subp, Ekind (Parent_Subp));
+ Mutate_Ekind (New_Subp, Ekind (Parent_Subp));
-- Check whether the inherited subprogram is a private operation that
-- should be inherited but not yet made visible. Such subprograms can
@@ -15766,7 +16027,7 @@ package body Sem_Ch3 is
-- that functions with controlling access results of record extensions
-- with a null extension part require overriding (AI95-00391/06).
- -- Ada 202x (AI12-0042): Similarly, set those properties for
+ -- Ada 2022 (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
@@ -15923,7 +16184,7 @@ package body Sem_Ch3 is
Set_Mechanism (New_Subp, Mechanism (Parent_Subp));
end if;
- -- Ada 2020 (AI12-0279): If a Yield aspect is specified True for a
+ -- Ada 2022 (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.
@@ -15933,6 +16194,8 @@ package body Sem_Ch3 is
then
Set_Has_Yield_Aspect (New_Subp, Has_Yield_Aspect (Alias (New_Subp)));
end if;
+
+ Set_Is_Ada_2022_Only (New_Subp, Is_Ada_2022_Only (Parent_Subp));
end Derive_Subprogram;
------------------------
@@ -16566,11 +16829,11 @@ package body Sem_Ch3 is
Conditional_Delay (Derived_Type, Parent_Type);
- Set_Ekind (Derived_Type, E_Enumeration_Subtype);
+ Mutate_Ekind (Derived_Type, E_Enumeration_Subtype);
Set_Etype (Derived_Type, Implicit_Base);
Set_Size_Info (Derived_Type, Parent_Type);
- if Unknown_RM_Size (Derived_Type) then
+ if not Known_RM_Size (Derived_Type) then
Set_RM_Size (Derived_Type, RM_Size (Parent_Type));
end if;
@@ -16815,7 +17078,7 @@ package body Sem_Ch3 is
Error_Msg_N ("type cannot be used in its own definition", Indic);
end if;
- Set_Ekind (T, Ekind (Parent_Type));
+ Mutate_Ekind (T, Ekind (Parent_Type));
Set_Etype (T, Any_Type);
Set_Scalar_Range (T, Scalar_Range (Any_Type));
@@ -17081,6 +17344,8 @@ package body Sem_Ch3 is
Error_Msg_N ("null exclusion can only apply to an access type", N);
end if;
+ Check_Wide_Character_Restriction (Parent_Type, Indic);
+
-- Avoid deriving parent primitives of underlying record views
Build_Derived_Type (N, Parent_Type, T, Is_Completion,
@@ -17156,7 +17421,7 @@ package body Sem_Ch3 is
R_Node := New_Node (N_Range, Sloc (Def));
Set_Low_Bound (R_Node, B_Node);
- Set_Ekind (T, E_Enumeration_Type);
+ Mutate_Ekind (T, E_Enumeration_Type);
Set_First_Literal (T, L);
Set_Etype (T, T);
Set_Is_Constrained (T);
@@ -17170,7 +17435,7 @@ package body Sem_Ch3 is
while Present (L) loop
if Ekind (L) /= E_Enumeration_Literal then
- Set_Ekind (L, E_Enumeration_Literal);
+ Mutate_Ekind (L, E_Enumeration_Literal);
Set_Enumeration_Pos (L, Ev);
Set_Enumeration_Rep (L, Ev);
Set_Is_Known_Valid (L, True);
@@ -17443,10 +17708,10 @@ package body Sem_Ch3 is
and then Nkind (N) = N_Private_Type_Declaration
then
Error_Msg_NE
- ("declaration of private } must be a tagged type ", Id, Prev);
+ ("declaration of private } must be a tagged type", Id, Prev);
else
Error_Msg_NE
- ("full declaration of } must be a tagged type ", Id, Prev);
+ ("full declaration of } must be a tagged type", Id, Prev);
end if;
else
@@ -17454,10 +17719,10 @@ package body Sem_Ch3 is
and then Nkind (N) = N_Private_Type_Declaration
then
Error_Msg_NE
- ("declaration of private } must be a tagged type ", Prev, Id);
+ ("declaration of private } must be a tagged type", Prev, Id);
else
Error_Msg_NE
- ("full declaration of } must be a tagged type ", Prev, Id);
+ ("full declaration of } must be a tagged type", Prev, Id);
end if;
end if;
end Tag_Mismatch;
@@ -17547,7 +17812,7 @@ package body Sem_Ch3 is
if Is_Tagged_Type (Prev)
and then Present (Class_Wide_Type (Prev))
then
- Set_Ekind (Id, Ekind (Prev)); -- will be reset later
+ Mutate_Ekind (Id, Ekind (Prev)); -- will be reset later
Set_Class_Wide_Type (Id, Class_Wide_Type (Prev));
-- Type of the class-wide type is the current Id. Previously
@@ -17825,6 +18090,44 @@ package body Sem_Ch3 is
T := Make_Defining_Identifier (Sloc (P), Nam);
+ -- If In_Spec_Expression, for example within a pre/postcondition,
+ -- provide enough information for use of the subtype without
+ -- depending on full analysis and freezing, which will happen when
+ -- building the correspondiing subprogram.
+
+ if In_Spec_Expression then
+ Analyze (Subtype_Mark (Obj_Def));
+
+ declare
+ Base_T : constant Entity_Id := Entity (Subtype_Mark (Obj_Def));
+ Decl : constant Node_Id :=
+ Make_Subtype_Declaration (Sloc (P),
+ Defining_Identifier => T,
+ Subtype_Indication => Relocate_Node (Obj_Def));
+ begin
+ Set_Etype (T, Base_T);
+ Mutate_Ekind (T, Subtype_Kind (Ekind (Base_T)));
+ Set_Parent (T, Obj_Def);
+
+ if Ekind (T) = E_Array_Subtype then
+ Set_First_Index (T, First_Index (Base_T));
+ Set_Is_Constrained (T);
+
+ elsif Ekind (T) = E_Record_Subtype then
+ Set_First_Entity (T, First_Entity (Base_T));
+ Set_Has_Discriminants (T, Has_Discriminants (Base_T));
+ Set_Is_Constrained (T);
+ end if;
+
+ Insert_Before (Related_Nod, Decl);
+ end;
+
+ return T;
+ end if;
+
+ -- When generating code, insert subtype declaration ahead of
+ -- declaration that generated it.
+
Insert_Action (Obj_Def,
Make_Subtype_Declaration (Sloc (P),
Defining_Identifier => T,
@@ -17856,9 +18159,8 @@ package body Sem_Ch3 is
T := Access_Definition (Related_Nod, Obj_Def);
Set_Is_Local_Anonymous_Access
- (T,
- V => (Ada_Version < Ada_2012)
- or else (Nkind (P) /= N_Object_Declaration)
+ (T, Ada_Version < Ada_2012
+ or else Nkind (P) /= N_Object_Declaration
or else Is_Library_Level_Entity (Defining_Identifier (P)));
-- Otherwise, the object definition is just a subtype_mark
@@ -17903,10 +18205,6 @@ package body Sem_Ch3 is
Typ := Entity (S);
end if;
- -- Check No_Wide_Characters restriction
-
- Check_Wide_Character_Restriction (Typ, S);
-
return Typ;
end Find_Type_Of_Subtype_Indic;
@@ -18106,7 +18404,7 @@ package body Sem_Ch3 is
Set_Digits_Value (Implicit_Base, Digits_Value (Base_Typ));
Set_Float_Rep (Implicit_Base, Float_Rep (Base_Typ));
- Set_Ekind (T, E_Floating_Point_Subtype);
+ Mutate_Ekind (T, E_Floating_Point_Subtype);
Set_Etype (T, Implicit_Base);
Set_Size_Info (T, Implicit_Base);
Set_RM_Size (T, RM_Size (Implicit_Base));
@@ -18593,7 +18891,7 @@ package body Sem_Ch3 is
if Is_Tagged and then Ekind (New_C) = E_Component
and then Nkind (N) /= N_Private_Extension_Declaration
then
- Set_Ekind (New_C, E_Void);
+ Mutate_Ekind (New_C, E_Void);
end if;
if Plain_Discrim then
@@ -18792,56 +19090,6 @@ package body Sem_Ch3 is
return False;
end Is_EVF_Procedure;
- -----------------------
- -- Is_Null_Extension --
- -----------------------
-
- function Is_Null_Extension (T : Entity_Id) return Boolean is
- Type_Decl : constant Node_Id := Parent (Base_Type (T));
- Comp_List : Node_Id;
- Comp : Node_Id;
-
- begin
- if Nkind (Type_Decl) /= N_Full_Type_Declaration
- or else not Is_Tagged_Type (T)
- or else Nkind (Type_Definition (Type_Decl)) /=
- N_Derived_Type_Definition
- or else No (Record_Extension_Part (Type_Definition (Type_Decl)))
- then
- return False;
- end if;
-
- Comp_List :=
- Component_List (Record_Extension_Part (Type_Definition (Type_Decl)));
-
- if Present (Discriminant_Specifications (Type_Decl)) then
- return False;
-
- elsif Present (Comp_List)
- and then Is_Non_Empty_List (Component_Items (Comp_List))
- then
- Comp := First (Component_Items (Comp_List));
-
- -- Only user-defined components are relevant. The component list
- -- may also contain a parent component and internal components
- -- corresponding to secondary tags, but these do not determine
- -- whether this is a null extension.
-
- while Present (Comp) loop
- if Comes_From_Source (Comp) then
- return False;
- end if;
-
- Next (Comp);
- end loop;
-
- return True;
-
- else
- return True;
- end if;
- end Is_Null_Extension;
-
--------------------------
-- Is_Private_Primitive --
--------------------------
@@ -18927,21 +19175,8 @@ package body Sem_Ch3 is
-------------------
function Is_Local_Type (Typ : Entity_Id) return Boolean is
- Scop : Entity_Id;
-
begin
- Scop := Scope (Typ);
- while Present (Scop)
- and then Scop /= Standard_Standard
- loop
- if Scop = Scope (Current_Scope) then
- return True;
- end if;
-
- Scop := Scope (Scop);
- end loop;
-
- return False;
+ return Scope_Within (Inner => Typ, Outer => Scope (Current_Scope));
end Is_Local_Type;
-- Start of processing for Is_Visible_Component
@@ -19148,7 +19383,24 @@ package body Sem_Ch3 is
-- abstract, its Etype points back to the specific root type, and it
-- cannot have any invariants.
- Set_Ekind (CW_Type, E_Class_Wide_Type);
+ if Ekind (CW_Type) in Incomplete_Or_Private_Kind then
+ Reinit_Field_To_Zero (CW_Type, F_Private_Dependents);
+
+ elsif Ekind (CW_Type) in Concurrent_Kind then
+ Reinit_Field_To_Zero (CW_Type, F_First_Private_Entity);
+ Reinit_Field_To_Zero (CW_Type, F_Scope_Depth_Value);
+
+ if Ekind (CW_Type) in Task_Kind then
+ Reinit_Field_To_Zero (CW_Type, F_Is_Elaboration_Checks_OK_Id);
+ Reinit_Field_To_Zero (CW_Type, F_Is_Elaboration_Warnings_OK_Id);
+ end if;
+
+ if Ekind (CW_Type) in E_Task_Type | E_Protected_Type then
+ Reinit_Field_To_Zero (CW_Type, F_SPARK_Aux_Pragma_Inherited);
+ end if;
+ end if;
+
+ Mutate_Ekind (CW_Type, E_Class_Wide_Type);
Set_Is_Tagged_Type (CW_Type, True);
Set_Direct_Primitive_Operations (CW_Type, New_Elmt_List);
Set_Is_Abstract_Type (CW_Type, False);
@@ -19354,7 +19606,7 @@ package body Sem_Ch3 is
else
if not Is_Entity_Name (N) or else not Is_Type (Entity (N)) then
- Error_Msg_N ("invalid subtype mark in discrete range ", N);
+ Error_Msg_N ("invalid subtype mark in discrete range", N);
Set_Etype (N, Any_Integer);
return;
@@ -19426,13 +19678,13 @@ package body Sem_Ch3 is
Set_Etype (Def_Id, Base_Type (T));
if Is_Signed_Integer_Type (T) then
- Set_Ekind (Def_Id, E_Signed_Integer_Subtype);
+ Mutate_Ekind (Def_Id, E_Signed_Integer_Subtype);
elsif Is_Modular_Integer_Type (T) then
- Set_Ekind (Def_Id, E_Modular_Integer_Subtype);
+ Mutate_Ekind (Def_Id, E_Modular_Integer_Subtype);
else
- Set_Ekind (Def_Id, E_Enumeration_Subtype);
+ Mutate_Ekind (Def_Id, E_Enumeration_Subtype);
Set_Is_Character_Type (Def_Id, Is_Character_Type (T));
Set_First_Literal (Def_Id, First_Literal (T));
end if;
@@ -19513,7 +19765,7 @@ package body Sem_Ch3 is
begin
-- If the mod expression is (exactly) 2 * literal, where literal is
- -- 128 or less,then almost certainly the * was meant to be **. Warn.
+ -- 128 or less, then almost certainly the * was meant to be **. Warn.
if Warn_On_Suspicious_Modulus_Value
and then Nkind (Mod_Expr) = N_Op_Multiply
@@ -19529,8 +19781,13 @@ package body Sem_Ch3 is
-- Proceed with analysis of mod expression
Analyze_And_Resolve (Mod_Expr, Any_Integer);
+
+ if Ekind (T) in Incomplete_Or_Private_Kind then
+ Reinit_Field_To_Zero (T, F_Stored_Constraint);
+ end if;
+
Set_Etype (T, T);
- Set_Ekind (T, E_Modular_Integer_Type);
+ Mutate_Ekind (T, E_Modular_Integer_Type);
Init_Alignment (T);
Set_Is_Constrained (T);
@@ -19644,7 +19901,7 @@ package body Sem_Ch3 is
begin
Op := Make_Defining_Operator_Symbol (Loc, Name_Op_Concat);
- Set_Ekind (Op, E_Operator);
+ Mutate_Ekind (Op, E_Operator);
Set_Scope (Op, Current_Scope);
Set_Etype (Op, Typ);
Set_Homonym (Op, Get_Name_Entity_Id (Name_Op_Concat));
@@ -19930,7 +20187,7 @@ package body Sem_Ch3 is
-- chain ensures that SPARK-related pragmas are not clobbered when the
-- ordinary fixed point type acts as a full view of a private type.
- Set_Ekind (T, E_Ordinary_Fixed_Point_Subtype);
+ Mutate_Ekind (T, E_Ordinary_Fixed_Point_Subtype);
Set_Etype (T, Implicit_Base);
Init_Size_Align (T);
Inherit_Rep_Item_Chain (T, Implicit_Base);
@@ -20064,19 +20321,34 @@ package body Sem_Ch3 is
end if;
if Nkind (Discriminant_Type (Discr)) = N_Access_Definition then
- Discr_Type := Access_Definition (Discr, Discriminant_Type (Discr));
+ Check_Anonymous_Access_Component
+ (Typ_Decl => N,
+ Typ => Defining_Identifier (N),
+ Prev => Prev,
+ Comp_Def => Discr,
+ Access_Def => Discriminant_Type (Discr));
+
+ -- if Check_Anonymous_Access_Component replaced Discr then
+ -- its Original_Node points to the old Discr and the access type
+ -- for Discr_Type has already been created.
+
+ if Original_Node (Discr) /= Discr then
+ Discr_Type := Etype (Discriminant_Type (Discr));
+ else
+ Discr_Type :=
+ Access_Definition (Discr, Discriminant_Type (Discr));
- -- Ada 2005 (AI-254)
+ -- Ada 2005 (AI-254)
- if Present (Access_To_Subprogram_Definition
- (Discriminant_Type (Discr)))
- and then Protected_Present (Access_To_Subprogram_Definition
- (Discriminant_Type (Discr)))
- then
- Discr_Type :=
- Replace_Anonymous_Access_To_Protected_Subprogram (Discr);
+ if Present (Access_To_Subprogram_Definition
+ (Discriminant_Type (Discr)))
+ and then Protected_Present (Access_To_Subprogram_Definition
+ (Discriminant_Type (Discr)))
+ then
+ Discr_Type :=
+ Replace_Anonymous_Access_To_Protected_Subprogram (Discr);
+ end if;
end if;
-
else
Find_Type (Discriminant_Type (Discr));
Discr_Type := Etype (Discriminant_Type (Discr));
@@ -20313,7 +20585,12 @@ package body Sem_Ch3 is
Discr_Number := Uint_1;
while Present (Discr) loop
Id := Defining_Identifier (Discr);
- Set_Ekind (Id, E_Discriminant);
+
+ if Ekind (Id) = E_In_Parameter then
+ Reinit_Field_To_Zero (Id, F_Discriminal_Link);
+ end if;
+
+ Mutate_Ekind (Id, E_Discriminant);
Init_Component_Location (Id);
Init_Esize (Id);
Set_Discriminant_Number (Id, Discr_Number);
@@ -20673,7 +20950,7 @@ package body Sem_Ch3 is
& "has no discriminants", Full_T);
end if;
- -- ??????? Do we implement the following properly ?????
+ -- Do we implement the following properly???
-- If the ancestor subtype of a private extension has constrained
-- discriminants, then the parent subtype of the full view shall
-- impose a statically matching constraint on those discriminants
@@ -20750,11 +21027,9 @@ package body Sem_Ch3 is
if not Has_Unknown_Discriminants (Priv_T)
and then not Has_Discriminants (Priv_T)
- and then Has_Discriminants (Full_T)
- and then
- Present (Discriminant_Default_Value (First_Discriminant (Full_T)))
+ and then Has_Defaulted_Discriminants (Full_T)
then
- Set_Has_Constrained_Partial_View (Full_T);
+ Set_Has_Constrained_Partial_View (Base_Type (Full_T));
Set_Has_Constrained_Partial_View (Priv_T);
end if;
@@ -20816,48 +21091,48 @@ package body Sem_Ch3 is
end loop;
end;
- -- If the private view was tagged, copy the new primitive operations
- -- from the private view to the full view.
+ declare
+ Disp_Typ : Entity_Id;
+ Full_List : Elist_Id;
+ Prim : Entity_Id;
+ Prim_Elmt : Elmt_Id;
+ Priv_List : Elist_Id;
+
+ function Contains
+ (E : Entity_Id;
+ L : Elist_Id) return Boolean;
+ -- Determine whether list L contains element E
+
+ --------------
+ -- Contains --
+ --------------
+
+ function Contains
+ (E : Entity_Id;
+ L : Elist_Id) return Boolean
+ is
+ List_Elmt : Elmt_Id;
- if Is_Tagged_Type (Full_T) then
- declare
- Disp_Typ : Entity_Id;
- Full_List : Elist_Id;
- Prim : Entity_Id;
- Prim_Elmt : Elmt_Id;
- Priv_List : Elist_Id;
-
- function Contains
- (E : Entity_Id;
- L : Elist_Id) return Boolean;
- -- Determine whether list L contains element E
-
- --------------
- -- Contains --
- --------------
-
- function Contains
- (E : Entity_Id;
- L : Elist_Id) return Boolean
- is
- List_Elmt : Elmt_Id;
+ begin
+ List_Elmt := First_Elmt (L);
+ while Present (List_Elmt) loop
+ if Node (List_Elmt) = E then
+ return True;
+ end if;
- begin
- List_Elmt := First_Elmt (L);
- while Present (List_Elmt) loop
- if Node (List_Elmt) = E then
- return True;
- end if;
+ Next_Elmt (List_Elmt);
+ end loop;
- Next_Elmt (List_Elmt);
- end loop;
+ return False;
+ end Contains;
- return False;
- end Contains;
+ -- Start of processing
- -- Start of processing
+ begin
+ -- If the private view was tagged, copy the new primitive operations
+ -- from the private view to the full view.
- begin
+ if Is_Tagged_Type (Full_T) then
if Is_Tagged_Type (Priv_T) then
Priv_List := Primitive_Operations (Priv_T);
Prim_Elmt := First_Elmt (Priv_List);
@@ -20991,8 +21266,23 @@ package body Sem_Ch3 is
Propagate_Concurrent_Flags (Class_Wide_Type (Priv_T), Full_T);
end if;
- end;
- end if;
+
+ -- For untagged types, copy the primitives across from the private
+ -- view to the full view (when extensions are allowed), for support
+ -- of prefixed calls (when extensions are enabled).
+
+ elsif Extensions_Allowed then
+ Priv_List := Primitive_Operations (Priv_T);
+ Prim_Elmt := First_Elmt (Priv_List);
+
+ Full_List := Primitive_Operations (Full_T);
+ while Present (Prim_Elmt) loop
+ Prim := Node (Prim_Elmt);
+ Append_Elmt (Prim, Full_List);
+ Next_Elmt (Prim_Elmt);
+ end loop;
+ end if;
+ end;
-- Ada 2005 AI 161: Check preelaborable initialization consistency
@@ -21199,8 +21489,11 @@ package body Sem_Ch3 is
then
Set_Subtype_Indication
(Parent (Priv_Dep), New_Occurrence_Of (Full_T, Sloc (Priv_Dep)));
+ Reinit_Field_To_Zero
+ (Priv_Dep, F_Private_Dependents,
+ Old_Ekind => E_Incomplete_Subtype);
+ Mutate_Ekind (Priv_Dep, Subtype_Kind (Ekind (Full_T)));
Set_Etype (Priv_Dep, Full_T);
- Set_Ekind (Priv_Dep, Subtype_Kind (Ekind (Full_T)));
Set_Analyzed (Parent (Priv_Dep), False);
-- Reanalyze the declaration, suppressing the call to Enter_Name
@@ -21774,7 +22067,7 @@ package body Sem_Ch3 is
-- Set Ekind of orphan itype, to prevent cascaded errors
if Present (Def_Id) then
- Set_Ekind (Def_Id, Ekind (Any_Type));
+ Mutate_Ekind (Def_Id, Ekind (Any_Type));
end if;
-- Make recursive call, having got rid of the bogus constraint
@@ -21965,7 +22258,7 @@ package body Sem_Ch3 is
-- These flags must be initialized before calling Process_Discriminants
-- because this routine makes use of them.
- Set_Ekind (T, E_Record_Type);
+ Mutate_Ekind (T, E_Record_Type);
Set_Etype (T, T);
Init_Size_Align (T);
Set_Interfaces (T, No_Elist);
@@ -22069,7 +22362,7 @@ package body Sem_Ch3 is
Tag_Comp := Make_Defining_Identifier (Sloc (Def), Name_uTag);
Enter_Name (Tag_Comp);
- Set_Ekind (Tag_Comp, E_Component);
+ Mutate_Ekind (Tag_Comp, E_Component);
Set_Is_Tag (Tag_Comp);
Set_Is_Aliased (Tag_Comp);
Set_Is_Independent (Tag_Comp);
@@ -22142,10 +22435,10 @@ package body Sem_Ch3 is
Final_Storage_Only := not Is_Controlled (T);
- -- Ada 2005: Check whether an explicit Limited is present in a derived
+ -- Ada 2005: Check whether an explicit "limited" is present in a derived
-- type declaration.
- if Nkind (Parent (Def)) = N_Derived_Type_Definition
+ if Parent_Kind (Def) = N_Derived_Type_Definition
and then Limited_Present (Parent (Def))
then
Set_Is_Limited_Record (T);
@@ -22179,7 +22472,7 @@ package body Sem_Ch3 is
if Ekind (Component) = E_Void
and then not Is_Itype (Component)
then
- Set_Ekind (Component, E_Component);
+ Mutate_Ekind (Component, E_Component);
Init_Component_Location (Component);
end if;
@@ -22400,9 +22693,9 @@ package body Sem_Ch3 is
-- Reset the kind of the subtype during analysis of the range, to
-- catch possible premature use in the bounds themselves.
- Set_Ekind (Def_Id, E_Void);
+ Mutate_Ekind (Def_Id, E_Void);
Process_Range_Expr_In_Decl (R, Subt, Subtyp => Def_Id);
- Set_Ekind (Def_Id, Kind);
+ Mutate_Ekind (Def_Id, Kind);
end Set_Scalar_Range_For_Subtype;
--------------------------------------------------------
@@ -22578,7 +22871,7 @@ package body Sem_Ch3 is
Set_First_Rep_Item (Implicit_Base, First_Rep_Item (Base_Typ));
Set_Scalar_Range (Implicit_Base, Scalar_Range (Base_Typ));
- Set_Ekind (T, E_Signed_Integer_Subtype);
+ Mutate_Ekind (T, E_Signed_Integer_Subtype);
Set_Etype (T, Implicit_Base);
Set_Size_Info (T, Implicit_Base);
Inherit_Rep_Item_Chain (T, Implicit_Base);
diff --git a/gcc/ada/sem_ch3.ads b/gcc/ada/sem_ch3.ads
index e94ce15..eedb98c 100644
--- a/gcc/ada/sem_ch3.ads
+++ b/gcc/ada/sem_ch3.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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,8 +69,10 @@ package Sem_Ch3 is
-- interface primitives with the tagged type primitives that cover them.
procedure Analyze_Declarations (L : List_Id);
- -- Called to analyze a list of declarations (in what context ???). Also
- -- performs necessary freezing actions (more description needed ???)
+ -- Called to analyze a list of declarations. Also performs necessary
+ -- freezing actions (such as freezing remaining unfrozen entities at
+ -- the end of declarative parts), resolves usage names in aspects, and
+ -- analyzes contracts that require delay until after freezing is done.
procedure Analyze_Interface_Declaration (T : Entity_Id; Def : Node_Id);
-- Analyze an interface declaration or a formal interface declaration
@@ -169,14 +171,10 @@ package Sem_Ch3 is
(Discriminant : Entity_Id;
Typ_For_Constraint : Entity_Id;
Constraint : Elist_Id) return Node_Id;
- -- ??? MORE DOCUMENTATION
- -- Given a discriminant somewhere in the Typ_For_Constraint tree and a
- -- Constraint, return the value of that discriminant.
-
- function Is_Null_Extension (T : Entity_Id) return Boolean;
- -- Returns True if the tagged type T has an N_Full_Type_Declaration that
- -- is a null extension, meaning that it has an extension part without any
- -- components and does not have a known discriminant part.
+ -- Given a discriminant Discriminant occurring somewhere up the derivation
+ -- tree from Typ_For_Constraint and a Constraint, return the expression
+ -- corresponding to that discriminant in the constraint that specifies its
+ -- value.
function Is_Visible_Component
(C : Entity_Id;
diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb
index 7a8c261..c052022 100644
--- a/gcc/ada/sem_ch4.adb
+++ b/gcc/ada/sem_ch4.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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,44 +23,48 @@
-- --
------------------------------------------------------------------------------
-with Aspects; use Aspects;
-with Atree; use Atree;
-with Debug; use Debug;
-with Einfo; use Einfo;
-with Elists; use Elists;
-with Errout; use Errout;
-with Exp_Util; use Exp_Util;
-with Itypes; use Itypes;
-with Lib; use Lib;
-with Lib.Xref; use Lib.Xref;
-with Namet; use Namet;
-with Namet.Sp; use Namet.Sp;
-with Nlists; use Nlists;
-with Nmake; use Nmake;
-with Opt; use Opt;
-with Output; use Output;
-with Restrict; use Restrict;
-with Rident; use Rident;
-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_Ch8; use Sem_Ch8;
-with Sem_Dim; use Sem_Dim;
-with Sem_Disp; use Sem_Disp;
-with Sem_Dist; use Sem_Dist;
-with Sem_Eval; use Sem_Eval;
-with Sem_Res; use Sem_Res;
-with Sem_Type; use Sem_Type;
-with Sem_Util; use Sem_Util;
-with Sem_Warn; use Sem_Warn;
-with Stand; use Stand;
-with Sinfo; use Sinfo;
-with Snames; use Snames;
-with Tbuild; use Tbuild;
-with Uintp; use Uintp;
+with Aspects; use Aspects;
+with Atree; use Atree;
+with Debug; use Debug;
+with Einfo; use Einfo;
+with Einfo.Entities; use Einfo.Entities;
+with Einfo.Utils; use Einfo.Utils;
+with Elists; use Elists;
+with Errout; use Errout;
+with Exp_Util; use Exp_Util;
+with Itypes; use Itypes;
+with Lib; use Lib;
+with Lib.Xref; use Lib.Xref;
+with Namet; use Namet;
+with Namet.Sp; use Namet.Sp;
+with Nlists; use Nlists;
+with Nmake; use Nmake;
+with Opt; use Opt;
+with Output; use Output;
+with Restrict; use Restrict;
+with Rident; use Rident;
+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_Ch8; use Sem_Ch8;
+with Sem_Dim; use Sem_Dim;
+with Sem_Disp; use Sem_Disp;
+with Sem_Dist; use Sem_Dist;
+with Sem_Eval; use Sem_Eval;
+with Sem_Res; use Sem_Res;
+with Sem_Type; use Sem_Type;
+with Sem_Util; use Sem_Util;
+with Sem_Warn; use Sem_Warn;
+with Stand; use Stand;
+with Sinfo; use Sinfo;
+with Sinfo.Nodes; use Sinfo.Nodes;
+with Sinfo.Utils; use Sinfo.Utils;
+with Snames; use Snames;
+with Tbuild; use Tbuild;
+with Uintp; use Uintp;
package body Sem_Ch4 is
@@ -599,12 +603,8 @@ package body Sem_Ch4 is
Type_Id := Entity (E);
if Is_Tagged_Type (Type_Id)
- and then Has_Discriminants (Type_Id)
+ and then Has_Defaulted_Discriminants (Type_Id)
and then not Is_Constrained (Type_Id)
- and then
- Present
- (Discriminant_Default_Value
- (First_Discriminant (Type_Id)))
then
declare
Constr : constant List_Id := New_List;
@@ -612,19 +612,17 @@ package body Sem_Ch4 is
Discr : Entity_Id := First_Discriminant (Type_Id);
begin
- if Present (Discriminant_Default_Value (Discr)) then
- while Present (Discr) loop
- Append (Discriminant_Default_Value (Discr), Constr);
- Next_Discriminant (Discr);
- end loop;
+ while Present (Discr) loop
+ Append (Discriminant_Default_Value (Discr), Constr);
+ Next_Discriminant (Discr);
+ end loop;
- Rewrite (E,
- Make_Subtype_Indication (Loc,
- Subtype_Mark => New_Occurrence_Of (Type_Id, Loc),
- Constraint =>
- Make_Index_Or_Discriminant_Constraint (Loc,
- Constraints => Constr)));
- end if;
+ Rewrite (E,
+ Make_Subtype_Indication (Loc,
+ Subtype_Mark => New_Occurrence_Of (Type_Id, Loc),
+ Constraint =>
+ Make_Index_Or_Discriminant_Constraint (Loc,
+ Constraints => Constr)));
end;
end if;
end if;
@@ -1467,8 +1465,6 @@ package body Sem_Ch4 is
else
Remove_Abstract_Operations (N);
end if;
-
- End_Interp_List;
end if;
-- Check the accessibility level for actuals for explicitly aliased
@@ -2278,9 +2274,12 @@ 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.
+ -- Check that the action A is allowed as a declare_item of a declare
+ -- expression if N and A come from source.
+
+ ---------------------
+ -- Check_Action_OK --
+ ---------------------
procedure Check_Action_OK (A : Node_Id) is
begin
@@ -2324,7 +2323,7 @@ package body Sem_Ch4 is
Error_Msg_N ("object renaming or constant declaration expected", A);
end Check_Action_OK;
- A : Node_Id;
+ A : Node_Id;
EWA_Scop : Entity_Id;
-- Start of processing for Analyze_Expression_With_Actions
@@ -2793,8 +2792,6 @@ package body Sem_Ch4 is
Error_Msg_N ("no legal interpretation for indexed component", N);
Set_Is_Overloaded (N, False);
end if;
-
- End_Interp_List;
end Process_Overloaded_Indexed_Component;
-- Start of processing for Analyze_Indexed_Component_Form
@@ -4345,8 +4342,7 @@ package body Sem_Ch4 is
or else
Covers (T1 => T2, T2 => T1)
then
- if T1 = Universal_Integer
- or else T1 = Universal_Real
+ if Is_Universal_Numeric_Type (T1)
or else T1 = Any_Character
then
Add_One_Interp (N, Base_Type (T2), Base_Type (T2));
@@ -4416,7 +4412,7 @@ package body Sem_Ch4 is
-- If result is Any_Type, then we did not find a compatible pair
if Etype (N) = Any_Type then
- Error_Msg_N ("incompatible types in range ", N);
+ Error_Msg_N ("incompatible types in range", N);
end if;
end if;
@@ -5006,8 +5002,11 @@ package body Sem_Ch4 is
-- Ada 2005 (AI05-0030): In the case of dispatching requeue, the
-- selected component should resolve to a name.
+ -- Extension feature: Also support calls with prefixed views for
+ -- untagged record types.
+
if Ada_Version >= Ada_2005
- and then Is_Tagged_Type (Prefix_Type)
+ and then (Is_Tagged_Type (Prefix_Type) or else Extensions_Allowed)
and then not Is_Concurrent_Type (Prefix_Type)
then
if Nkind (Parent (N)) = N_Generic_Association
@@ -5080,6 +5079,15 @@ package body Sem_Ch4 is
Next_Entity (Comp);
end loop;
+ -- Extension feature: Also support calls with prefixed views for
+ -- untagged private types.
+
+ if Extensions_Allowed then
+ if Try_Object_Operation (N) then
+ return;
+ end if;
+ end if;
+
elsif Is_Concurrent_Type (Prefix_Type) then
-- Find visible operation with given name. For a protected type,
@@ -5299,7 +5307,7 @@ package body Sem_Ch4 is
Set_Parent (Par, Parent (Parent (N)));
if Try_Object_Operation
- (Sinfo.Name (Par), CW_Test_Only => True)
+ (Sinfo.Nodes.Name (Par), CW_Test_Only => True)
then
return;
end if;
@@ -5332,6 +5340,14 @@ package body Sem_Ch4 is
Set_Is_Overloaded (N, Is_Overloaded (Sel));
+ -- Extension feature: Also support calls with prefixed views for
+ -- untagged types.
+
+ elsif Extensions_Allowed
+ and then Try_Object_Operation (N)
+ then
+ return;
+
else
-- Invalid prefix
@@ -5455,9 +5471,9 @@ package body Sem_Ch4 is
Apply_Compile_Time_Constraint_Error
(N, "component not present in }??",
CE_Discriminant_Check_Failed,
- Ent => Prefix_Type);
-
- Set_Raises_Constraint_Error (N);
+ Ent => Prefix_Type,
+ Emit_Message =>
+ SPARK_Mode = On or not In_Instance_Not_Visible);
return;
end if;
@@ -5972,7 +5988,7 @@ package body Sem_Ch4 is
function Specific_Type (T1, T2 : Entity_Id) return Entity_Id is
begin
- if T1 = Universal_Integer or else T1 = Universal_Real then
+ if Is_Universal_Numeric_Type (T1) then
return Base_Type (T2);
else
return Base_Type (T1);
@@ -9542,7 +9558,15 @@ package body Sem_Ch4 is
-- type, this is not a prefixed call. Restore the previous type as
-- the current one is not a legal candidate.
- if not Is_Tagged_Type (Obj_Type)
+ -- Extension feature: Calls with prefixed views are also supported
+ -- for untagged types, so skip the early return when extensions are
+ -- enabled, unless the type doesn't have a primitive operations list
+ -- (such as in the case of predefined types).
+
+ if (not Is_Tagged_Type (Obj_Type)
+ and then
+ (not Extensions_Allowed
+ or else not Present (Primitive_Operations (Obj_Type))))
or else Is_Incomplete_Type (Obj_Type)
then
Obj_Type := Prev_Obj_Type;
@@ -9560,6 +9584,36 @@ package body Sem_Ch4 is
Try_Primitive_Operation
(Call_Node => New_Call_Node,
Node_To_Replace => Node_To_Replace);
+
+ -- Extension feature: In the case where the prefix is of an
+ -- access type, and a primitive wasn't found for the designated
+ -- type, then if the access type has primitives we attempt a
+ -- prefixed call using one of its primitives. (It seems that
+ -- this isn't quite right to give preference to the designated
+ -- type in the case where both the access and designated types
+ -- have homographic prefixed-view operations that could result
+ -- in an ambiguity, but handling properly may be tricky. ???)
+
+ if Extensions_Allowed
+ and then not Prim_Result
+ and then Is_Named_Access_Type (Prev_Obj_Type)
+ and then Present (Direct_Primitive_Operations (Prev_Obj_Type))
+ then
+ -- Temporarily reset Obj_Type to the original access type
+
+ Obj_Type := Prev_Obj_Type;
+
+ Prim_Result :=
+ Try_Primitive_Operation
+ (Call_Node => New_Call_Node,
+ Node_To_Replace => Node_To_Replace);
+
+ -- Restore Obj_Type to the designated type (is this really
+ -- necessary, or should it only be done when Prim_Result is
+ -- still False?).
+
+ Obj_Type := Designated_Type (Obj_Type);
+ end if;
end if;
-- Check if there is a class-wide subprogram covering the
@@ -9899,7 +9953,7 @@ package body Sem_Ch4 is
-- be the corresponding record of a synchronized type.
return Obj_Type = Typ
- or else Base_Type (Obj_Type) = Typ
+ or else Base_Type (Obj_Type) = Base_Type (Typ)
or else Corr_Type = Typ
-- Object may be of a derived type whose parent has unknown
@@ -10212,6 +10266,16 @@ package body Sem_Ch4 is
Report => True,
Success => Success,
Skip_First => True);
+
+ -- The error may hot have been reported yet for overloaded
+ -- prefixed calls, depending on the non-matching candidate,
+ -- in which case provide a concise error now.
+
+ if Serious_Errors_Detected = 0 then
+ Error_Msg_NE
+ ("cannot resolve prefixed call to primitive operation of&",
+ N, Entity (Obj));
+ end if;
end if;
-- No need for further errors
diff --git a/gcc/ada/sem_ch4.ads b/gcc/ada/sem_ch4.ads
index 25daab2..7379626 100644
--- a/gcc/ada/sem_ch4.ads
+++ b/gcc/ada/sem_ch4.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute 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 04fc980..7a8d0cc 100644
--- a/gcc/ada/sem_ch5.adb
+++ b/gcc/ada/sem_ch5.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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,44 +23,49 @@
-- --
------------------------------------------------------------------------------
-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;
-with Exp_Ch6; use Exp_Ch6;
-with Exp_Util; use Exp_Util;
-with Freeze; use Freeze;
-with Ghost; use Ghost;
-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 Sem; use Sem;
-with Sem_Aux; use Sem_Aux;
-with Sem_Case; use Sem_Case;
-with Sem_Ch3; use Sem_Ch3;
-with Sem_Ch6; use Sem_Ch6;
-with Sem_Ch8; use Sem_Ch8;
-with Sem_Dim; use Sem_Dim;
-with Sem_Disp; use Sem_Disp;
-with Sem_Elab; use Sem_Elab;
-with Sem_Eval; use Sem_Eval;
-with Sem_Res; use Sem_Res;
-with Sem_Type; use Sem_Type;
-with Sem_Util; use Sem_Util;
-with Sem_Warn; use Sem_Warn;
-with Snames; use Snames;
-with Stand; use Stand;
-with Sinfo; use Sinfo;
-with Targparm; use Targparm;
-with Tbuild; use Tbuild;
-with Ttypes; use Ttypes;
-with Uintp; use Uintp;
+with Aspects; use Aspects;
+with Atree; use Atree;
+with Checks; use Checks;
+with Debug; use Debug;
+with Einfo; use Einfo;
+with Einfo.Entities; use Einfo.Entities;
+with Einfo.Utils; use Einfo.Utils;
+with Errout; use Errout;
+with Expander; use Expander;
+with Exp_Ch6; use Exp_Ch6;
+with Exp_Tss; use Exp_Tss;
+with Exp_Util; use Exp_Util;
+with Freeze; use Freeze;
+with Ghost; use Ghost;
+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 Sem; use Sem;
+with Sem_Aux; use Sem_Aux;
+with Sem_Case; use Sem_Case;
+with Sem_Ch3; use Sem_Ch3;
+with Sem_Ch6; use Sem_Ch6;
+with Sem_Ch8; use Sem_Ch8;
+with Sem_Dim; use Sem_Dim;
+with Sem_Disp; use Sem_Disp;
+with Sem_Elab; use Sem_Elab;
+with Sem_Eval; use Sem_Eval;
+with Sem_Res; use Sem_Res;
+with Sem_Type; use Sem_Type;
+with Sem_Util; use Sem_Util;
+with Sem_Warn; use Sem_Warn;
+with Snames; use Snames;
+with Stand; use Stand;
+with Sinfo; use Sinfo;
+with Sinfo.Nodes; use Sinfo.Nodes;
+with Sinfo.Utils; use Sinfo.Utils;
+with Targparm; use Targparm;
+with Tbuild; use Tbuild;
+with Ttypes; use Ttypes;
+with Uintp; use Uintp;
package body Sem_Ch5 is
@@ -475,12 +480,11 @@ package body Sem_Ch5 is
Mark_And_Set_Ghost_Assignment (N);
if Has_Target_Names (N) then
+ pragma Assert (No (Current_Assignment));
Current_Assignment := N;
Expander_Mode_Save_And_Set (False);
Save_Full_Analysis := Full_Analysis;
Full_Analysis := False;
- else
- Current_Assignment := Empty;
end if;
Analyze (Lhs);
@@ -975,7 +979,92 @@ package body Sem_Ch5 is
end if;
if Is_Scalar_Type (T1) then
- Apply_Scalar_Range_Check (Rhs, Etype (Lhs));
+ declare
+
+ function Omit_Range_Check_For_Streaming return Boolean;
+ -- Return True if this assignment statement is the expansion of
+ -- a Some_Scalar_Type'Read procedure call such that all conditions
+ -- of 13.3.2(35)'s "no check is made" rule are met.
+
+ ------------------------------------
+ -- Omit_Range_Check_For_Streaming --
+ ------------------------------------
+
+ function Omit_Range_Check_For_Streaming return Boolean is
+ begin
+ -- Have we got an implicitly generated assignment to a
+ -- component of a composite object? If not, return False.
+
+ if Comes_From_Source (N)
+ or else Serious_Errors_Detected > 0
+ or else Nkind (Lhs)
+ not in N_Selected_Component | N_Indexed_Component
+ then
+ return False;
+ end if;
+
+ declare
+ Pref : constant Node_Id := Prefix (Lhs);
+ begin
+ -- Are we in the implicitly-defined Read subprogram
+ -- for a composite type, reading the value of a scalar
+ -- component from the stream? If not, return False.
+
+ if Nkind (Pref) /= N_Identifier
+ or else not Is_TSS (Scope (Entity (Pref)), TSS_Stream_Read)
+ then
+ return False;
+ end if;
+
+ -- Return False if Default_Value or Default_Component_Value
+ -- aspect applies.
+
+ if Has_Default_Aspect (Etype (Lhs))
+ or else Has_Default_Aspect (Etype (Pref))
+ then
+ return False;
+
+ -- Are we assigning to a record component (as opposed to
+ -- an array component)?
+
+ elsif Nkind (Lhs) = N_Selected_Component then
+
+ -- Are we assigning to a nondiscriminant component
+ -- that lacks a default initial value expression?
+ -- If so, return True.
+
+ declare
+ Comp_Id : constant Entity_Id :=
+ Original_Record_Component
+ (Entity (Selector_Name (Lhs)));
+ begin
+ if Ekind (Comp_Id) = E_Component
+ and then Nkind (Parent (Comp_Id))
+ = N_Component_Declaration
+ and then
+ not Present (Expression (Parent (Comp_Id)))
+ then
+ return True;
+ end if;
+ return False;
+ end;
+
+ -- We are assigning to a component of an array
+ -- (and we tested for both Default_Value and
+ -- Default_Component_Value above), so return True.
+
+ else
+ pragma Assert (Nkind (Lhs) = N_Indexed_Component);
+ return True;
+ end if;
+ end;
+ end Omit_Range_Check_For_Streaming;
+
+ begin
+ if not Omit_Range_Check_For_Streaming then
+ Apply_Scalar_Range_Check (Rhs, Etype (Lhs));
+ end if;
+ end;
-- For array types, verify that lengths match. If the right hand side
-- is a function call that has been inlined, the assignment has been
@@ -1108,6 +1197,12 @@ package body Sem_Ch5 is
-- warnings when an assignment is rewritten as another
-- assignment, and gets tied up with itself.
+ -- We also omit the warning if the RHS includes target names,
+ -- that is to say the Ada 2022 "@" that denotes an instance of
+ -- the LHS, which indicates that the current value is being
+ -- used. Note that this implicit reference to the entity on
+ -- the RHS is not treated as a source reference.
+
-- There may have been a previous reference to a component of
-- the variable, which in general removes the Last_Assignment
-- field of the variable to indicate a relevant use of the
@@ -1126,6 +1221,7 @@ package body Sem_Ch5 is
and then Comes_From_Source (N)
and then In_Extended_Main_Source_Unit (Ent)
and then not Has_Deferred_Reference (Ent)
+ and then not Has_Target_Names (N)
then
Warn_On_Useless_Assignment (Ent, N);
end if;
@@ -1205,6 +1301,7 @@ package body Sem_Ch5 is
if Has_Target_Names (N) then
Expander_Mode_Restore;
Full_Analysis := Save_Full_Analysis;
+ Current_Assignment := Empty;
end if;
pragma Assert (not Should_Transform_BIP_Assignment (Typ => T1));
@@ -1308,7 +1405,11 @@ package body Sem_Ch5 is
Set_Identifier (N, Empty);
else
- Set_Ekind (Ent, E_Block);
+ if Ekind (Ent) = E_Label then
+ Reinit_Field_To_Zero (Ent, F_Enclosing_Scope);
+ end if;
+
+ Mutate_Ekind (Ent, E_Block);
Generate_Reference (Ent, N, ' ');
Generate_Definition (Ent);
@@ -1397,6 +1498,9 @@ package body Sem_Ch5 is
-- the case statement, and as a result it is not a good idea to output
-- warning messages about unreachable code.
+ Is_General_Case_Statement : Boolean := False;
+ -- Set True (later) if type of case expression is not discrete
+
procedure Non_Static_Choice_Error (Choice : Node_Id);
-- Error routine invoked by the generic instantiation below when the
-- case statement has a non static choice.
@@ -1438,6 +1542,12 @@ package body Sem_Ch5 is
Ent : Entity_Id;
begin
+ if Is_General_Case_Statement then
+ return;
+ -- Processing deferred in this case; decls associated with
+ -- pattern match bindings don't exist yet.
+ end if;
+
Unblocked_Exit_Count := Unblocked_Exit_Count + 1;
Statements_Analyzed := True;
@@ -1456,7 +1566,7 @@ package body Sem_Ch5 is
if Is_Entity_Name (Exp) then
Ent := Entity (Exp);
- if Is_Assignable (Ent) then
+ if Is_Object (Ent) then
if List_Length (Choices) = 1
and then Nkind (First (Choices)) in N_Subexpr
and then Compile_Time_Known_Value (First (Choices))
@@ -1475,7 +1585,7 @@ package body Sem_Ch5 is
end if;
end if;
- -- Case where expression is not an entity name of a variable
+ -- Case where expression is not an entity name of an object
Analyze_Statements (Statements (Alternative));
end Process_Statements;
@@ -1509,9 +1619,37 @@ package body Sem_Ch5 is
and then Present (Full_View (Etype (Exp)))
and then Is_Discrete_Type (Full_View (Etype (Exp)))
then
- Resolve (Exp, Etype (Exp));
+ Resolve (Exp);
Exp_Type := Full_View (Etype (Exp));
+ -- For Ada, overloading might be ok because subsequently filtering
+ -- out non-discretes may resolve the ambiguity.
+ -- But GNAT extensions allow casing on non-discretes.
+
+ elsif Extensions_Allowed and then Is_Overloaded (Exp) then
+
+ -- It would be nice if we could generate all the right error
+ -- messages by calling "Resolve (Exp, Any_Type);" in the
+ -- same way that they are generated a few lines below by the
+ -- call "Analyze_And_Resolve (Exp, Any_Discrete);".
+ -- Unfortunately, Any_Type and Any_Discrete are not treated
+ -- consistently (specifically, by Sem_Type.Covers), so that
+ -- doesn't work.
+
+ Error_Msg_N
+ ("selecting expression of general case statement is ambiguous",
+ Exp);
+ return;
+
+ -- Check for a GNAT-extension "general" case statement (i.e., one where
+ -- the type of the selecting expression is not discrete).
+
+ elsif Extensions_Allowed
+ and then not Is_Discrete_Type (Etype (Exp))
+ then
+ Resolve (Exp, Etype (Exp));
+ Exp_Type := Etype (Exp);
+ Is_General_Case_Statement := True;
else
Analyze_And_Resolve (Exp, Any_Discrete);
Exp_Type := Etype (Exp);
@@ -1564,6 +1702,21 @@ package body Sem_Ch5 is
Analyze_Choices (Alternatives (N), Exp_Type);
Check_Choices (N, Alternatives (N), Exp_Type, Others_Present);
+ if Is_General_Case_Statement then
+ -- Work normally done in Process_Statements was deferred; do that
+ -- deferred work now that Check_Choices has had a chance to create
+ -- any needed pattern-match-binding declarations.
+ declare
+ Alt : Node_Id := First (Alternatives (N));
+ begin
+ while Present (Alt) loop
+ Unblocked_Exit_Count := Unblocked_Exit_Count + 1;
+ Analyze_Statements (Statements (Alt));
+ Next (Alt);
+ end loop;
+ end;
+ 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;
@@ -1758,6 +1911,18 @@ package body Sem_Ch5 is
raise Program_Error;
end Analyze_Goto_Statement;
+ ---------------------------------
+ -- Analyze_Goto_When_Statement --
+ ---------------------------------
+
+ procedure Analyze_Goto_When_Statement (N : Node_Id) is
+ begin
+ -- Verify the condition is a Boolean expression
+
+ Analyze_And_Resolve (Condition (N), Any_Boolean);
+ Check_Unset_Reference (Condition (N));
+ end Analyze_Goto_When_Statement;
+
--------------------------
-- Analyze_If_Statement --
--------------------------
@@ -1955,7 +2120,7 @@ package body Sem_Ch5 is
Id : constant Node_Id := Defining_Identifier (N);
begin
Enter_Name (Id);
- Set_Ekind (Id, E_Label);
+ Mutate_Ekind (Id, E_Label);
Set_Etype (Id, Standard_Void_Type);
Set_Enclosing_Scope (Id, Current_Scope);
end Analyze_Implicit_Label_Declaration;
@@ -2011,9 +2176,11 @@ package body Sem_Ch5 is
-- indicator, verify that the container type has an Iterate aspect that
-- implements the reversible iterator interface.
- procedure Check_Subtype_Indication (Comp_Type : Entity_Id);
+ procedure Check_Subtype_Definition (Comp_Type : Entity_Id);
-- If a subtype indication is present, verify that it is consistent
-- with the component type of the array or container name.
+ -- In Ada 2022, the subtype indication may be an access definition,
+ -- if the array or container has elements of an anonymous access type.
function Get_Cursor_Type (Typ : Entity_Id) return Entity_Id;
-- For containers with Iterator and related aspects, the cursor is
@@ -2037,31 +2204,53 @@ package body Sem_Ch5 is
then
null;
else
- Error_Msg_NE
- ("container type does not support reverse iteration", N, Typ);
+ Error_Msg_N
+ ("container type does not support reverse iteration", N);
end if;
end if;
end Check_Reverse_Iteration;
-------------------------------
- -- Check_Subtype_Indication --
+ -- Check_Subtype_Definition --
-------------------------------
- procedure Check_Subtype_Indication (Comp_Type : Entity_Id) is
+ procedure Check_Subtype_Definition (Comp_Type : Entity_Id) is
begin
- if Present (Subt)
- and then (not Covers (Base_Type ((Bas)), Comp_Type)
+ if not Present (Subt) then
+ return;
+ end if;
+
+ if Is_Anonymous_Access_Type (Entity (Subt)) then
+ if not Is_Anonymous_Access_Type (Comp_Type) then
+ Error_Msg_NE
+ ("component type& is not an anonymous access",
+ Subt, Comp_Type);
+
+ elsif not Conforming_Types
+ (Designated_Type (Entity (Subt)),
+ Designated_Type (Comp_Type),
+ Fully_Conformant)
+ then
+ Error_Msg_NE
+ ("subtype indication does not match component type&",
+ Subt, Comp_Type);
+ end if;
+
+ elsif Present (Subt)
+ and then (not Covers (Base_Type (Bas), Comp_Type)
or else not Subtypes_Statically_Match (Bas, Comp_Type))
then
if Is_Array_Type (Typ) then
- Error_Msg_N
- ("subtype indication does not match component type", Subt);
+ Error_Msg_NE
+ ("subtype indication does not match component type&",
+ Subt, Comp_Type);
else
- Error_Msg_N
- ("subtype indication does not match element type", Subt);
+ Error_Msg_NE
+ ("subtype indication does not match element type&",
+ Subt, Comp_Type);
end if;
end if;
- end Check_Subtype_Indication;
+ end Check_Subtype_Definition;
---------------------
-- Get_Cursor_Type --
@@ -2123,6 +2312,39 @@ package body Sem_Ch5 is
Analyze (Decl);
Rewrite (Subt, New_Occurrence_Of (S, Sloc (Subt)));
end;
+
+ -- Ada 2022: the subtype definition may be for an anonymous
+ -- access type.
+
+ elsif Nkind (Subt) = N_Access_Definition then
+ declare
+ S : constant Entity_Id := Make_Temporary (Sloc (Subt), 'S');
+ Decl : Node_Id;
+ begin
+ if Present (Subtype_Mark (Subt)) then
+ Decl :=
+ Make_Full_Type_Declaration (Loc,
+ Defining_Identifier => S,
+ Type_Definition =>
+ Make_Access_To_Object_Definition (Loc,
+ All_Present => True,
+ Subtype_Indication =>
+ New_Copy_Tree (Subtype_Mark (Subt))));
+
+ else
+ Decl :=
+ Make_Full_Type_Declaration (Loc,
+ Defining_Identifier => S,
+ Type_Definition =>
+ New_Copy_Tree
+ (Access_To_Subprogram_Definition (Subt)));
+ end if;
+
+ Insert_Before (Parent (Parent (N)), Decl);
+ Analyze (Decl);
+ Freeze_Before (First (Statements (Parent (Parent (N)))), S);
+ Rewrite (Subt, New_Occurrence_Of (S, Sloc (Subt)));
+ end;
else
Analyze (Subt);
end if;
@@ -2149,7 +2371,7 @@ package body Sem_Ch5 is
-- Set the kind of the loop variable, which is not visible within the
-- iterator name.
- Set_Ekind (Def_Id, E_Variable);
+ Mutate_Ekind (Def_Id, E_Variable);
-- Provide a link between the iterator variable and the container, for
-- subsequent use in cross-reference and modification information.
@@ -2360,7 +2582,7 @@ package body Sem_Ch5 is
-- Domain of iteration is not overloaded
else
- Resolve (Iter_Name, Etype (Iter_Name));
+ Resolve (Iter_Name);
end if;
if not Of_Present (N) then
@@ -2400,7 +2622,7 @@ package body Sem_Ch5 is
& "component of a mutable object", N);
end if;
- Check_Subtype_Indication (Component_Type (Typ));
+ Check_Subtype_Definition (Component_Type (Typ));
-- Here we have a missing Range attribute
@@ -2418,7 +2640,7 @@ package body Sem_Ch5 is
-- Prevent cascaded errors
- Set_Ekind (Def_Id, E_Loop_Parameter);
+ Mutate_Ekind (Def_Id, E_Loop_Parameter);
Set_Etype (Def_Id, Etype (First_Index (Typ)));
end if;
@@ -2430,7 +2652,7 @@ package body Sem_Ch5 is
-- Iteration over a container
else
- Set_Ekind (Def_Id, E_Loop_Parameter);
+ Mutate_Ekind (Def_Id, E_Loop_Parameter);
Error_Msg_Ada_2012_Feature ("container iterator", Sloc (N));
-- OF present
@@ -2450,7 +2672,7 @@ package body Sem_Ch5 is
end if;
end;
- Check_Subtype_Indication (Etype (Def_Id));
+ Check_Subtype_Definition (Etype (Def_Id));
-- For a predefined container, the type of the loop variable is
-- the Iterator_Element aspect of the container type.
@@ -2477,13 +2699,13 @@ package body Sem_Ch5 is
Cursor_Type := Get_Cursor_Type (Typ);
pragma Assert (Present (Cursor_Type));
- Check_Subtype_Indication (Etype (Def_Id));
+ Check_Subtype_Definition (Etype (Def_Id));
-- If the container has a variable indexing aspect, the
-- element is a variable and is modifiable in the loop.
if Has_Aspect (Typ, Aspect_Variable_Indexing) then
- Set_Ekind (Def_Id, E_Variable);
+ Mutate_Ekind (Def_Id, E_Variable);
end if;
-- If the container is a constant, iterating over it
@@ -2654,7 +2876,7 @@ package body Sem_Ch5 is
procedure Analyze_Label_Entity (E : Entity_Id) is
begin
- Set_Ekind (E, E_Label);
+ Mutate_Ekind (E, E_Label);
Set_Etype (E, Standard_Void_Type);
Set_Enclosing_Scope (E, Current_Scope);
Set_Reachable (E, True);
@@ -3040,7 +3262,7 @@ package body Sem_Ch5 is
-- subsequent analysis of the condition in a quantified
-- expression.
- Set_Ekind (Id, E_Loop_Parameter);
+ Mutate_Ekind (Id, E_Loop_Parameter);
return;
end;
@@ -3103,7 +3325,7 @@ package body Sem_Ch5 is
Make_Index (DS, N);
end if;
- Set_Ekind (Id, E_Loop_Parameter);
+ Mutate_Ekind (Id, E_Loop_Parameter);
-- A quantified expression which appears in a pre- or post-condition may
-- be analyzed multiple times. The analysis of the range creates several
@@ -3298,6 +3520,32 @@ package body Sem_Ch5 is
("\loop executes zero times or raises "
& "Constraint_Error??", Bad_Bound);
end if;
+
+ if Compile_Time_Compare (LLo, LHi, Assume_Valid => False)
+ = GT
+ then
+ Error_Msg_N ("??constrained range is null",
+ Constraint (DS));
+
+ -- Additional constraints on modular types can be
+ -- confusing, add more information.
+
+ if Ekind (Etype (DS)) = E_Modular_Integer_Subtype then
+ Error_Msg_Uint_1 := Intval (LLo);
+ Error_Msg_Uint_2 := Intval (LHi);
+ Error_Msg_NE ("\iterator has modular type &, " &
+ "so the loop has bounds ^ ..^",
+ Constraint (DS),
+ Subtype_Mark (DS));
+ end if;
+
+ Set_Is_Null_Loop (Loop_Nod);
+ Null_Range := True;
+
+ -- Suppress other warnigns about the body of the loop, as
+ -- it will never execute.
+ Set_Suppress_Loop_Warnings (Loop_Nod);
+ end if;
end;
end if;
@@ -3731,7 +3979,7 @@ package body Sem_Ch5 is
and then Ekind (Homonym (Ent)) = E_Label
then
Set_Entity (Id, Ent);
- Set_Ekind (Ent, E_Loop);
+ Mutate_Ekind (Ent, E_Loop);
end if;
else
@@ -3745,7 +3993,8 @@ package body Sem_Ch5 is
-- parser for generic units.
if Ekind (Ent) = E_Label then
- Set_Ekind (Ent, E_Loop);
+ Reinit_Field_To_Zero (Ent, F_Enclosing_Scope);
+ Mutate_Ekind (Ent, E_Loop);
if Nkind (Parent (Ent)) = N_Implicit_Label_Declaration then
Set_Label_Construct (Parent (Ent), N);
@@ -3909,7 +4158,7 @@ package body Sem_Ch5 is
if not Of_Present (I_Spec)
or else not Is_Variable (Name (I_Spec))
then
- Set_Ekind (Id, E_Loop_Parameter);
+ Mutate_Ekind (Id, E_Loop_Parameter);
end if;
end;
@@ -3984,11 +4233,67 @@ package body Sem_Ch5 is
-------------------------
procedure Analyze_Target_Name (N : Node_Id) is
+ procedure Report_Error;
+ -- Complain about illegal use of target_name and rewrite it into unknown
+ -- identifier.
+
+ ------------------
+ -- Report_Error --
+ ------------------
+
+ procedure Report_Error is
+ begin
+ Error_Msg_N
+ ("must appear in the right-hand side of an assignment statement",
+ N);
+ Rewrite (N, New_Occurrence_Of (Any_Id, Sloc (N)));
+ end Report_Error;
+
+ -- Start of processing for Analyze_Target_Name
+
begin
-- A target name has the type of the left-hand side of the enclosing
-- assignment.
- Set_Etype (N, Etype (Name (Current_Assignment)));
+ -- First, verify that the context is the right-hand side of an
+ -- assignment statement.
+
+ if No (Current_Assignment) then
+ Report_Error;
+ return;
+ end if;
+
+ declare
+ Current : Node_Id := N;
+ Context : Node_Id := Parent (N);
+ begin
+ while Present (Context) loop
+
+ -- Check if target_name appears in the expression of the enclosing
+ -- assignment.
+
+ if Nkind (Context) = N_Assignment_Statement then
+ if Current = Expression (Context) then
+ pragma Assert (Context = Current_Assignment);
+ Set_Etype (N, Etype (Name (Current_Assignment)));
+ else
+ Report_Error;
+ end if;
+ return;
+
+ -- Prevent the search from going too far
+
+ elsif Is_Body_Or_Package_Declaration (Context) then
+ Report_Error;
+ return;
+ end if;
+
+ Current := Context;
+ Context := Parent (Context);
+ end loop;
+
+ Report_Error;
+ end;
end Analyze_Target_Name;
------------------------
@@ -4337,8 +4642,8 @@ package body Sem_Ch5 is
Error_Msg_N
("ambiguous bounds in range of iteration", R_Copy);
Error_Msg_N ("\possible interpretations:", R_Copy);
- Error_Msg_NE ("\\} ", R_Copy, Found);
- Error_Msg_NE ("\\} ", R_Copy, It.Typ);
+ Error_Msg_NE ("\\}", R_Copy, Found);
+ Error_Msg_NE ("\\}", R_Copy, It.Typ);
exit;
end if;
end if;
diff --git a/gcc/ada/sem_ch5.ads b/gcc/ada/sem_ch5.ads
index 55200e4..c320665 100644
--- a/gcc/ada/sem_ch5.ads
+++ b/gcc/ada/sem_ch5.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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,6 +33,7 @@ package Sem_Ch5 is
procedure Analyze_Compound_Statement (N : Node_Id);
procedure Analyze_Exit_Statement (N : Node_Id);
procedure Analyze_Goto_Statement (N : Node_Id);
+ procedure Analyze_Goto_When_Statement (N : Node_Id);
procedure Analyze_If_Statement (N : Node_Id);
procedure Analyze_Implicit_Label_Declaration (N : Node_Id);
procedure Analyze_Iterator_Specification (N : Node_Id);
diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb
index 7bab772..304dc19 100644
--- a/gcc/ada/sem_ch6.adb
+++ b/gcc/ada/sem_ch6.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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,70 +23,73 @@
-- --
------------------------------------------------------------------------------
-with Aspects; use Aspects;
-with Atree; use Atree;
-with Checks; use Checks;
-with Contracts; use Contracts;
-with Debug; use Debug;
-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;
-with Exp_Dbug; use Exp_Dbug;
-with Exp_Tss; use Exp_Tss;
-with Exp_Util; use Exp_Util;
-with Freeze; use Freeze;
-with Ghost; use Ghost;
-with Inline; use Inline;
-with Itypes; use Itypes;
-with Lib.Xref; use Lib.Xref;
-with Layout; use Layout;
-with Namet; use Namet;
-with Lib; use Lib;
-with Nlists; use Nlists;
-with Nmake; use Nmake;
-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;
-with Sem_Cat; use Sem_Cat;
-with Sem_Ch3; use Sem_Ch3;
-with Sem_Ch4; use Sem_Ch4;
-with Sem_Ch5; use Sem_Ch5;
-with Sem_Ch8; use Sem_Ch8;
-with Sem_Ch9; use Sem_Ch9;
-with Sem_Ch10; use Sem_Ch10;
-with Sem_Ch12; use Sem_Ch12;
-with Sem_Ch13; use Sem_Ch13;
-with Sem_Dim; use Sem_Dim;
-with Sem_Disp; use Sem_Disp;
-with Sem_Dist; use Sem_Dist;
-with Sem_Elim; use Sem_Elim;
-with Sem_Eval; use Sem_Eval;
-with Sem_Mech; use Sem_Mech;
-with Sem_Prag; use Sem_Prag;
-with Sem_Res; use Sem_Res;
-with Sem_Util; use Sem_Util;
-with Sem_Type; use Sem_Type;
-with Sem_Warn; use Sem_Warn;
-with Sinput; use Sinput;
-with Stand; use Stand;
-with Sinfo; use Sinfo;
-with Sinfo.CN; use Sinfo.CN;
-with Snames; use Snames;
-with Stringt; use Stringt;
+with Aspects; use Aspects;
+with Atree; use Atree;
+with Checks; use Checks;
+with Contracts; use Contracts;
+with Debug; use Debug;
+with Einfo; use Einfo;
+with Einfo.Entities; use Einfo.Entities;
+with Einfo.Utils; use Einfo.Utils;
+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_Ch9; use Exp_Ch9;
+with Exp_Dbug; use Exp_Dbug;
+with Exp_Tss; use Exp_Tss;
+with Exp_Util; use Exp_Util;
+with Freeze; use Freeze;
+with Ghost; use Ghost;
+with Inline; use Inline;
+with Itypes; use Itypes;
+with Lib.Xref; use Lib.Xref;
+with Layout; use Layout;
+with Namet; use Namet;
+with Lib; use Lib;
+with Nlists; use Nlists;
+with Nmake; use Nmake;
+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;
+with Sem_Cat; use Sem_Cat;
+with Sem_Ch3; use Sem_Ch3;
+with Sem_Ch4; use Sem_Ch4;
+with Sem_Ch5; use Sem_Ch5;
+with Sem_Ch8; use Sem_Ch8;
+with Sem_Ch9; use Sem_Ch9;
+with Sem_Ch10; use Sem_Ch10;
+with Sem_Ch12; use Sem_Ch12;
+with Sem_Ch13; use Sem_Ch13;
+with Sem_Dim; use Sem_Dim;
+with Sem_Disp; use Sem_Disp;
+with Sem_Dist; use Sem_Dist;
+with Sem_Elim; use Sem_Elim;
+with Sem_Eval; use Sem_Eval;
+with Sem_Mech; use Sem_Mech;
+with Sem_Prag; use Sem_Prag;
+with Sem_Res; use Sem_Res;
+with Sem_Util; use Sem_Util;
+with Sem_Type; use Sem_Type;
+with Sem_Warn; use Sem_Warn;
+with Sinput; use Sinput;
+with Stand; use Stand;
+with Sinfo; use Sinfo;
+with Sinfo.Nodes; use Sinfo.Nodes;
+with Sinfo.Utils; use Sinfo.Utils;
+with Sinfo.CN; use Sinfo.CN;
+with Snames; use Snames;
+with Stringt; use Stringt;
with Style;
-with Stylesw; use Stylesw;
-with Tbuild; use Tbuild;
-with Uintp; use Uintp;
-with Urealp; use Urealp;
-with Validsw; use Validsw;
+with Stylesw; use Stylesw;
+with Tbuild; use Tbuild;
+with Uintp; use Uintp;
+with Urealp; use Urealp;
+with Validsw; use Validsw;
package body Sem_Ch6 is
@@ -128,9 +131,6 @@ package body Sem_Ch6 is
-- Does all the real work of Analyze_Subprogram_Body. This is split out so
-- that we can use RETURN but not skip the debug output at the end.
- function Can_Override_Operator (Subp : Entity_Id) return Boolean;
- -- Returns true if Subp can override a predefined operator.
-
procedure Check_Conformance
(New_Id : Entity_Id;
Old_Id : Entity_Id;
@@ -298,8 +298,9 @@ package body Sem_Ch6 is
Asp : Node_Id;
New_Body : Node_Id;
New_Spec : Node_Id;
- Orig_N : Node_Id;
+ Orig_N : Node_Id := Empty;
Ret : Node_Id;
+ Typ : Entity_Id := Empty;
Def_Id : Entity_Id := Empty;
Prev : Entity_Id;
@@ -333,6 +334,8 @@ package body Sem_Ch6 is
Def_Id := Analyze_Subprogram_Specification (Spec);
Prev := Find_Corresponding_Spec (N);
+ Typ := Etype (Def_Id);
+
-- The previous entity may be an expression function as well, in
-- which case the redeclaration is illegal.
@@ -406,7 +409,7 @@ package body Sem_Ch6 is
if not Inside_A_Generic then
Freeze_Expr_Types
(Def_Id => Def_Id,
- Typ => Etype (Def_Id),
+ Typ => Typ,
Expr => Expr,
N => N);
end if;
@@ -496,6 +499,8 @@ package body Sem_Ch6 is
Def_Id := Defining_Entity (N);
Set_Is_Inlined (Def_Id);
+ Typ := Etype (Def_Id);
+
-- Establish the linkages between the spec and the body. These are
-- used when the expression function acts as the prefix of attribute
-- 'Access in order to freeze the original expression which has been
@@ -517,107 +522,99 @@ package body Sem_Ch6 is
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));
+ Preanalyze_Spec_Expression (Expr, Typ);
+ End_Scope;
+ else
+ Push_Scope (Def_Id);
+ Install_Formals (Def_Id);
+ Preanalyze_Formal_Expression (Expr, Typ);
+ Check_Limited_Return (Orig_N, Expr, Typ);
End_Scope;
end if;
+ -- If this is a wrapper created in an instance for a formal
+ -- subprogram, insert body after declaration, to be analyzed when the
+ -- enclosing instance is analyzed.
+
+ if GNATprove_Mode
+ and then Is_Generic_Actual_Subprogram (Def_Id)
+ then
+ Insert_After (N, New_Body);
+
-- To prevent premature freeze action, insert the new body at the end
-- of the current declarations, or at the end of the package spec.
-- However, resolve usage names now, to prevent spurious visibility
-- on later entities. Note that the function can now be called in
- -- the current declarative part, which will appear to be prior to
- -- the presence of the body in the code. There are nevertheless no
- -- order of elaboration issues because all name resolution has taken
- -- place at the point of declaration.
-
- declare
- Decls : List_Id := List_Containing (N);
- Expr : constant Node_Id := Expression (Ret);
- Par : constant Node_Id := Parent (Decls);
- Typ : constant Entity_Id := Etype (Def_Id);
-
- begin
- -- If this is a wrapper created for in an instance for a formal
- -- subprogram, insert body after declaration, to be analyzed when
- -- the enclosing instance is analyzed.
+ -- the current declarative part, which will appear to be prior to the
+ -- presence of the body in the code. There are nevertheless no order
+ -- of elaboration issues because all name resolution has taken place
+ -- at the point of declaration.
- if GNATprove_Mode
- and then Is_Generic_Actual_Subprogram (Def_Id)
- then
- Insert_After (N, New_Body);
+ else
+ declare
+ Decls : List_Id := List_Containing (N);
+ Par : constant Node_Id := Parent (Decls);
- else
+ begin
if Nkind (Par) = N_Package_Specification
and then Decls = Visible_Declarations (Par)
- and then Present (Private_Declarations (Par))
and then not Is_Empty_List (Private_Declarations (Par))
then
Decls := Private_Declarations (Par);
end if;
Insert_After (Last (Decls), New_Body);
+ end;
+ end if;
- -- Preanalyze the expression if not already done above
-
- if not Inside_A_Generic then
- Push_Scope (Def_Id);
- Install_Formals (Def_Id);
- Preanalyze_Formal_Expression (Expr, Typ);
- 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);
+ -- 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 2022
+ -- RM in 4.9(3.2/5-3.4/5) and we flag an error.
- Preanalyze_Formal_Expression (Exp_Copy, Typ);
+ 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);
- if not Is_Static_Expression (Exp_Copy) then
- Error_Msg_N
- ("static expression function requires "
- & "potentially static expression", Expr);
- end if;
+ Preanalyze_Formal_Expression (Exp_Copy, Typ);
- Set_Checking_Potentially_Static_Expression (False);
- end;
+ if not Is_Static_Expression (Exp_Copy) then
+ Error_Msg_N
+ ("static expression function requires "
+ & "potentially static expression", Expr);
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_Checking_Potentially_Static_Expression (False);
+ end;
+ end if;
- Set_Expression
- (Original_Node (Subprogram_Spec (Def_Id)),
- New_Copy_Tree (Expr));
+ -- 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.
- -- Mark static expression functions as inlined, to ensure
- -- that even calls with nonstatic actuals will be inlined.
+ Set_Expression
+ (Original_Node (Subprogram_Spec (Def_Id)),
+ New_Copy_Tree (Expr));
- Set_Has_Pragma_Inline (Def_Id);
- Set_Is_Inlined (Def_Id);
- end if;
- end if;
- end;
+ -- Mark static expression functions as inlined, to ensure
+ -- that even calls with nonstatic actuals will be inlined.
+
+ Set_Has_Pragma_Inline (Def_Id);
+ Set_Is_Inlined (Def_Id);
+ end if;
end if;
-- Check incorrect use of dynamically tagged expression. This doesn't
@@ -626,13 +623,12 @@ package body Sem_Ch6 is
-- nodes that don't come from source.
if Present (Def_Id)
- and then Nkind (Def_Id) in N_Has_Etype
- and then Is_Tagged_Type (Etype (Def_Id))
+ and then Is_Tagged_Type (Typ)
then
Check_Dynamically_Tagged_Expression
(Expr => Expr,
- Typ => Etype (Def_Id),
- Related_Nod => Original_Node (N));
+ Typ => Typ,
+ Related_Nod => Orig_N);
end if;
-- We must enforce checks for unreferenced formals in our newly
@@ -642,9 +638,9 @@ package body Sem_Ch6 is
if Present (Parameter_Specifications (New_Spec)) then
declare
Form_New_Def : Entity_Id;
- Form_New_Spec : Entity_Id;
+ Form_New_Spec : Node_Id;
Form_Old_Def : Entity_Id;
- Form_Old_Spec : Entity_Id;
+ Form_Old_Spec : Node_Id;
begin
Form_New_Spec := First (Parameter_Specifications (New_Spec));
@@ -740,7 +736,7 @@ package body Sem_Ch6 is
-- Function result subtype
procedure Check_No_Return_Expression (Return_Expr : Node_Id);
- -- Ada 2020: Check that the return expression in a No_Return function
+ -- Ada 2022: 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);
@@ -1446,13 +1442,13 @@ package body Sem_Ch6 is
Check_Return_Construct_Accessibility (N);
- -- Ada 2020 (AI12-0269): Any return statement that applies to a
+ -- Ada 2022 (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 Ada_Version >= Ada_2020
+ if Ada_Version >= Ada_2022
and then No_Return (Scope_Id)
and then Comes_From_Source (N)
then
@@ -1531,14 +1527,12 @@ package body Sem_Ch6 is
-- Check RM 6.5 (5.9/3)
if Has_Aliased then
- if Ada_Version < Ada_2012 then
-
- -- Shouldn't this test Warn_On_Ada_2012_Compatibility ???
- -- Can it really happen (extended return???)
-
+ if Ada_Version < Ada_2012
+ and then Warn_On_Ada_2012_Compatibility
+ then
Error_Msg_N
("ALIASED only allowed for limited return objects "
- & "in Ada 2012??", N);
+ & "in Ada 2012?y?", N);
elsif not Is_Limited_View (R_Type) then
Error_Msg_N
@@ -1546,10 +1540,10 @@ package body Sem_Ch6 is
end if;
end if;
- -- Ada 2020 (AI12-0269): Any return statement that applies to a
+ -- Ada 2022 (AI12-0269): Any return statement that applies to a
-- nonreturning function shall be a simple_return_statement.
- if Ada_Version >= Ada_2020
+ if Ada_Version >= Ada_2022
and then No_Return (Scope_Id)
and then Comes_From_Source (N)
then
@@ -1670,9 +1664,9 @@ package body Sem_Ch6 is
Related_Nod => N);
end if;
- -- ??? A real run-time accessibility check is needed in cases
- -- involving dereferences of access parameters. For now we just
- -- check the static cases.
+ -- Perform static accessibility checks for cases involving
+ -- dereferences of access parameters. Runtime accessibility checks
+ -- get generated elsewhere.
if (Ada_Version < Ada_2005 or else Debug_Flag_Dot_L)
and then Is_Limited_View (Etype (Scope_Id))
@@ -1770,13 +1764,13 @@ package body Sem_Ch6 is
if Kind = E_Generic_Procedure
and then Nkind (Spec) /= N_Procedure_Specification
then
- Error_Msg_N ("invalid body for generic procedure ", Body_Id);
+ Error_Msg_N ("invalid body for generic procedure", Body_Id);
return;
elsif Kind = E_Generic_Function
and then Nkind (Spec) /= N_Function_Specification
then
- Error_Msg_N ("invalid body for generic function ", Body_Id);
+ Error_Msg_N ("invalid body for generic function", Body_Id);
return;
end if;
@@ -1792,7 +1786,7 @@ package body Sem_Ch6 is
end if;
if Nkind (N) = N_Subprogram_Body_Stub then
- Set_Ekind (Defining_Entity (Specification (N)), Kind);
+ Mutate_Ekind (Defining_Entity (Specification (N)), Kind);
else
Set_Corresponding_Spec (N, Gen_Id);
end if;
@@ -1843,8 +1837,13 @@ package body Sem_Ch6 is
-- Visible generic entity is callable within its own body
- Set_Ekind (Gen_Id, Ekind (Body_Id));
- Set_Ekind (Body_Id, E_Subprogram_Body);
+ Mutate_Ekind (Gen_Id, Ekind (Body_Id));
+ Reinit_Field_To_Zero (Body_Id, F_Has_Out_Or_In_Out_Parameter,
+ Old_Ekind =>
+ (E_Function | E_Procedure |
+ E_Generic_Function | E_Generic_Procedure => True,
+ others => False));
+ Mutate_Ekind (Body_Id, E_Subprogram_Body);
Set_Convention (Body_Id, Convention (Gen_Id));
Set_Is_Obsolescent (Body_Id, Is_Obsolescent (Gen_Id));
Set_Scope (Body_Id, Scope (Gen_Id));
@@ -1855,8 +1854,8 @@ package body Sem_Ch6 is
-- No body to analyze, so restore state of generic unit
- Set_Ekind (Gen_Id, Kind);
- Set_Ekind (Body_Id, Kind);
+ Mutate_Ekind (Gen_Id, Kind);
+ Mutate_Ekind (Body_Id, Kind);
if Present (First_Ent) then
Set_First_Entity (Gen_Id, First_Ent);
@@ -1920,7 +1919,9 @@ package body Sem_Ch6 is
-- Outside of its body, unit is generic again
- Set_Ekind (Gen_Id, Kind);
+ Reinit_Field_To_Zero (Gen_Id, F_Has_Nested_Subprogram,
+ Old_Ekind => (E_Function | E_Procedure => True, others => False));
+ Mutate_Ekind (Gen_Id, Kind);
Generate_Reference (Gen_Id, Body_Id, 'b', Set_Ref => False);
if Style_Check then
@@ -2015,7 +2016,7 @@ package body Sem_Ch6 is
if Present (Prev) and then Is_Generic_Subprogram (Prev) then
Insert_Before (N, Null_Body);
- Set_Ekind (Defining_Entity (N), Ekind (Prev));
+ Mutate_Ekind (Defining_Entity (N), Ekind (Prev));
Rewrite (N, Make_Null_Statement (Loc));
Analyze_Generic_Subprogram_Body (Null_Body, Prev);
@@ -2328,7 +2329,7 @@ package body Sem_Ch6 is
if Present (Actuals) then
Analyze_Call_And_Resolve;
else
- Error_Msg_N ("missing explicit dereference in call ", N);
+ Error_Msg_N ("missing explicit dereference in call", N);
end if;
-- If not an access to subprogram, then the prefix must resolve to the
@@ -2605,6 +2606,18 @@ package body Sem_Ch6 is
Analyze_Dimension (N);
end Analyze_Return_Statement;
+ -----------------------------------
+ -- Analyze_Return_When_Statement --
+ -----------------------------------
+
+ procedure Analyze_Return_When_Statement (N : Node_Id) is
+ begin
+ -- Verify the condition is a Boolean expression
+
+ Analyze_And_Resolve (Condition (N), Any_Boolean);
+ Check_Unset_Reference (Condition (N));
+ end Analyze_Return_When_Statement;
+
-------------------------------------
-- Analyze_Simple_Return_Statement --
-------------------------------------
@@ -3416,15 +3429,13 @@ package body Sem_Ch6 is
Prag := Empty;
end if;
- if Present (Prag) then
+ if Present (Prag) and then Is_List_Member (N) then
if Present (Spec_Id) then
- if Is_List_Member (N)
- and then Is_List_Member (Unit_Declaration_Node (Spec_Id))
+ if Is_List_Member (Unit_Declaration_Node (Spec_Id))
and then In_Same_List (N, Unit_Declaration_Node (Spec_Id))
then
Analyze (Prag);
end if;
-
else
-- Create a subprogram declaration, to make treatment uniform.
-- Make the sloc of the subprogram name that of the entity in
@@ -3443,7 +3454,12 @@ package body Sem_Ch6 is
-- Link the body and the generated spec
Set_Corresponding_Body (Decl, Body_Id);
- Set_Corresponding_Spec (N, Subp);
+
+ if Nkind (N) = N_Subprogram_Body_Stub then
+ Set_Corresponding_Spec_Of_Stub (N, Subp);
+ else
+ Set_Corresponding_Spec (N, Subp);
+ end if;
Set_Defining_Unit_Name (Specification (Decl), Subp);
@@ -3818,7 +3834,8 @@ package body Sem_Ch6 is
Result : Elist_Id := No_Elist;
function Mask_Type_Refs (Node : Node_Id) return Traverse_Result;
- -- Mask all types referenced in the subtree rooted at Node
+ -- Mask all types referenced in the subtree rooted at Node as
+ -- formally frozen.
--------------------
-- Mask_Type_Refs --
@@ -3826,7 +3843,8 @@ package body Sem_Ch6 is
function Mask_Type_Refs (Node : Node_Id) return Traverse_Result is
procedure Mask_Type (Typ : Entity_Id);
- -- ??? what does this do?
+ -- Mask a given type as formally frozen when outside the current
+ -- scope, or else freeze the type.
---------------
-- Mask_Type --
@@ -4061,7 +4079,7 @@ package body Sem_Ch6 is
and then Operator_Matches_Spec (Spec_Id, Spec_Id)
then
Error_Msg_NE
- ("subprogram& overrides predefined operator ",
+ ("subprogram& overrides predefined operator",
Body_Spec, Spec_Id);
-- Overriding indicators aren't allowed for protected subprogram
@@ -4568,6 +4586,17 @@ package body Sem_Ch6 is
then
Conformant := True;
+ -- Finally, a body generated for an expression function copies
+ -- the profile of the function and no check is needed either.
+ -- If the body is the completion of a previous function
+ -- declared elsewhere, the conformance check is required.
+
+ elsif Nkind (N) = N_Subprogram_Body
+ and then Was_Expression_Function (N)
+ and then Sloc (Spec_Id) = Sloc (Body_Id)
+ then
+ Conformant := True;
+
else
Check_Conformance
(Body_Id, Spec_Id,
@@ -4601,7 +4630,19 @@ package body Sem_Ch6 is
Reference_Body_Formals (Spec_Id, Body_Id);
end if;
- Set_Ekind (Body_Id, E_Subprogram_Body);
+ Reinit_Field_To_Zero (Body_Id, F_Has_Out_Or_In_Out_Parameter);
+ Reinit_Field_To_Zero (Body_Id, F_Needs_No_Actuals,
+ Old_Ekind => (E_Function | E_Procedure => True, others => False));
+ Reinit_Field_To_Zero (Body_Id, F_Is_Predicate_Function,
+ Old_Ekind => (E_Function | E_Procedure => True, others => False));
+ Reinit_Field_To_Zero (Body_Id, F_Protected_Subprogram,
+ Old_Ekind => (E_Function | E_Procedure => True, others => False));
+
+ if Ekind (Body_Id) = E_Procedure then
+ Reinit_Field_To_Zero (Body_Id, F_Receiving_Entry);
+ end if;
+
+ Mutate_Ekind (Body_Id, E_Subprogram_Body);
if Nkind (N) = N_Subprogram_Body_Stub then
Set_Corresponding_Spec_Of_Stub (N, Spec_Id);
@@ -5644,17 +5685,6 @@ package body Sem_Ch6 is
end;
end if;
- -- What is the following code for, it used to be
-
- -- ??? Set_Suppress_Elaboration_Checks
- -- ??? (Designator, Elaboration_Checks_Suppressed (Designator));
-
- -- The following seems equivalent, but a bit dubious
-
- if Elaboration_Checks_Suppressed (Designator) then
- Set_Kill_Elaboration_Checks (Designator);
- end if;
-
-- For a compilation unit, set body required. This flag will only be
-- reset if a valid Import or Interface pragma is processed later on.
@@ -5766,10 +5796,10 @@ package body Sem_Ch6 is
end if;
if Nkind (N) = N_Function_Specification then
- Set_Ekind (Designator, E_Function);
+ Mutate_Ekind (Designator, E_Function);
Set_Mechanism (Designator, Default_Mechanism);
else
- Set_Ekind (Designator, E_Procedure);
+ Mutate_Ekind (Designator, E_Procedure);
Set_Etype (Designator, Standard_Void_Type);
end if;
@@ -6255,7 +6285,9 @@ package body Sem_Ch6 is
-- Null exclusion must match
- if not Null_Exclusions_Match (Old_Formal, New_Formal) then
+ if not Relaxed_RM_Semantics
+ and then not Null_Exclusions_Match (Old_Formal, New_Formal)
+ then
Conformance_Error
("\null exclusion for& does not match", New_Formal);
@@ -6727,18 +6759,7 @@ package body Sem_Ch6 is
-- may not be known yet (for private types).
if not Has_Delayed_Freeze (Designator) and then Expander_Active then
- declare
- Typ : constant Entity_Id := Etype (Designator);
- Utyp : constant Entity_Id := Underlying_Type (Typ);
-
- begin
- if Is_Limited_View (Typ) then
- Set_Returns_By_Ref (Designator);
-
- elsif Present (Utyp) and then CW_Or_Has_Controlled_Part (Utyp) then
- Set_Returns_By_Ref (Designator);
- end if;
- end;
+ Compute_Returns_By_Ref (Designator);
end if;
end Check_Delayed_Subprogram;
@@ -6990,16 +7011,14 @@ package body Sem_Ch6 is
-- A limited interface that is not immutably limited is OK
if Is_Limited_Interface (R_Type)
- and then
- not (Is_Task_Interface (R_Type)
- or else Is_Protected_Interface (R_Type)
- or else Is_Synchronized_Interface (R_Type))
+ and then not Is_Concurrent_Interface (R_Type)
then
null;
elsif Is_Limited_Type (R_Type)
and then not Is_Interface (R_Type)
- and then Comes_From_Source (N)
+ and then not (Nkind (N) = N_Simple_Return_Statement
+ and then Comes_From_Extended_Return_Statement (N))
and then not In_Instance_Body
and then not OK_For_Limited_Init_In_05 (R_Type, Expr)
then
@@ -7261,10 +7280,14 @@ package body Sem_Ch6 is
then
Set_Overridden_Operation (Subp, Alias (Overridden_Subp));
Inherit_Subprogram_Contract (Subp, Alias (Overridden_Subp));
+ Set_Is_Ada_2022_Only (Subp,
+ Is_Ada_2022_Only (Alias (Overridden_Subp)));
else
Set_Overridden_Operation (Subp, Overridden_Subp);
Inherit_Subprogram_Contract (Subp, Overridden_Subp);
+ Set_Is_Ada_2022_Only (Subp,
+ Is_Ada_2022_Only (Overridden_Subp));
end if;
end if;
end if;
@@ -7293,7 +7316,7 @@ package body Sem_Ch6 is
-- predefined signature, because we know already that there is no
-- explicit overridden operation.
- elsif Nkind (Subp) = N_Defining_Operator_Symbol then
+ elsif Chars (Subp) in Any_Operator_Name then
if Must_Not_Override (Spec) then
-- If this is not a primitive or a protected subprogram, then
@@ -7307,7 +7330,7 @@ package body Sem_Ch6 is
elsif Can_Override_Operator (Subp) then
Error_Msg_NE
- ("subprogram& overrides predefined operator ", Spec, Subp);
+ ("subprogram& overrides predefined operator", Spec, Subp);
end if;
elsif Must_Override (Spec) then
@@ -8285,7 +8308,12 @@ package body Sem_Ch6 is
Typ : Entity_Id;
begin
- if Nkind (Subp) /= N_Defining_Operator_Symbol then
+ -- Return False if not an operator. We test the name rather than testing
+ -- that the Nkind is N_Defining_Operator_Symbol, because there are cases
+ -- where an operator entity can be an N_Defining_Identifier (such as for
+ -- function instantiations).
+
+ if Chars (Subp) not in Any_Operator_Name then
return False;
else
@@ -8775,7 +8803,7 @@ package body Sem_Ch6 is
return Empty;
end if;
- Set_Ekind (EF, E_In_Parameter);
+ Mutate_Ekind (EF, E_In_Parameter);
Set_Actual_Subtype (EF, Typ);
Set_Etype (EF, Typ);
Set_Scope (EF, Scope);
@@ -8874,7 +8902,7 @@ package body Sem_Ch6 is
end if;
if not Has_Discriminants (Formal_Type)
- and then Ekind (Formal_Type) in Private_Kind
+ and then Is_Private_Type (Formal_Type)
and then Present (Underlying_Type (Formal_Type))
then
Formal_Type := Underlying_Type (Formal_Type);
@@ -9021,7 +9049,7 @@ package body Sem_Ch6 is
if Needs_BIP_Task_Actuals (E) then
Discard :=
Add_Extra_Formal
- (E, RTE (RE_Master_Id),
+ (E, Standard_Integer,
E, BIP_Formal_Suffix (BIP_Task_Master));
Set_Has_Master_Entity (E);
@@ -10713,8 +10741,8 @@ package body Sem_Ch6 is
exit;
end if;
- Next_Entity (P_Formal);
- Next_Entity (N_Formal);
+ Next_Formal (P_Formal);
+ Next_Formal (N_Formal);
end loop;
-- Found a matching primitive operation belonging to the
@@ -10991,9 +11019,11 @@ package body Sem_Ch6 is
(Is_Primitive : out Boolean;
Is_Overriding : Boolean := False)
is
- Formal : Entity_Id;
- F_Typ : Entity_Id;
- B_Typ : Entity_Id;
+ procedure Add_Or_Replace_Untagged_Primitive (Typ : Entity_Id);
+ -- Either add the new subprogram to the list of primitives for
+ -- untagged type Typ, or if it overrides a primitive of Typ, then
+ -- replace the overridden primitive in Typ's primitives list with
+ -- the new subprogram.
function Visible_Part_Type (T : Entity_Id) return Boolean;
-- Returns true if T is declared in the visible part of the current
@@ -11008,6 +11038,63 @@ package body Sem_Ch6 is
-- in a private part, then it must override a function declared in
-- the visible part.
+ ---------------------------------------
+ -- Add_Or_Replace_Untagged_Primitive --
+ ---------------------------------------
+
+ procedure Add_Or_Replace_Untagged_Primitive (Typ : Entity_Id) is
+ Replaced_Overridden_Subp : Boolean := False;
+
+ begin
+ pragma Assert (not Is_Tagged_Type (Typ));
+
+ -- Anonymous access types don't have a primitives list. Normally
+ -- such types wouldn't make it here, but the case of anonymous
+ -- access-to-subprogram types can.
+
+ if not Is_Anonymous_Access_Type (Typ) then
+
+ -- If S overrides a subprogram that's a primitive of
+ -- the formal's type, then replace the overridden
+ -- subprogram with the new subprogram in the type's
+ -- list of primitives.
+
+ if Is_Overriding then
+ pragma Assert (Present (Overridden_Subp)
+ and then Overridden_Subp = E); -- Added for now
+
+ declare
+ Prim_Ops : constant Elist_Id :=
+ Primitive_Operations (Typ);
+ Elmt : Elmt_Id;
+ begin
+ if Present (Prim_Ops) then
+ Elmt := First_Elmt (Prim_Ops);
+
+ while Present (Elmt)
+ and then Node (Elmt) /= Overridden_Subp
+ loop
+ Next_Elmt (Elmt);
+ end loop;
+
+ if Present (Elmt) then
+ Replace_Elmt (Elmt, S);
+ Replaced_Overridden_Subp := True;
+ end if;
+ end if;
+ end;
+ end if;
+
+ -- If the new subprogram did not override an operation
+ -- of the formal's type, then add it to the primitives
+ -- list of the type.
+
+ if not Replaced_Overridden_Subp then
+ Append_Unique_Elmt (S, Primitive_Operations (Typ));
+ end if;
+ end if;
+ end Add_Or_Replace_Untagged_Primitive;
+
------------------------------
-- Check_Private_Overriding --
------------------------------
@@ -11163,7 +11250,7 @@ package body Sem_Ch6 is
-- If the entity is a private type, then it must be declared in a
-- visible part.
- if Ekind (T) in Private_Kind then
+ if Is_Private_Type (T) then
return True;
elsif Is_Type (T) and then Has_Private_Declaration (T) then
@@ -11180,13 +11267,29 @@ package body Sem_Ch6 is
end if;
end Visible_Part_Type;
+ -- Local variables
+
+ Formal : Entity_Id;
+ F_Typ : Entity_Id;
+ B_Typ : Entity_Id;
+
-- Start of processing for Check_For_Primitive_Subprogram
begin
Is_Primitive := False;
if not Comes_From_Source (S) then
- null;
+
+ -- Add an inherited primitive for an untagged derived type to
+ -- Derived_Type's list of primitives. Tagged primitives are dealt
+ -- with in Check_Dispatching_Operation.
+
+ if Present (Derived_Type)
+ and then Extensions_Allowed
+ and then not Is_Tagged_Type (Derived_Type)
+ then
+ Append_Unique_Elmt (S, Primitive_Operations (Derived_Type));
+ end if;
-- If subprogram is at library level, it is not primitive operation
@@ -11215,8 +11318,18 @@ package body Sem_Ch6 is
Is_Primitive := True;
Set_Has_Primitive_Operations (B_Typ);
Set_Is_Primitive (S);
- Check_Private_Overriding (B_Typ);
+ -- Add a primitive for an untagged type to B_Typ's list
+ -- of primitives. Tagged primitives are dealt with in
+ -- Check_Dispatching_Operation.
+
+ if Extensions_Allowed
+ and then not Is_Tagged_Type (B_Typ)
+ then
+ Add_Or_Replace_Untagged_Primitive (B_Typ);
+ end if;
+
+ Check_Private_Overriding (B_Typ);
-- The Ghost policy in effect at the point of declaration
-- or a tagged type and a primitive operation must match
-- (SPARK RM 6.9(16)).
@@ -11248,6 +11361,17 @@ package body Sem_Ch6 is
Is_Primitive := True;
Set_Is_Primitive (S);
Set_Has_Primitive_Operations (B_Typ);
+
+ -- Add a primitive for an untagged type to B_Typ's list
+ -- of primitives. Tagged primitives are dealt with in
+ -- Check_Dispatching_Operation.
+
+ if Extensions_Allowed
+ and then not Is_Tagged_Type (B_Typ)
+ then
+ Add_Or_Replace_Untagged_Primitive (B_Typ);
+ end if;
+
Check_Private_Overriding (B_Typ);
-- The Ghost policy in effect at the point of declaration
@@ -11681,7 +11805,7 @@ package body Sem_Ch6 is
if Inside_Freezing_Actions = 0
and then Is_Package_Or_Generic_Package (Current_Scope)
and then In_Private_Part (Current_Scope)
- and then Nkind (Parent (E)) = N_Private_Extension_Declaration
+ and then Parent_Kind (E) = N_Private_Extension_Declaration
and then Nkind (Parent (S)) = N_Full_Type_Declaration
and then Full_View (Defining_Identifier (Parent (E)))
= Defining_Identifier (Parent (S))
@@ -11878,10 +12002,13 @@ package body Sem_Ch6 is
if Present (Alias (S)) then
Set_Overridden_Operation (E, Alias (S));
Inherit_Subprogram_Contract (E, Alias (S));
+ Set_Is_Ada_2022_Only (E,
+ Is_Ada_2022_Only (Alias (S)));
else
Set_Overridden_Operation (E, S);
Inherit_Subprogram_Contract (E, S);
+ Set_Is_Ada_2022_Only (E, Is_Ada_2022_Only (S));
end if;
-- When a dispatching operation overrides an inherited
@@ -12048,6 +12175,8 @@ package body Sem_Ch6 is
then
Set_Overridden_Operation (S, Alias (E));
Inherit_Subprogram_Contract (S, Alias (E));
+ Set_Is_Ada_2022_Only (S,
+ Is_Ada_2022_Only (Alias (E)));
-- Normal case of setting entity as overridden
@@ -12059,8 +12188,22 @@ package body Sem_Ch6 is
-- must check whether the target is an init_proc.
elsif not Is_Init_Proc (S) then
- Set_Overridden_Operation (S, E);
- Inherit_Subprogram_Contract (S, E);
+
+ -- LSP wrappers must override the ultimate alias of their
+ -- wrapped dispatching primitive E; required to traverse
+ -- the chain of ancestor primitives (c.f. Map_Primitives)
+ -- They don't inherit contracts.
+
+ if Is_Wrapper (S)
+ and then Present (LSP_Subprogram (S))
+ then
+ Set_Overridden_Operation (S, Ultimate_Alias (E));
+ else
+ Set_Overridden_Operation (S, E);
+ Inherit_Subprogram_Contract (S, E);
+ end if;
+
+ Set_Is_Ada_2022_Only (S, Is_Ada_2022_Only (E));
end if;
Check_Overriding_Indicator (S, E, Is_Primitive => True);
@@ -12087,8 +12230,22 @@ package body Sem_Ch6 is
Is_Predefined_Dispatching_Operation (Alias (E)))
then
if Present (Alias (E)) then
- Set_Overridden_Operation (S, Alias (E));
- Inherit_Subprogram_Contract (S, Alias (E));
+
+ -- LSP wrappers must override the ultimate alias of
+ -- their wrapped dispatching primitive E; required to
+ -- traverse the chain of ancestor primitives (see
+ -- Map_Primitives). They don't inherit contracts.
+
+ if Is_Wrapper (S)
+ and then Present (LSP_Subprogram (S))
+ then
+ Set_Overridden_Operation (S, Ultimate_Alias (E));
+ else
+ Set_Overridden_Operation (S, Alias (E));
+ Inherit_Subprogram_Contract (S, Alias (E));
+ end if;
+
+ Set_Is_Ada_2022_Only (S, Is_Ada_2022_Only (Alias (E)));
end if;
end if;
@@ -12963,30 +13120,30 @@ package body Sem_Ch6 is
end if;
if In_Present (Spec) then
- Set_Ekind (Formal_Id, E_In_Out_Parameter);
+ Mutate_Ekind (Formal_Id, E_In_Out_Parameter);
else
- Set_Ekind (Formal_Id, E_Out_Parameter);
+ Mutate_Ekind (Formal_Id, E_Out_Parameter);
end if;
-- But not in earlier versions of Ada
else
Error_Msg_N ("functions can only have IN parameters", Spec);
- Set_Ekind (Formal_Id, E_In_Parameter);
+ Mutate_Ekind (Formal_Id, E_In_Parameter);
end if;
elsif In_Present (Spec) then
- Set_Ekind (Formal_Id, E_In_Out_Parameter);
+ Mutate_Ekind (Formal_Id, E_In_Out_Parameter);
else
- Set_Ekind (Formal_Id, E_Out_Parameter);
+ Mutate_Ekind (Formal_Id, E_Out_Parameter);
Set_Never_Set_In_Source (Formal_Id, True);
Set_Is_True_Constant (Formal_Id, False);
Set_Current_Value (Formal_Id, Empty);
end if;
else
- Set_Ekind (Formal_Id, E_In_Parameter);
+ Mutate_Ekind (Formal_Id, E_In_Parameter);
end if;
-- Set Is_Known_Non_Null for access parameters since the language
diff --git a/gcc/ada/sem_ch6.ads b/gcc/ada/sem_ch6.ads
index 81b4821..4afcf36 100644
--- a/gcc/ada/sem_ch6.ads
+++ b/gcc/ada/sem_ch6.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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,6 +41,7 @@ package Sem_Ch6 is
procedure Analyze_Operator_Symbol (N : Node_Id);
procedure Analyze_Parameter_Association (N : Node_Id);
procedure Analyze_Procedure_Call (N : Node_Id);
+ procedure Analyze_Return_When_Statement (N : Node_Id);
procedure Analyze_Simple_Return_Statement (N : Node_Id);
procedure Analyze_Subprogram_Declaration (N : Node_Id);
procedure Analyze_Subprogram_Body (N : Node_Id);
@@ -50,6 +51,9 @@ package Sem_Ch6 is
-- and body declarations. Returns the defining entity for the
-- specification N.
+ function Can_Override_Operator (Subp : Entity_Id) return Boolean;
+ -- Returns true if Subp can override a predefined operator
+
procedure Check_Conventions (Typ : Entity_Id);
-- Ada 2005 (AI-430): Check that the conventions of all inherited and
-- overridden dispatching operations of type Typ are consistent with their
diff --git a/gcc/ada/sem_ch7.adb b/gcc/ada/sem_ch7.adb
index 762f0c1..f30a9aa 100644
--- a/gcc/ada/sem_ch7.adb
+++ b/gcc/ada/sem_ch7.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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,47 +28,50 @@
-- handling of private and full declarations, and the construction of dispatch
-- tables for tagged types.
-with Aspects; use Aspects;
-with Atree; use Atree;
-with Contracts; use Contracts;
-with Debug; use Debug;
-with Einfo; use Einfo;
-with Elists; use Elists;
-with Errout; use Errout;
-with Exp_Disp; use Exp_Disp;
-with Exp_Dist; use Exp_Dist;
-with Exp_Dbug; use Exp_Dbug;
-with Freeze; use Freeze;
-with Ghost; use Ghost;
-with GNAT_CUDA; use GNAT_CUDA;
-with Lib; use Lib;
-with Lib.Xref; use Lib.Xref;
-with Namet; use Namet;
-with Nmake; use Nmake;
-with Nlists; use Nlists;
-with Opt; use Opt;
-with Output; use Output;
-with Rtsfind; use Rtsfind;
-with Sem; use Sem;
-with Sem_Aux; use Sem_Aux;
-with Sem_Cat; use Sem_Cat;
-with Sem_Ch3; use Sem_Ch3;
-with Sem_Ch6; use Sem_Ch6;
-with Sem_Ch8; use Sem_Ch8;
-with Sem_Ch10; use Sem_Ch10;
-with Sem_Ch12; use Sem_Ch12;
-with Sem_Ch13; use Sem_Ch13;
-with Sem_Disp; use Sem_Disp;
-with Sem_Eval; use Sem_Eval;
-with Sem_Prag; use Sem_Prag;
-with Sem_Util; use Sem_Util;
-with Sem_Warn; use Sem_Warn;
-with Snames; use Snames;
-with Stand; use Stand;
-with Sinfo; use Sinfo;
-with Sinput; use Sinput;
+with Aspects; use Aspects;
+with Atree; use Atree;
+with Contracts; use Contracts;
+with Debug; use Debug;
+with Einfo; use Einfo;
+with Einfo.Entities; use Einfo.Entities;
+with Einfo.Utils; use Einfo.Utils;
+with Elists; use Elists;
+with Errout; use Errout;
+with Exp_Disp; use Exp_Disp;
+with Exp_Dist; use Exp_Dist;
+with Exp_Dbug; use Exp_Dbug;
+with Freeze; use Freeze;
+with Ghost; use Ghost;
+with Lib; use Lib;
+with Lib.Xref; use Lib.Xref;
+with Namet; use Namet;
+with Nmake; use Nmake;
+with Nlists; use Nlists;
+with Opt; use Opt;
+with Output; use Output;
+with Rtsfind; use Rtsfind;
+with Sem; use Sem;
+with Sem_Aux; use Sem_Aux;
+with Sem_Cat; use Sem_Cat;
+with Sem_Ch3; use Sem_Ch3;
+with Sem_Ch6; use Sem_Ch6;
+with Sem_Ch8; use Sem_Ch8;
+with Sem_Ch10; use Sem_Ch10;
+with Sem_Ch12; use Sem_Ch12;
+with Sem_Ch13; use Sem_Ch13;
+with Sem_Disp; use Sem_Disp;
+with Sem_Eval; use Sem_Eval;
+with Sem_Prag; use Sem_Prag;
+with Sem_Util; use Sem_Util;
+with Sem_Warn; use Sem_Warn;
+with Snames; use Snames;
+with Stand; use Stand;
+with Sinfo; use Sinfo;
+with Sinfo.Nodes; use Sinfo.Nodes;
+with Sinfo.Utils; use Sinfo.Utils;
+with Sinput; use Sinput;
with Style;
-with Uintp; use Uintp;
+with Uintp; use Uintp;
with GNAT.HTable;
@@ -840,7 +843,7 @@ package body Sem_Ch7 is
-- unannotated body will be used in all instantiations.
Body_Id := Defining_Entity (N);
- Set_Ekind (Body_Id, E_Package_Body);
+ Mutate_Ekind (Body_Id, E_Package_Body);
Set_Scope (Body_Id, Scope (Spec_Id));
Set_Is_Obsolescent (Body_Id, Is_Obsolescent (Spec_Id));
Set_Body_Entity (Spec_Id, Body_Id);
@@ -872,7 +875,7 @@ package body Sem_Ch7 is
-- current node otherwise. Note that N was rewritten above, so we must
-- be sure to get the latest Body_Id value.
- Set_Ekind (Body_Id, E_Package_Body);
+ Mutate_Ekind (Body_Id, E_Package_Body);
Set_Body_Entity (Spec_Id, Body_Id);
Set_Spec_Entity (Body_Id, Spec_Id);
@@ -1000,13 +1003,6 @@ package body Sem_Ch7 is
Analyze_List (Declarations (N));
end if;
- -- If procedures marked with CUDA_Global have been defined within N, we
- -- need to register them with the CUDA runtime at program startup. This
- -- requires multiple declarations and function calls which need to be
- -- appended to N's declarations.
-
- Build_And_Insert_CUDA_Initialization (N);
-
HSS := Handled_Statement_Sequence (N);
if Present (HSS) then
@@ -1165,7 +1161,7 @@ package body Sem_Ch7 is
Generate_Definition (Id);
Enter_Name (Id);
- Set_Ekind (Id, E_Package);
+ Mutate_Ekind (Id, E_Package);
Set_Etype (Id, Standard_Void_Type);
-- Set SPARK_Mode from context
@@ -2065,6 +2061,8 @@ package body Sem_Ch7 is
Replace_Elmt (Op_Elmt, New_Op);
Remove_Elmt (Op_List, Op_Elmt_2);
Set_Overridden_Operation (New_Op, Parent_Subp);
+ Set_Is_Ada_2022_Only (New_Op,
+ Is_Ada_2022_Only (Parent_Subp));
-- We don't need to inherit its dispatching slot.
-- Set_All_DT_Position has previously ensured that
@@ -2562,9 +2560,9 @@ package body Sem_Ch7 is
end if;
if Limited_Present (Def) then
- Set_Ekind (Id, E_Limited_Private_Type);
+ Mutate_Ekind (Id, E_Limited_Private_Type);
else
- Set_Ekind (Id, E_Private_Type);
+ Mutate_Ekind (Id, E_Private_Type);
end if;
Set_Etype (Id, Id);
@@ -2596,7 +2594,7 @@ package body Sem_Ch7 is
Set_Private_Dependents (Id, New_Elmt_List);
if Tagged_Present (Def) then
- Set_Ekind (Id, E_Record_Type_With_Private);
+ Mutate_Ekind (Id, E_Record_Type_With_Private);
Set_Direct_Primitive_Operations (Id, New_Elmt_List);
Set_Is_Abstract_Type (Id, Abstract_Present (Def));
Set_Is_Limited_Record (Id, Limited_Present (Def));
@@ -2614,6 +2612,15 @@ package body Sem_Ch7 is
elsif Abstract_Present (Def) then
Error_Msg_N ("only a tagged type can be abstract", N);
+
+ -- When extensions are enabled, we initialize the primitive operations
+ -- list of an untagged private type to an empty element list. (Note:
+ -- This could be done for all private types and shared with the tagged
+ -- case above, but for now we do it separately when the feature of
+ -- prefixed calls for untagged types is enabled.)
+
+ elsif Extensions_Allowed then
+ Set_Direct_Primitive_Operations (Id, New_Elmt_List);
end if;
end New_Private_Type;
@@ -2726,8 +2733,10 @@ package body Sem_Ch7 is
(Priv, Size_Known_At_Compile_Time (Full));
Set_Is_Volatile (Priv, Is_Volatile (Full));
Set_Treat_As_Volatile (Priv, Treat_As_Volatile (Full));
+ Set_Is_Atomic (Priv, Is_Atomic (Full));
Set_Is_Ada_2005_Only (Priv, Is_Ada_2005_Only (Full));
Set_Is_Ada_2012_Only (Priv, Is_Ada_2012_Only (Full));
+ Set_Is_Ada_2022_Only (Priv, Is_Ada_2022_Only (Full));
Set_Has_Pragma_Unmodified (Priv, Has_Pragma_Unmodified (Full));
Set_Has_Pragma_Unreferenced (Priv, Has_Pragma_Unreferenced (Full));
Set_Has_Pragma_Unreferenced_Objects
@@ -2737,7 +2746,6 @@ package body Sem_Ch7 is
if Is_Unchecked_Union (Full) then
Set_Is_Unchecked_Union (Base_Type (Priv));
end if;
- -- Why is atomic not copied here ???
if Referenced (Full) then
Set_Referenced (Priv);
@@ -2932,6 +2940,11 @@ package body Sem_Ch7 is
Set_Is_Potentially_Use_Visible (Id);
end if;
+ -- Avoid crash caused by previous errors
+
+ elsif No (Etype (Id)) and then Serious_Errors_Detected /= 0 then
+ null;
+
-- We need to avoid incorrectly marking enumeration literals as
-- non-visible when a visible use-all-type clause is in effect.
diff --git a/gcc/ada/sem_ch7.ads b/gcc/ada/sem_ch7.ads
index f42c0bd..064ffb2 100644
--- a/gcc/ada/sem_ch7.ads
+++ b/gcc/ada/sem_ch7.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute 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 efff714..78d2426 100644
--- a/gcc/ada/sem_ch8.adb
+++ b/gcc/ada/sem_ch8.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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,55 +23,59 @@
-- --
------------------------------------------------------------------------------
-with Atree; use Atree;
-with Debug; use Debug;
-with Einfo; use Einfo;
-with Elists; use Elists;
-with Errout; use Errout;
-with Exp_Disp; use Exp_Disp;
-with Exp_Tss; use Exp_Tss;
-with Exp_Util; use Exp_Util;
-with Freeze; use Freeze;
-with Ghost; use Ghost;
-with Impunit; use Impunit;
-with Lib; use Lib;
-with Lib.Load; use Lib.Load;
-with Lib.Xref; use Lib.Xref;
-with Namet; use Namet;
-with Namet.Sp; use Namet.Sp;
-with Nlists; use Nlists;
-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;
-with Sem_Cat; use Sem_Cat;
-with Sem_Ch3; use Sem_Ch3;
-with Sem_Ch4; use Sem_Ch4;
-with Sem_Ch6; use Sem_Ch6;
-with Sem_Ch10; use Sem_Ch10;
-with Sem_Ch12; use Sem_Ch12;
-with Sem_Ch13; use Sem_Ch13;
-with Sem_Dim; use Sem_Dim;
-with Sem_Disp; use Sem_Disp;
-with Sem_Dist; use Sem_Dist;
-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 Sem_Type; use Sem_Type;
-with Stand; use Stand;
-with Sinfo; use Sinfo;
-with Sinfo.CN; use Sinfo.CN;
-with Snames; use Snames;
+with Atree; use Atree;
+with Debug; use Debug;
+with Einfo; use Einfo;
+with Einfo.Entities; use Einfo.Entities;
+with Einfo.Utils; use Einfo.Utils;
+with Elists; use Elists;
+with Errout; use Errout;
+with Exp_Disp; use Exp_Disp;
+with Exp_Tss; use Exp_Tss;
+with Exp_Util; use Exp_Util;
+with Freeze; use Freeze;
+with Ghost; use Ghost;
+with Impunit; use Impunit;
+with Lib; use Lib;
+with Lib.Load; use Lib.Load;
+with Lib.Xref; use Lib.Xref;
+with Namet; use Namet;
+with Namet.Sp; use Namet.Sp;
+with Nlists; use Nlists;
+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;
+with Sem_Cat; use Sem_Cat;
+with Sem_Ch3; use Sem_Ch3;
+with Sem_Ch4; use Sem_Ch4;
+with Sem_Ch6; use Sem_Ch6;
+with Sem_Ch10; use Sem_Ch10;
+with Sem_Ch12; use Sem_Ch12;
+with Sem_Ch13; use Sem_Ch13;
+with Sem_Dim; use Sem_Dim;
+with Sem_Disp; use Sem_Disp;
+with Sem_Dist; use Sem_Dist;
+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 Sem_Type; use Sem_Type;
+with Stand; use Stand;
+with Sinfo; use Sinfo;
+with Sinfo.Nodes; use Sinfo.Nodes;
+with Sinfo.Utils; use Sinfo.Utils;
+with Sinfo.CN; use Sinfo.CN;
+with Snames; use Snames;
with Style;
with Table;
-with Tbuild; use Tbuild;
-with Uintp; use Uintp;
+with Tbuild; use Tbuild;
+with Uintp; use Uintp;
package body Sem_Ch8 is
@@ -477,11 +481,10 @@ package body Sem_Ch8 is
-- legality of selector given the scope denoted by prefix, and change node
-- N into a expanded name with a properly set Entity field.
- function Find_Most_Prev (Use_Clause : Node_Id) return Node_Id;
+ function Find_First_Use (Use_Clause : Node_Id) return Node_Id;
-- Find the most previous use clause (that is, the first one to appear in
-- the source) by traversing the previous clause chain that exists in both
-- N_Use_Package_Clause nodes and N_Use_Type_Clause nodes.
- -- ??? a better subprogram name is in order
function Find_Renamed_Entity
(N : Node_Id;
@@ -525,7 +528,6 @@ package body Sem_Ch8 is
Clause2 : Entity_Id) return Entity_Id;
-- Determine which use clause parameter is the most descendant in terms of
-- scope.
- -- ??? a better subprogram name is in order
procedure Premature_Usage (N : Node_Id);
-- Diagnose usage of an entity before it is visible
@@ -568,7 +570,7 @@ package body Sem_Ch8 is
Enter_Name (Id);
Analyze (Nam);
- Set_Ekind (Id, E_Exception);
+ Mutate_Ekind (Id, E_Exception);
Set_Etype (Id, Standard_Exception_Type);
Set_Is_Pure (Id, Is_Pure (Current_Scope));
@@ -697,7 +699,7 @@ package body Sem_Ch8 is
end if;
Enter_Name (New_P);
- Set_Ekind (New_P, K);
+ Mutate_Ekind (New_P, K);
if Etype (Old_P) = Any_Type then
null;
@@ -759,6 +761,7 @@ package body Sem_Ch8 is
Dec : Node_Id;
T : Entity_Id;
T2 : Entity_Id;
+ Q : Node_Id;
procedure Check_Constrained_Object;
-- If the nominal type is unconstrained but the renamed object is
@@ -979,7 +982,7 @@ package body Sem_Ch8 is
Error_Msg_N
("object name or value expected in renaming", Nam);
- Set_Ekind (Id, E_Variable);
+ Mutate_Ekind (Id, E_Variable);
Set_Etype (Id, Any_Type);
return;
@@ -1027,7 +1030,7 @@ package body Sem_Ch8 is
Error_Msg_N
("object name or value expected in renaming", Nam);
- Set_Ekind (Id, E_Variable);
+ Mutate_Ekind (Id, E_Variable);
Set_Etype (Id, Any_Type);
return;
@@ -1074,17 +1077,55 @@ package body Sem_Ch8 is
-- Check against AI12-0401 here before Resolve may rewrite Nam and
-- potentially generate spurious warnings.
+ -- In the case where the object_name is a qualified_expression with
+ -- a nominal subtype T and whose expression is a name that denotes
+ -- an object Q:
+ -- * if T is an elementary subtype, then:
+ -- * Q shall be a constant other than a dereference of an access
+ -- type; or
+ -- * the nominal subtype of Q shall be statically compatible with
+ -- T; or
+ -- * T shall statically match the base subtype of its type if
+ -- scalar, or the first subtype of its type if an access type.
+ -- * if T is a composite subtype, then Q shall be known to be
+ -- constrained or T shall statically match the first subtype of
+ -- its type.
+
if Nkind (Nam) = N_Qualified_Expression
- and then Is_Variable (Expression (Nam))
- and then not
- (Subtypes_Statically_Match (T, Etype (Expression (Nam)))
- or else
- Subtypes_Statically_Match (Base_Type (T), Etype (Nam)))
+ and then Is_Object_Reference (Expression (Nam))
then
- Error_Msg_N
- ("subtype of renamed qualified expression does not " &
- "statically match", N);
- return;
+ Q := Expression (Nam);
+
+ if (Is_Elementary_Type (T)
+ and then
+ not ((not Is_Variable (Q)
+ and then Nkind (Q) /= N_Explicit_Dereference)
+ or else Subtypes_Statically_Compatible (Etype (Q), T)
+ or else (Is_Scalar_Type (T)
+ and then Subtypes_Statically_Match
+ (T, Base_Type (T)))
+ or else (Is_Access_Type (T)
+ and then Subtypes_Statically_Match
+ (T, First_Subtype (T)))))
+ or else (Is_Composite_Type (T)
+ and then
+
+ -- If Q is an aggregate, Is_Constrained may not be set
+ -- yet and its type may not be resolved yet.
+ -- This doesn't quite correspond to the complex notion
+ -- of "known to be constrained" but this is good enough
+ -- for a rule which is in any case too complex.
+
+ not (Is_Constrained (Etype (Q))
+ or else Nkind (Q) = N_Aggregate
+ or else Subtypes_Statically_Match
+ (T, First_Subtype (T))))
+ then
+ Error_Msg_N
+ ("subtype of renamed qualified expression does not " &
+ "statically match", N);
+ return;
+ end if;
end if;
Resolve (Nam, T);
@@ -1102,7 +1143,7 @@ package body Sem_Ch8 is
and then Comes_From_Source (N)
then
Set_Etype (Id, T);
- Set_Ekind (Id, E_Constant);
+ Mutate_Ekind (Id, E_Constant);
Rewrite (N,
Make_Object_Declaration (Loc,
Defining_Identifier => Id,
@@ -1125,7 +1166,9 @@ package body Sem_Ch8 is
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???
+ Error_Msg_NE
+ ("cannot rename anonymous access object "
+ & "as a named access type", Expression (Nam), T);
end if;
-- Check that a class-wide object is not being renamed as an object
@@ -1415,13 +1458,9 @@ package body Sem_Ch8 is
-- want to change it to a variable.
if Ekind (Id) /= E_Constant then
- Set_Ekind (Id, E_Variable);
+ Mutate_Ekind (Id, E_Variable);
end if;
- -- Initialize the object size and alignment. Note that we used to call
- -- Init_Size_Align here, but that's wrong for objects which have only
- -- an Esize, not an RM_Size field.
-
Init_Object_Size_Align (Id);
-- If N comes from source then check that the original node is an
@@ -1491,13 +1530,13 @@ package body Sem_Ch8 is
-- Ignore (accept) N_Raise_xxx_Error nodes in this context.
elsif No_Raise_xxx_Error (Nam) = OK then
- Error_Msg_Ada_2020_Feature ("value in renaming", Sloc (Nam));
+ Error_Msg_Ada_2022_Feature ("value in renaming", Sloc (Nam));
end if;
Set_Etype (Id, T2);
if not Is_Variable (Nam) then
- Set_Ekind (Id, E_Constant);
+ Mutate_Ekind (Id, E_Constant);
Set_Never_Set_In_Source (Id, True);
Set_Is_True_Constant (Id, True);
end if;
@@ -1506,10 +1545,11 @@ package body Sem_Ch8 is
-- renamed object is atomic, independent, volatile or VFA. These flags
-- are set on the renamed object in the RM legality sense.
- Set_Is_Atomic (Id, Is_Atomic_Object (Nam));
- Set_Is_Independent (Id, Is_Independent_Object (Nam));
- Set_Is_Volatile (Id, Is_Volatile_Object (Nam));
- Set_Is_Volatile_Full_Access (Id, Is_Volatile_Full_Access_Object (Nam));
+ Set_Is_Atomic (Id, Is_Atomic_Object (Nam));
+ Set_Is_Independent (Id, Is_Independent_Object (Nam));
+ Set_Is_Volatile (Id, Is_Volatile_Object_Ref (Nam));
+ Set_Is_Volatile_Full_Access
+ (Id, Is_Volatile_Full_Access_Object_Ref (Nam));
-- Treat as volatile if we just set the Volatile flag
@@ -1592,7 +1632,7 @@ package body Sem_Ch8 is
-- Set basic attributes to minimize cascaded errors
- Set_Ekind (New_P, E_Package);
+ Mutate_Ekind (New_P, E_Package);
Set_Etype (New_P, Standard_Void_Type);
elsif Present (Renamed_Entity (Old_P))
@@ -1607,7 +1647,7 @@ package body Sem_Ch8 is
-- Set basic attributes to minimize cascaded errors
- Set_Ekind (New_P, E_Package);
+ Mutate_Ekind (New_P, E_Package);
Set_Etype (New_P, Standard_Void_Type);
-- Here for OK package renaming
@@ -1617,7 +1657,7 @@ package body Sem_Ch8 is
-- entity. The simplest implementation is to have both packages share
-- the entity list.
- Set_Ekind (New_P, E_Package);
+ Mutate_Ekind (New_P, E_Package);
Set_Etype (New_P, Standard_Void_Type);
if Present (Renamed_Object (Old_P)) then
@@ -1823,7 +1863,7 @@ package body Sem_Ch8 is
Old_S := Find_Renamed_Entity (N, Selector_Name (Nam), New_S);
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
Check_Subtype_Conformant (New_S, Old_S, N);
@@ -3238,7 +3278,10 @@ package body Sem_Ch8 is
-- constructed later at the freeze point, so indicate that the
-- completion has not been seen yet.
- Set_Ekind (New_S, E_Subprogram_Body);
+ Reinit_Field_To_Zero (New_S, F_Has_Out_Or_In_Out_Parameter);
+ Reinit_Field_To_Zero (New_S, F_Needs_No_Actuals,
+ Old_Ekind => (E_Function | E_Procedure => True, others => False));
+ Mutate_Ekind (New_S, E_Subprogram_Body);
New_S := Rename_Spec;
Set_Has_Completion (Rename_Spec, False);
@@ -3256,7 +3299,9 @@ package body Sem_Ch8 is
Style.Missing_Overriding (N, Rename_Spec);
end if;
- elsif Must_Override (Specification (N)) then
+ elsif Must_Override (Specification (N))
+ and then not Can_Override_Operator (Rename_Spec)
+ then
Error_Msg_NE ("subprogram& is not overriding", N, Rename_Spec);
end if;
@@ -3538,7 +3583,7 @@ package body Sem_Ch8 is
end if;
if Original_Subprogram (Old_S) = Rename_Spec then
- Error_Msg_N ("unfrozen subprogram cannot rename itself ", N);
+ Error_Msg_N ("unfrozen subprogram cannot rename itself", N);
else
Check_Formal_Subprogram_Conformance (New_S, Old_S, Spec);
end if;
@@ -3745,15 +3790,31 @@ package body Sem_Ch8 is
Set_Has_Delayed_Freeze (New_S, False);
Freeze_Before (N, New_S);
- -- An abstract subprogram is only allowed as an actual in the case
- -- where the formal subprogram is also abstract.
-
if (Ekind (Old_S) = E_Procedure or else Ekind (Old_S) = E_Function)
- and then Is_Abstract_Subprogram (Old_S)
and then not Is_Abstract_Subprogram (Formal_Spec)
then
- Error_Msg_N
- ("abstract subprogram not allowed as generic actual", Nam);
+ -- An abstract subprogram is only allowed as an actual in the
+ -- case where the formal subprogram is also abstract.
+
+ if Is_Abstract_Subprogram (Old_S) then
+ Error_Msg_N
+ ("abstract subprogram not allowed as generic actual", Nam);
+ end if;
+
+ -- AI12-0412: A primitive of an abstract type with Pre'Class
+ -- or Post'Class aspects specified with nonstatic expressions
+ -- is not allowed as actual for a nonabstract formal subprogram
+ -- (see RM 6.1.1(18.2/5).
+
+ if Is_Dispatching_Operation (Old_S)
+ and then
+ Is_Prim_Of_Abst_Type_With_Nonstatic_CW_Pre_Post (Old_S)
+ then
+ Error_Msg_N
+ ("primitive of abstract type with nonstatic class-wide "
+ & "pre/postconditions not allowed as actual",
+ Nam);
+ end if;
end if;
end if;
@@ -4404,7 +4465,7 @@ package body Sem_Ch8 is
if not Configurable_Run_Time_Mode
and then not Present (Corresponding_Formal_Spec (N))
- and then Etype (Nam) /= RTE (RE_AST_Handler)
+ and then not Is_RTE (Etype (Nam), RE_AST_Handler)
then
declare
P : constant Node_Id := Prefix (Nam);
@@ -4819,7 +4880,7 @@ package body Sem_Ch8 is
Pop_Scope;
- while not (Is_List_Member (Decl))
+ while not Is_List_Member (Decl)
or else Nkind (Parent (Decl)) in N_Protected_Definition
| N_Task_Definition
loop
@@ -5271,16 +5332,6 @@ package body Sem_Ch8 is
elsif not Comes_From_Source (E) then
return False;
-
- -- In gnat internal mode, we consider all entities known. The
- -- historical reason behind this discrepancy is not known??? But the
- -- only effect is to modify the error message given, so it is not
- -- critical. Since it only affects the exact wording of error
- -- messages in illegal programs, we do not mention this as an
- -- effect of -gnatg, since it is not a language modification.
-
- elsif GNAT_Mode then
- return True;
end if;
-- Here we have an entity that is not from package Standard, and
@@ -6790,7 +6841,17 @@ package body Sem_Ch8 is
end if;
end if;
- Change_Selected_Component_To_Expanded_Name (N);
+ case Nkind (N) is
+ when N_Selected_Component =>
+ Reinit_Field_To_Zero (N, F_Is_Prefixed_Call);
+ Change_Selected_Component_To_Expanded_Name (N);
+
+ when N_Expanded_Name =>
+ null;
+
+ when others =>
+ pragma Assert (False);
+ end case;
-- Preserve relevant elaboration-related attributes of the context which
-- are no longer available or very expensive to recompute once analysis,
@@ -6936,10 +6997,10 @@ package body Sem_Ch8 is
end Find_Expanded_Name;
--------------------
- -- Find_Most_Prev --
+ -- Find_First_Use --
--------------------
- function Find_Most_Prev (Use_Clause : Node_Id) return Node_Id is
+ function Find_First_Use (Use_Clause : Node_Id) return Node_Id is
Curr : Node_Id;
begin
@@ -6951,7 +7012,7 @@ package body Sem_Ch8 is
end loop;
return Curr;
- end Find_Most_Prev;
+ end Find_First_Use;
-------------------------
-- Find_Renamed_Entity --
@@ -7469,15 +7530,9 @@ package body Sem_Ch8 is
-- dispatch table wrappers. Required to avoid generating
-- elaboration code with HI runtimes.
- elsif RTU_Loaded (Ada_Tags)
- and then
- ((RTE_Available (RE_Dispatch_Table_Wrapper)
- and then Scope (Selector) =
- RTE (RE_Dispatch_Table_Wrapper))
- or else
- (RTE_Available (RE_No_Dispatch_Table_Wrapper)
- and then Scope (Selector) =
- RTE (RE_No_Dispatch_Table_Wrapper)))
+ elsif Is_RTE (Scope (Selector), RE_Dispatch_Table_Wrapper)
+ or else
+ Is_RTE (Scope (Selector), RE_No_Dispatch_Table_Wrapper)
then
C_Etype := Empty;
else
@@ -7549,10 +7604,16 @@ package body Sem_Ch8 is
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).
+ -- First check for components of a record object (not the result of
+ -- a call, which is handled below). This also covers the case where
+ -- where the extension feature that supports the prefixed form of
+ -- calls for primitives of untagged types is enabled (excluding
+ -- concurrent cases, which are handled further below).
- if Has_Components (P_Type)
+ if Is_Type (P_Type)
+ and then (Has_Components (P_Type)
+ or else (Extensions_Allowed
+ and then not Is_Concurrent_Type (P_Type)))
and then not Is_Overloadable (P_Name)
and then not Is_Type (P_Name)
then
@@ -7893,16 +7954,18 @@ package body Sem_Ch8 is
Set_Entity (N, Any_Type);
return;
- -- ??? This test is temporarily disabled (always
- -- False) because it causes an unwanted warning on
- -- GNAT sources (built with -gnatg, which includes
- -- Warn_On_Obsolescent_ Feature). Once this issue
- -- is cleared in the sources, it can be enabled.
+ else
+ if Restriction_Check_Required (No_Obsolescent_Features)
+ then
+ Check_Restriction
+ (No_Obsolescent_Features, Prefix (N));
+ end if;
- elsif Warn_On_Obsolescent_Feature and then False then
- Error_Msg_N
- ("applying ''Class to an untagged incomplete type"
- & " is an obsolescent feature (RM J.11)?r?", N);
+ if Warn_On_Obsolescent_Feature then
+ Error_Msg_N
+ ("applying ''Class to an untagged incomplete type"
+ & " is an obsolescent feature (RM J.11)?r?", N);
+ end if;
end if;
end if;
@@ -8087,25 +8150,14 @@ package body Sem_Ch8 is
if Ekind (Base_Type (T_Name)) = E_Task_Type then
-- In Ada 2005, a task name can be used in an access
- -- definition within its own body. It cannot be used
- -- in the discriminant part of the task declaration,
- -- nor anywhere else in the declaration because entries
- -- cannot have access parameters.
+ -- definition within its own body.
if Ada_Version >= Ada_2005
and then Nkind (Parent (N)) = N_Access_Definition
then
Set_Entity (N, T_Name);
Set_Etype (N, T_Name);
-
- if Has_Completion (T_Name) then
- return;
-
- else
- Error_Msg_N
- ("task type cannot be used as type mark " &
- "within its own declaration", N);
- end if;
+ return;
else
Error_Msg_N
@@ -8959,6 +9011,28 @@ package body Sem_Ch8 is
procedure Push_Scope (S : Entity_Id) is
E : constant Entity_Id := Scope (S);
+ function Component_Alignment_Default return Component_Alignment_Kind;
+ -- Return Component_Alignment_Kind for the newly-pushed scope.
+
+ function Component_Alignment_Default return Component_Alignment_Kind is
+ begin
+ -- Each new scope pushed onto the scope stack inherits the component
+ -- alignment of the previous scope. This emulates the "visibility"
+ -- semantics of pragma Component_Alignment.
+
+ if Scope_Stack.Last > Scope_Stack.First then
+ return Scope_Stack.Table
+ (Scope_Stack.Last - 1).Component_Alignment_Default;
+
+ -- Otherwise, this is the first scope being pushed on the scope
+ -- stack. Inherit the component alignment from the configuration
+ -- form of pragma Component_Alignment (if any).
+
+ else
+ return Configuration_Component_Alignment;
+ end if;
+ end Component_Alignment_Default;
+
begin
if Ekind (S) = E_Void then
null;
@@ -8987,49 +9061,27 @@ package body Sem_Ch8 is
Scope_Stack.Increment_Last;
- declare
- SST : Scope_Stack_Entry renames Scope_Stack.Table (Scope_Stack.Last);
-
- begin
- SST.Entity := S;
- SST.Save_Scope_Suppress := Scope_Suppress;
- SST.Save_Local_Suppress_Stack_Top := Local_Suppress_Stack_Top;
- SST.Save_Check_Policy_List := Check_Policy_List;
- SST.Save_Default_Storage_Pool := Default_Pool;
- SST.Save_No_Tagged_Streams := No_Tagged_Streams;
- SST.Save_SPARK_Mode := SPARK_Mode;
- SST.Save_SPARK_Mode_Pragma := SPARK_Mode_Pragma;
- SST.Save_Default_SSO := Default_SSO;
- SST.Save_Uneval_Old := Uneval_Old;
-
- -- Each new scope pushed onto the scope stack inherits the component
- -- alignment of the previous scope. This emulates the "visibility"
- -- semantics of pragma Component_Alignment.
-
- if Scope_Stack.Last > Scope_Stack.First then
- SST.Component_Alignment_Default :=
- Scope_Stack.Table
- (Scope_Stack.Last - 1).Component_Alignment_Default;
-
- -- Otherwise, this is the first scope being pushed on the scope
- -- stack. Inherit the component alignment from the configuration
- -- form of pragma Component_Alignment (if any).
-
- else
- SST.Component_Alignment_Default :=
- Configuration_Component_Alignment;
- end if;
-
- SST.Last_Subprogram_Name := null;
- SST.Is_Transient := False;
- SST.Node_To_Be_Wrapped := Empty;
- SST.Pending_Freeze_Actions := No_List;
- SST.Actions_To_Be_Wrapped := (others => No_List);
- SST.First_Use_Clause := Empty;
- SST.Is_Active_Stack_Base := False;
- SST.Previous_Visibility := False;
- SST.Locked_Shared_Objects := No_Elist;
- end;
+ Scope_Stack.Table (Scope_Stack.Last) :=
+ (Entity => S,
+ Save_Scope_Suppress => Scope_Suppress,
+ Save_Local_Suppress_Stack_Top => Local_Suppress_Stack_Top,
+ Save_Check_Policy_List => Check_Policy_List,
+ Save_Default_Storage_Pool => Default_Pool,
+ Save_No_Tagged_Streams => No_Tagged_Streams,
+ Save_SPARK_Mode => SPARK_Mode,
+ Save_SPARK_Mode_Pragma => SPARK_Mode_Pragma,
+ Save_Default_SSO => Default_SSO,
+ Save_Uneval_Old => Uneval_Old,
+ Component_Alignment_Default => Component_Alignment_Default,
+ Last_Subprogram_Name => null,
+ Is_Transient => False,
+ Node_To_Be_Wrapped => Empty,
+ Pending_Freeze_Actions => No_List,
+ Actions_To_Be_Wrapped => (others => No_List),
+ First_Use_Clause => Empty,
+ Is_Active_Stack_Base => False,
+ Previous_Visibility => False,
+ Locked_Shared_Objects => No_Elist);
if Debug_Flag_W then
Write_Str ("--> new scope: ");
@@ -9766,16 +9818,16 @@ package body Sem_Ch8 is
if Present (Redundant) and then Parent (Redundant) /= Prev_Use then
-- Make sure we are looking at most-descendant use_package_clause
- -- by traversing the chain with Find_Most_Prev and then verifying
+ -- by traversing the chain with Find_First_Use and then verifying
-- there is no scope manipulation via Most_Descendant_Use_Clause.
if Nkind (Prev_Use) = N_Use_Package_Clause
and then
(Nkind (Parent (Prev_Use)) /= N_Compilation_Unit
or else Most_Descendant_Use_Clause
- (Prev_Use, Find_Most_Prev (Prev_Use)) /= Prev_Use)
+ (Prev_Use, Find_First_Use (Prev_Use)) /= Prev_Use)
then
- Prev_Use := Find_Most_Prev (Prev_Use);
+ Prev_Use := Find_First_Use (Prev_Use);
end if;
Error_Msg_Sloc := Sloc (Prev_Use);
@@ -10329,7 +10381,7 @@ package body Sem_Ch8 is
if Present (Current_Use_Clause (T)) then
Use_Clause_Known : declare
Clause1 : constant Node_Id :=
- Find_Most_Prev (Current_Use_Clause (T));
+ Find_First_Use (Current_Use_Clause (T));
Clause2 : constant Node_Id := Parent (Id);
Ent1 : Entity_Id;
Ent2 : Entity_Id;
@@ -10469,10 +10521,10 @@ package body Sem_Ch8 is
-- a spurious warning - so verify there is a previous use clause.
if Current_Use_Clause (Scope (T)) /=
- Find_Most_Prev (Current_Use_Clause (Scope (T)))
+ Find_First_Use (Current_Use_Clause (Scope (T)))
then
Error_Msg_Sloc :=
- Sloc (Find_Most_Prev (Current_Use_Clause (Scope (T))));
+ Sloc (Find_First_Use (Current_Use_Clause (Scope (T))));
Error_Msg_NE -- CODEFIX
("& is already use-visible through package use clause #??",
Id, T);
diff --git a/gcc/ada/sem_ch8.ads b/gcc/ada/sem_ch8.ads
index fe5d5ee..d47f421 100644
--- a/gcc/ada/sem_ch8.ads
+++ b/gcc/ada/sem_ch8.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute 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 b7b7d7d..ab25dd0 100644
--- a/gcc/ada/sem_ch9.adb
+++ b/gcc/ada/sem_ch9.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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,46 +23,50 @@
-- --
------------------------------------------------------------------------------
-with Aspects; use Aspects;
-with Atree; use Atree;
-with Checks; use Checks;
-with Contracts; use Contracts;
-with Debug; use Debug;
-with Einfo; use Einfo;
-with Errout; use Errout;
-with Exp_Ch9; use Exp_Ch9;
-with Elists; use Elists;
-with Freeze; use Freeze;
-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;
-with Rident; use Rident;
-with Rtsfind; use Rtsfind;
-with Sem; use Sem;
-with Sem_Aux; use Sem_Aux;
-with Sem_Ch3; use Sem_Ch3;
-with Sem_Ch5; use Sem_Ch5;
-with Sem_Ch6; use Sem_Ch6;
-with Sem_Ch8; use Sem_Ch8;
-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_Type; use Sem_Type;
-with Sem_Util; use Sem_Util;
-with Sem_Warn; use Sem_Warn;
-with Snames; use Snames;
-with Stand; use Stand;
-with Sinfo; use Sinfo;
+with Aspects; use Aspects;
+with Atree; use Atree;
+with Checks; use Checks;
+with Contracts; use Contracts;
+with Debug; use Debug;
+with Einfo; use Einfo;
+with Einfo.Entities; use Einfo.Entities;
+with Einfo.Utils; use Einfo.Utils;
+with Errout; use Errout;
+with Exp_Ch9; use Exp_Ch9;
+with Elists; use Elists;
+with Freeze; use Freeze;
+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;
+with Rident; use Rident;
+with Rtsfind; use Rtsfind;
+with Sem; use Sem;
+with Sem_Aux; use Sem_Aux;
+with Sem_Ch3; use Sem_Ch3;
+with Sem_Ch5; use Sem_Ch5;
+with Sem_Ch6; use Sem_Ch6;
+with Sem_Ch8; use Sem_Ch8;
+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_Type; use Sem_Type;
+with Sem_Util; use Sem_Util;
+with Sem_Warn; use Sem_Warn;
+with Snames; use Snames;
+with Stand; use Stand;
+with Sinfo; use Sinfo;
+with Sinfo.Nodes; use Sinfo.Nodes;
+with Sinfo.Utils; use Sinfo.Utils;
with Style;
-with Tbuild; use Tbuild;
-with Uintp; use Uintp;
+with Tbuild; use Tbuild;
+with Uintp; use Uintp;
package body Sem_Ch9 is
@@ -1228,9 +1232,9 @@ package body Sem_Ch9 is
Analyze (Formals);
if Present (Entry_Index_Specification (Formals)) then
- Set_Ekind (Id, E_Entry_Family);
+ Mutate_Ekind (Id, E_Entry_Family);
else
- Set_Ekind (Id, E_Entry);
+ Mutate_Ekind (Id, E_Entry);
end if;
Set_Etype (Id, Standard_Void_Type);
@@ -1522,7 +1526,7 @@ package body Sem_Ch9 is
if Nkind (Call) = N_Explicit_Dereference then
Error_Msg_N
- ("entry call or dispatching primitive of interface required ", N);
+ ("entry call or dispatching primitive of interface required", N);
end if;
if Is_Non_Empty_List (Statements (N)) then
@@ -1547,13 +1551,13 @@ package body Sem_Ch9 is
-- Case of no discrete subtype definition
if No (D_Sdef) then
- Set_Ekind (Def_Id, E_Entry);
+ Mutate_Ekind (Def_Id, E_Entry);
-- Processing for discrete subtype definition present
else
Enter_Name (Def_Id);
- Set_Ekind (Def_Id, E_Entry_Family);
+ Mutate_Ekind (Def_Id, E_Entry_Family);
Analyze (D_Sdef);
Make_Index (D_Sdef, N, Def_Id);
@@ -1718,11 +1722,11 @@ package body Sem_Ch9 is
Make_Index (Def, N);
end if;
- Set_Ekind (Loop_Id, E_Loop);
+ Mutate_Ekind (Loop_Id, E_Loop);
Set_Scope (Loop_Id, Current_Scope);
Push_Scope (Loop_Id);
Enter_Name (Iden);
- Set_Ekind (Iden, E_Entry_Index_Parameter);
+ Mutate_Ekind (Iden, E_Entry_Index_Parameter);
Set_Etype (Iden, Etype (Def));
end Analyze_Entry_Index_Specification;
@@ -1804,7 +1808,7 @@ package body Sem_Ch9 is
Freeze_Previous_Contracts (N);
Tasking_Used := True;
- Set_Ekind (Body_Id, E_Protected_Body);
+ Mutate_Ekind (Body_Id, E_Protected_Body);
Set_Etype (Body_Id, Standard_Void_Type);
Spec_Id := Find_Concurrent_Spec (Body_Id);
@@ -1951,9 +1955,7 @@ package body Sem_Ch9 is
Tasking_Used := True;
Analyze_Declarations (Visible_Declarations (N));
- if Present (Private_Declarations (N))
- and then not Is_Empty_List (Private_Declarations (N))
- then
+ if not Is_Empty_List (Private_Declarations (N)) then
Last_Id := Last_Entity (Prot_Typ);
Analyze_Declarations (Private_Declarations (N));
@@ -2020,13 +2022,19 @@ package body Sem_Ch9 is
Set_Completion_Referenced (T);
end if;
- Set_Ekind (T, E_Protected_Type);
+ Mutate_Ekind (T, E_Protected_Type);
Set_Is_First_Subtype (T);
Init_Size_Align (T);
Set_Etype (T, T);
Set_Has_Delayed_Freeze (T);
Set_Stored_Constraint (T, No_Elist);
+ -- Initialize type's primitive operations list, for possible use when
+ -- the extension of prefixed call notation for untagged types is enabled
+ -- (such as by use of -gnatX).
+
+ Set_Direct_Primitive_Operations (T, New_Elmt_List);
+
-- Mark this type as a protected type for the sake of restrictions,
-- unless the protected type is declared in a private part of a package
-- of the runtime. With this exception, the Suspension_Object from
@@ -2134,7 +2142,7 @@ package body Sem_Ch9 is
E := First_Entity (Current_Scope);
while Present (E) loop
if Ekind (E) = E_Void then
- Set_Ekind (E, E_Component);
+ Mutate_Ekind (E, E_Component);
Init_Component_Location (E);
end if;
@@ -2619,7 +2627,7 @@ package body Sem_Ch9 is
(Nkind (Delay_Statement (Alt)) = N_Delay_Relative_Statement)
then
Error_Msg_N
- ("delay_until and delay_relative alternatives ", Alt);
+ ("delay_until and delay_relative alternatives", Alt);
Error_Msg_N
("\cannot appear in the same selective_wait", Alt);
end if;
@@ -2771,12 +2779,12 @@ package body Sem_Ch9 is
-- its own body.
Enter_Name (Typ);
- Set_Ekind (Typ, E_Protected_Type);
+ Mutate_Ekind (Typ, E_Protected_Type);
Set_Etype (Typ, Typ);
Set_Anonymous_Object (Typ, Obj_Id);
Enter_Name (Obj_Id);
- Set_Ekind (Obj_Id, E_Variable);
+ Mutate_Ekind (Obj_Id, E_Variable);
Set_Etype (Obj_Id, Typ);
Set_SPARK_Pragma (Obj_Id, SPARK_Mode_Pragma);
Set_SPARK_Pragma_Inherited (Obj_Id);
@@ -2857,12 +2865,12 @@ package body Sem_Ch9 is
-- in its own body.
Enter_Name (Typ);
- Set_Ekind (Typ, E_Task_Type);
+ Mutate_Ekind (Typ, E_Task_Type);
Set_Etype (Typ, Typ);
Set_Anonymous_Object (Typ, Obj_Id);
Enter_Name (Obj_Id);
- Set_Ekind (Obj_Id, E_Variable);
+ Mutate_Ekind (Obj_Id, E_Variable);
Set_Etype (Obj_Id, Typ);
Set_SPARK_Pragma (Obj_Id, SPARK_Mode_Pragma);
Set_SPARK_Pragma_Inherited (Obj_Id);
@@ -2918,7 +2926,7 @@ package body Sem_Ch9 is
Tasking_Used := True;
Set_Scope (Body_Id, Current_Scope);
- Set_Ekind (Body_Id, E_Task_Body);
+ Mutate_Ekind (Body_Id, E_Task_Body);
Set_Etype (Body_Id, Standard_Void_Type);
Spec_Id := Find_Concurrent_Spec (Body_Id);
@@ -3135,12 +3143,12 @@ package body Sem_Ch9 is
Set_Completion_Referenced (T);
else
- Set_Ekind (T, E_Task_Type);
+ Mutate_Ekind (T, E_Task_Type);
Set_Corresponding_Record_Type (T, Empty);
end if;
end if;
- Set_Ekind (T, E_Task_Type);
+ Mutate_Ekind (T, E_Task_Type);
Set_Is_First_Subtype (T, True);
Set_Has_Task (T, True);
Init_Size_Align (T);
@@ -3148,6 +3156,12 @@ package body Sem_Ch9 is
Set_Has_Delayed_Freeze (T, True);
Set_Stored_Constraint (T, No_Elist);
+ -- Initialize type's primitive operations list, for possible use when
+ -- the extension of prefixed call notation for untagged types is enabled
+ -- (such as by use of -gnatX).
+
+ Set_Direct_Primitive_Operations (T, New_Elmt_List);
+
-- Set the SPARK_Mode from the current context (may be overwritten later
-- with an explicit pragma).
@@ -3677,7 +3691,7 @@ package body Sem_Ch9 is
elsif Nkind (Trigger) = N_Explicit_Dereference then
Error_Msg_N
- ("entry call or dispatching primitive of interface required ",
+ ("entry call or dispatching primitive of interface required",
Trigger);
end if;
end if;
diff --git a/gcc/ada/sem_ch9.ads b/gcc/ada/sem_ch9.ads
index abd3c09..9c06f72 100644
--- a/gcc/ada/sem_ch9.ads
+++ b/gcc/ada/sem_ch9.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute 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 cb93fdb..b303229 100644
--- a/gcc/ada/sem_dim.adb
+++ b/gcc/ada/sem_dim.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2011-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2011-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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,30 +23,34 @@
-- --
------------------------------------------------------------------------------
-with Aspects; use Aspects;
-with Atree; use Atree;
-with Einfo; use Einfo;
-with Errout; use Errout;
-with Exp_Util; use Exp_Util;
-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; use Sem;
-with Sem_Aux; use Sem_Aux;
-with Sem_Eval; use Sem_Eval;
-with Sem_Res; use Sem_Res;
-with Sem_Util; use Sem_Util;
-with Sinfo; use Sinfo;
-with Snames; use Snames;
-with Stand; use Stand;
-with Stringt; use Stringt;
+with Aspects; use Aspects;
+with Atree; use Atree;
+with Einfo; use Einfo;
+with Einfo.Entities; use Einfo.Entities;
+with Einfo.Utils; use Einfo.Utils;
+with Errout; use Errout;
+with Exp_Util; use Exp_Util;
+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; use Sem;
+with Sem_Aux; use Sem_Aux;
+with Sem_Eval; use Sem_Eval;
+with Sem_Res; use Sem_Res;
+with Sem_Util; use Sem_Util;
+with Sinfo; use Sinfo;
+with Sinfo.Nodes; use Sinfo.Nodes;
+with Sinfo.Utils; use Sinfo.Utils;
+with Snames; use Snames;
+with Stand; use Stand;
+with Stringt; use Stringt;
with Table;
-with Tbuild; use Tbuild;
-with Uintp; use Uintp;
-with Urealp; use Urealp;
+with Tbuild; use Tbuild;
+with Uintp; use Uintp;
+with Urealp; use Urealp;
with GNAT.HTable;
@@ -3761,16 +3765,20 @@ package body Sem_Dim is
---------------
function System_Of (E : Entity_Id) return System_Type is
- Type_Decl : constant Node_Id := Parent (E);
-
begin
- -- Look for Type_Decl in System_Table
+ if Present (E) then
+ declare
+ Type_Decl : constant Node_Id := Parent (E);
+ begin
+ -- Look for Type_Decl in System_Table
- for Dim_Sys in 1 .. System_Table.Last loop
- if Type_Decl = System_Table.Table (Dim_Sys).Type_Decl then
- return System_Table.Table (Dim_Sys);
- end if;
- end loop;
+ for Dim_Sys in 1 .. System_Table.Last loop
+ if Type_Decl = System_Table.Table (Dim_Sys).Type_Decl then
+ return System_Table.Table (Dim_Sys);
+ end if;
+ end loop;
+ end;
+ end if;
return Null_System;
end System_Of;
diff --git a/gcc/ada/sem_dim.ads b/gcc/ada/sem_dim.ads
index 0f9d603..b2ff685 100644
--- a/gcc/ada/sem_dim.ads
+++ b/gcc/ada/sem_dim.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2011-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2011-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute 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 36efa42..064e2b5 100644
--- a/gcc/ada/sem_disp.adb
+++ b/gcc/ada/sem_disp.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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,37 +23,40 @@
-- --
------------------------------------------------------------------------------
-with Aspects; use Aspects;
-with Atree; use Atree;
-with Debug; use Debug;
-with Elists; use Elists;
-with Einfo; use Einfo;
-with Exp_Disp; use Exp_Disp;
-with Exp_Util; use Exp_Util;
-with Exp_Ch7; use Exp_Ch7;
-with Exp_Tss; use Exp_Tss;
-with Errout; use Errout;
-with Lib.Xref; use Lib.Xref;
-with Namet; use Namet;
-with Nlists; use Nlists;
-with Nmake; use Nmake;
-with Opt; use Opt;
-with Output; use Output;
-with Restrict; use Restrict;
-with Rident; use Rident;
-with Sem; use Sem;
-with Sem_Aux; use Sem_Aux;
-with Sem_Ch3; use Sem_Ch3;
-with Sem_Ch6; use Sem_Ch6;
-with Sem_Ch8; use Sem_Ch8;
-with Sem_Eval; use Sem_Eval;
-with Sem_Type; use Sem_Type;
-with Sem_Util; use Sem_Util;
-with Snames; use Snames;
-with Sinfo; use Sinfo;
-with Tbuild; use Tbuild;
-with Uintp; use Uintp;
-with Warnsw; use Warnsw;
+with Aspects; use Aspects;
+with Atree; use Atree;
+with Debug; use Debug;
+with Elists; use Elists;
+with Einfo; use Einfo;
+with Einfo.Entities; use Einfo.Entities;
+with Einfo.Utils; use Einfo.Utils;
+with Exp_Disp; use Exp_Disp;
+with Exp_Util; use Exp_Util;
+with Exp_Ch7; use Exp_Ch7;
+with Exp_Tss; use Exp_Tss;
+with Errout; use Errout;
+with Lib.Xref; use Lib.Xref;
+with Namet; use Namet;
+with Nlists; use Nlists;
+with Nmake; use Nmake;
+with Opt; use Opt;
+with Output; use Output;
+with Restrict; use Restrict;
+with Rident; use Rident;
+with Sem; use Sem;
+with Sem_Aux; use Sem_Aux;
+with Sem_Ch6; use Sem_Ch6;
+with Sem_Ch8; use Sem_Ch8;
+with Sem_Eval; use Sem_Eval;
+with Sem_Type; use Sem_Type;
+with Sem_Util; use Sem_Util;
+with Snames; use Snames;
+with Sinfo; use Sinfo;
+with Sinfo.Nodes; use Sinfo.Nodes;
+with Sinfo.Utils; use Sinfo.Utils;
+with Tbuild; use Tbuild;
+with Uintp; use Uintp;
+with Warnsw; use Warnsw;
package body Sem_Disp is
@@ -517,6 +520,12 @@ package body Sem_Disp is
procedure Abstract_Context_Error;
-- Error for abstract call dispatching on result is not dispatching
+ function Has_Controlling_Current_Instance_Actual_In_DIC
+ (Call : Node_Id) return Boolean;
+ -- Return True if the subprogram call Call has a controlling actual
+ -- given directly by a current instance referenced within a DIC
+ -- aspect.
+
----------------------------
-- Abstract_Context_Error --
----------------------------
@@ -536,6 +545,44 @@ package body Sem_Disp is
end if;
end Abstract_Context_Error;
+ ----------------------------------------
+ -- Has_Current_Instance_Actual_In_DIC --
+ ----------------------------------------
+
+ function Has_Controlling_Current_Instance_Actual_In_DIC
+ (Call : Node_Id) return Boolean
+ is
+ A : Node_Id;
+ F : Entity_Id;
+ begin
+ F := First_Formal (Subp_Entity);
+ A := First_Actual (Call);
+
+ while Present (F) loop
+
+ -- Return True if the actual denotes a current instance (which
+ -- will be represented by an in-mode formal of the enclosing
+ -- DIC_Procedure) passed to a controlling formal. We don't have
+ -- to worry about controlling access formals here, because its
+ -- illegal to apply Access (etc.) attributes to a current
+ -- instance within an aspect (by AI12-0068).
+
+ if Is_Controlling_Formal (F)
+ and then Nkind (A) = N_Identifier
+ and then Ekind (Entity (A)) = E_In_Parameter
+ and then Is_Subprogram (Scope (Entity (A)))
+ and then Is_DIC_Procedure (Scope (Entity (A)))
+ then
+ return True;
+ end if;
+
+ Next_Formal (F);
+ Next_Actual (A);
+ end loop;
+
+ return False;
+ end Has_Controlling_Current_Instance_Actual_In_DIC;
+
-- Local variables
Scop : constant Entity_Id := Current_Scope_No_Loops;
@@ -565,29 +612,46 @@ package body Sem_Disp is
Set_Entity (Name (N), Alias (Subp));
return;
- -- An obscure special case: a null procedure may have a class-
- -- wide pre/postcondition that includes a call to an abstract
- -- subp. Calls within the expression may not have been rewritten
- -- as dispatching calls yet, because the null body appears in
- -- the current declarative part. The expression will be properly
- -- rewritten/reanalyzed when the postcondition procedure is built.
-
- -- Similarly, if this is a pre/postcondition for an abstract
- -- subprogram, it may call another abstract function which is
- -- a primitive of an abstract type. The call is non-dispatching
- -- but will be legal in overridings of the operation. However,
- -- if the call is tag-indeterminate we want to continue with
- -- with the error checking below, as this case is illegal even
- -- for abstract subprograms (see AI12-0170).
-
- elsif (Is_Subprogram (Scop)
- or else Chars (Scop) = Name_Postcondition)
+ -- If this is a pre/postcondition for an abstract subprogram,
+ -- it may call another abstract function that is a primitive
+ -- of an abstract type. The call is nondispatching but will be
+ -- legal in overridings of the operation. However, if the call
+ -- is tag-indeterminate we want to continue with with the error
+ -- checking below, as this case is illegal even for abstract
+ -- subprograms (see AI12-0170).
+
+ -- Similarly, as per AI12-0412, a nonabstract subprogram may
+ -- have a class-wide pre/postcondition that includes a call to
+ -- an abstract primitive of the subprogram's controlling type.
+ -- Certain operations (nondispatching calls, 'Access, use as
+ -- a generic actual) applied to such a nonabstract subprogram
+ -- are illegal in the case where the type is abstract (see
+ -- RM 6.1.1(18.2/5)).
+
+ elsif Is_Subprogram (Scop)
+ and then not Is_Tag_Indeterminate (N)
+ and then In_Pre_Post_Condition (Call, Class_Wide_Only => True)
+
+ -- The tagged type associated with the called subprogram must be
+ -- the same as that of the subprogram with a class-wide aspect.
+
+ and then Is_Dispatching_Operation (Scop)
and then
- ((Is_Abstract_Subprogram (Scop)
- and then not Is_Tag_Indeterminate (N))
- or else
- (Nkind (Parent (Scop)) = N_Procedure_Specification
- and then Null_Present (Parent (Scop))))
+ Find_Dispatching_Type (Subp) = Find_Dispatching_Type (Scop)
+ then
+ null;
+
+ -- Similarly to the dispensation for postconditions, a call to
+ -- an abstract function within a Default_Initial_Condition aspect
+ -- can be legal when passed a current instance of the type. Such
+ -- a call will be effectively mapped to a call to a primitive of
+ -- a descendant type (see AI12-0397, as well as AI12-0170), so
+ -- doesn't need to be dispatching. We test for being within a DIC
+ -- procedure, since that's where the call will be analyzed.
+
+ elsif Is_Subprogram (Scop)
+ and then Is_DIC_Procedure (Scop)
+ and then Has_Controlling_Current_Instance_Actual_In_DIC (Call)
then
null;
@@ -602,7 +666,7 @@ package body Sem_Disp is
-- provides a tag to make the call dispatching. This requires
-- the call to be the actual in an enclosing call, and that
-- actual must be controlling. If the call is an operand of
- -- equality, the other operand must not ve abstract.
+ -- equality, the other operand must not be abstract.
if not Is_Tagged_Type (Typ)
and then not
@@ -909,7 +973,6 @@ package body Sem_Disp is
end loop;
Check_Dispatching_Context (N);
- return;
elsif Nkind (Parent (N)) in N_Subexpr then
Check_Dispatching_Context (N);
@@ -924,6 +987,23 @@ package body Sem_Disp is
return;
end if;
+ -- If this is a nondispatching call to a nonabstract subprogram
+ -- and the subprogram has any Pre'Class or Post'Class aspects with
+ -- nonstatic values, then report an error. This is specified by
+ -- RM 6.1.1(18.2/5) (by AI12-0412).
+
+ if No (Control)
+ and then not Is_Abstract_Subprogram (Subp_Entity)
+ and then
+ Is_Prim_Of_Abst_Type_With_Nonstatic_CW_Pre_Post (Subp_Entity)
+ then
+ Error_Msg_N
+ ("nondispatching call to nonabstract subprogram of "
+ & "abstract type with nonstatic class-wide "
+ & "pre/postconditions",
+ N);
+ end if;
+
else
-- If dispatching on result, the enclosing call, if any, will
-- determine the controlling argument. Otherwise this is the
@@ -1147,7 +1227,7 @@ package body Sem_Disp is
-- primitives.
-- 3. Subprograms associated with stream attributes (built by
- -- New_Stream_Subprogram)
+ -- New_Stream_Subprogram) or with the Put_Image attribute.
-- 4. Wrappers built for inherited operations with inherited class-
-- wide conditions, where the conditions include calls to other
@@ -1176,8 +1256,11 @@ package body Sem_Disp is
or else Get_TSS_Name (Subp) = TSS_Stream_Read
or else Get_TSS_Name (Subp) = TSS_Stream_Write
+ or else Get_TSS_Name (Subp) = TSS_Put_Image
- or else Present (Contract (Overridden_Operation (Subp)))
+ or else
+ (Is_Wrapper (Subp)
+ and then Present (LSP_Subprogram (Subp)))
or else GNATprove_Mode);
@@ -2137,6 +2220,8 @@ package body Sem_Disp is
while Present (Elmt) loop
if Node (Elmt) = Orig_Prim then
Set_Overridden_Operation (S, Prim);
+ Set_Is_Ada_2022_Only (S,
+ Is_Ada_2022_Only (Prim));
Set_Alias (Prim, Orig_Prim);
return Prim;
end if;
@@ -2582,8 +2667,7 @@ package body Sem_Disp is
procedure Override_Dispatching_Operation
(Tagged_Type : Entity_Id;
Prev_Op : Entity_Id;
- New_Op : Entity_Id;
- Is_Wrapper : Boolean := False)
+ New_Op : Entity_Id)
is
Elmt : Elmt_Id;
Prim : Node_Id;
@@ -2660,7 +2744,7 @@ package body Sem_Disp is
-- wrappers of controlling functions since (at this stage)
-- they are not yet decorated.
- if not Is_Wrapper then
+ if not Is_Wrapper (New_Op) then
Check_Subtype_Conformant (New_Op, Prim);
Set_Is_Abstract_Subprogram (Prim,
@@ -2699,6 +2783,7 @@ 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));
+ Set_Is_Ada_2022_Only (New_Op, Is_Ada_2022_Only (Prev_Op));
end if;
end Override_Dispatching_Operation;
diff --git a/gcc/ada/sem_disp.ads b/gcc/ada/sem_disp.ads
index 993ec10..7b42cf5 100644
--- a/gcc/ada/sem_disp.ads
+++ b/gcc/ada/sem_disp.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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,11 +57,15 @@ package Sem_Disp is
procedure Check_Operation_From_Incomplete_Type
(Subp : Entity_Id;
Typ : Entity_Id);
- -- If a primitive operation was defined for the incomplete view of the
- -- type, and the full type declaration is a derived type definition,
- -- the operation may override an inherited one.
- -- Need more description here, what are the parameters, and what does
- -- this call actually do???
+ -- If a primitive subprogram Subp was defined for the incomplete view of
+ -- Typ, and the full type declaration is a derived type, then Subp may
+ -- override a subprogram inherited from the parent type. In that case,
+ -- the inherited subprogram will have been hidden by the current one at
+ -- the point of the type derivation, so it does not appear in the list
+ -- of primitive operations of the type, and this procedure inserts the
+ -- overriding subprogram in the the full type's list of primitives by
+ -- iterating over the list for the parent type. If instead Subp is a new
+ -- primitive, then it's simply appended to the primitive list.
procedure Check_Operation_From_Private_View (Subp, Old_Subp : Entity_Id);
-- No action performed if Subp is not an alias of a dispatching operation.
@@ -163,20 +167,16 @@ package Sem_Disp is
procedure Override_Dispatching_Operation
(Tagged_Type : Entity_Id;
Prev_Op : Entity_Id;
- New_Op : Entity_Id;
- Is_Wrapper : Boolean := False);
+ New_Op : Entity_Id);
-- Replace an implicit dispatching operation of the type Tagged_Type
-- with an explicit one. Prev_Op is an inherited primitive operation which
- -- is overridden by the explicit declaration of New_Op. Is_Wrapper is
- -- True when New_Op is an internally generated wrapper of a controlling
- -- function. The caller checks that Tagged_Type is indeed a tagged type.
+ -- is overridden by the explicit declaration of New_Op.
procedure Propagate_Tag (Control : Node_Id; Actual : Node_Id);
- -- If a function call is tag-indeterminate, its controlling argument is
- -- found in the context: either an enclosing call, or the left-hand side
- -- of the enclosing assignment statement. The tag must be propagated
- -- recursively to the tag-indeterminate actuals of the call.
- -- Need clear description of the parameters Control and Actual, especially
- -- since the comments above refer to actuals in the plural ???
+ -- If a function call given by Actual is tag-indeterminate, its controlling
+ -- argument is found in the context, given by Control: either from an
+ -- operand of an enclosing call, or the left-hand side of the enclosing
+ -- assignment statement. The tag of Control will be propagated recursively
+ -- to Actual and to its tag-indeterminate operands, if any.
end Sem_Disp;
diff --git a/gcc/ada/sem_dist.adb b/gcc/ada/sem_dist.adb
index 4ee6e8b..e3075f7 100644
--- a/gcc/ada/sem_dist.adb
+++ b/gcc/ada/sem_dist.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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,28 +23,32 @@
-- --
------------------------------------------------------------------------------
-with Atree; use Atree;
-with Casing; use Casing;
-with Einfo; use Einfo;
-with Errout; use Errout;
-with Exp_Dist; use Exp_Dist;
-with Exp_Tss; use Exp_Tss;
-with Nlists; use Nlists;
-with Nmake; use Nmake;
-with Namet; use Namet;
-with Opt; use Opt;
-with Rtsfind; use Rtsfind;
-with Sem; use Sem;
-with Sem_Aux; use Sem_Aux;
-with Sem_Disp; use Sem_Disp;
-with Sem_Eval; use Sem_Eval;
-with Sem_Res; use Sem_Res;
-with Sem_Util; use Sem_Util;
-with Sinfo; use Sinfo;
-with Stand; use Stand;
-with Stringt; use Stringt;
-with Tbuild; use Tbuild;
-with Uintp; use Uintp;
+with Atree; use Atree;
+with Casing; use Casing;
+with Einfo; use Einfo;
+with Einfo.Entities; use Einfo.Entities;
+with Einfo.Utils; use Einfo.Utils;
+with Errout; use Errout;
+with Exp_Dist; use Exp_Dist;
+with Exp_Tss; use Exp_Tss;
+with Nlists; use Nlists;
+with Nmake; use Nmake;
+with Namet; use Namet;
+with Opt; use Opt;
+with Rtsfind; use Rtsfind;
+with Sem; use Sem;
+with Sem_Aux; use Sem_Aux;
+with Sem_Disp; use Sem_Disp;
+with Sem_Eval; use Sem_Eval;
+with Sem_Res; use Sem_Res;
+with Sem_Util; use Sem_Util;
+with Sinfo; use Sinfo;
+with Sinfo.Nodes; use Sinfo.Nodes;
+with Sinfo.Utils; use Sinfo.Utils;
+with Stand; use Stand;
+with Stringt; use Stringt;
+with Tbuild; use Tbuild;
+with Uintp; use Uintp;
package body Sem_Dist is
@@ -656,7 +660,7 @@ package body Sem_Dist is
-- Corresponding_Remote_Type attribute, whose presence indicates that
-- this is the record type used to implement a RAS.
- Set_Ekind (Fat_Type, E_Record_Type);
+ Mutate_Ekind (Fat_Type, E_Record_Type);
Set_Corresponding_Remote_Type (Fat_Type, User_Type);
Insert_After_And_Analyze (Subpkg_Body, Fat_Type_Decl);
diff --git a/gcc/ada/sem_dist.ads b/gcc/ada/sem_dist.ads
index cf40429..75dfad5 100644
--- a/gcc/ada/sem_dist.ads
+++ b/gcc/ada/sem_dist.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute 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 89b6e13..f6edcac 100644
--- a/gcc/ada/sem_elab.adb
+++ b/gcc/ada/sem_elab.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1997-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1997-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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,43 +23,47 @@
-- --
------------------------------------------------------------------------------
-with ALI; use ALI;
-with Atree; use Atree;
-with Checks; use Checks;
-with Debug; use Debug;
-with Einfo; use Einfo;
-with Elists; use Elists;
-with Errout; use Errout;
-with Exp_Ch11; use Exp_Ch11;
-with Exp_Tss; use Exp_Tss;
-with Exp_Util; use Exp_Util;
-with Expander; use Expander;
-with Lib; use Lib;
-with Lib.Load; use Lib.Load;
-with Namet; use Namet;
-with Nlists; use Nlists;
-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;
-with Sem_Cat; use Sem_Cat;
-with Sem_Ch7; use Sem_Ch7;
-with Sem_Ch8; use Sem_Ch8;
-with Sem_Disp; use Sem_Disp;
-with Sem_Prag; use Sem_Prag;
-with Sem_Util; use Sem_Util;
-with Sinfo; use Sinfo;
-with Sinput; use Sinput;
-with Snames; use Snames;
-with Stand; use Stand;
+with ALI; use ALI;
+with Atree; use Atree;
+with Checks; use Checks;
+with Debug; use Debug;
+with Einfo; use Einfo;
+with Einfo.Entities; use Einfo.Entities;
+with Einfo.Utils; use Einfo.Utils;
+with Elists; use Elists;
+with Errout; use Errout;
+with Exp_Ch11; use Exp_Ch11;
+with Exp_Tss; use Exp_Tss;
+with Exp_Util; use Exp_Util;
+with Expander; use Expander;
+with Lib; use Lib;
+with Lib.Load; use Lib.Load;
+with Namet; use Namet;
+with Nlists; use Nlists;
+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;
+with Sem_Cat; use Sem_Cat;
+with Sem_Ch7; use Sem_Ch7;
+with Sem_Ch8; use Sem_Ch8;
+with Sem_Disp; use Sem_Disp;
+with Sem_Prag; use Sem_Prag;
+with Sem_Util; use Sem_Util;
+with Sinfo; use Sinfo;
+with Sinfo.Nodes; use Sinfo.Nodes;
+with Sinfo.Utils; use Sinfo.Utils;
+with Sinput; use Sinput;
+with Snames; use Snames;
+with Stand; use Stand;
with Table;
-with Tbuild; use Tbuild;
-with Uintp; use Uintp;
-with Uname; use Uname;
+with Tbuild; use Tbuild;
+with Uintp; use Uintp;
+with Uname; use Uname;
with GNAT; use GNAT;
with GNAT.Dynamic_HTables; use GNAT.Dynamic_HTables;
@@ -3758,10 +3762,10 @@ 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
+ -- Ada 2022 (AI12-0175): Calls to certain functions that are essentially
-- unchecked conversions are preelaborable.
- if Ada_Version >= Ada_2020 then
+ if Ada_Version >= Ada_2022 then
Set_Is_Preelaborable_Call (Marker, Is_Preelaborable_Construct (N));
else
Set_Is_Preelaborable_Call (Marker, False);
@@ -8873,10 +8877,10 @@ package body Sem_Elab is
Error_Msg_Warn := GNAT_Mode;
- -- Ada 2020 (AI12-0175): Calls to certain functions that are essentially
+ -- Ada 2022 (AI12-0175): Calls to certain functions that are essentially
-- unchecked conversions are preelaborable.
- if Ada_Version >= Ada_2020 then
+ if Ada_Version >= Ada_2022 then
Error_Msg_N
("<<non-preelaborable call not allowed in preelaborated unit", N);
else
@@ -11883,7 +11887,7 @@ package body Sem_Elab is
-- Partially decorate the elaboration procedure because it will not
-- be insertred into the tree and analyzed.
- Set_Ekind (Proc_Id, E_Procedure);
+ Mutate_Ekind (Proc_Id, E_Procedure);
Set_Etype (Proc_Id, Standard_Void_Type);
Set_Scope (Proc_Id, Unique_Entity (Main_Unit_Entity));
@@ -12008,7 +12012,7 @@ package body Sem_Elab is
-- it will not be inserted into the tree and analyzed.
Task_Obj := Make_Temporary (Loc, 'T');
- Set_Ekind (Task_Obj, E_Variable);
+ Mutate_Ekind (Task_Obj, E_Variable);
Set_Etype (Task_Obj, Task_Typ);
-- Associate the dummy task object with the activation call
@@ -15121,7 +15125,7 @@ package body Sem_Elab is
Inst_Rep : Scenario_Rep_Id;
In_State : Processing_In_State);
pragma Inline (Process_SPARK_Instantiation);
- -- Verify that instanciation Inst does not precede the generic body it
+ -- Verify that instantiation Inst does not precede the generic body it
-- instantiates (SPARK RM 7.7(6)). Inst_Rep is the representation of the
-- instantiation. In_State is the current state of the Processing phase.
@@ -17554,14 +17558,14 @@ 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
+ -- Ada 2022 (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 not (Ada_Version >= Ada_2022
and then Is_Preelaborable_Construct (N))
then
Error_Preelaborated_Call (N);
diff --git a/gcc/ada/sem_elab.ads b/gcc/ada/sem_elab.ads
index a703a8a..1252a46 100644
--- a/gcc/ada/sem_elab.ads
+++ b/gcc/ada/sem_elab.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1997-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1997-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute 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 d693a8d..c08686d 100644
--- a/gcc/ada/sem_elim.adb
+++ b/gcc/ada/sem_elim.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1997-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1997-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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,25 +23,28 @@
-- --
------------------------------------------------------------------------------
-with Atree; use Atree;
-with Einfo; use Einfo;
-with Errout; use Errout;
-with Lib; use Lib;
-with Namet; use Namet;
-with Nlists; use Nlists;
-with Opt; use Opt;
-with Sem; use Sem;
-with Sem_Aux; use Sem_Aux;
-with Sem_Prag; use Sem_Prag;
-with Sem_Util; use Sem_Util;
-with Sinput; use Sinput;
-with Sinfo; use Sinfo;
-with Snames; use Snames;
-with Stand; use Stand;
-with Stringt; use Stringt;
+with Atree; use Atree;
+with Einfo; use Einfo;
+with Einfo.Entities; use Einfo.Entities;
+with Einfo.Utils; use Einfo.Utils;
+with Errout; use Errout;
+with Lib; use Lib;
+with Namet; use Namet;
+with Nlists; use Nlists;
+with Opt; use Opt;
+with Sem; use Sem;
+with Sem_Aux; use Sem_Aux;
+with Sem_Prag; use Sem_Prag;
+with Sem_Util; use Sem_Util;
+with Sinput; use Sinput;
+with Sinfo; use Sinfo;
+with Sinfo.Nodes; use Sinfo.Nodes;
+with Snames; use Snames;
+with Stand; use Stand;
+with Stringt; use Stringt;
with Table;
-with GNAT.HTable; use GNAT.HTable;
+with GNAT.HTable; use GNAT.HTable;
package body Sem_Elim is
@@ -783,7 +786,7 @@ package body Sem_Elim is
and then Is_Concurrent_Record_Type (Etype (First_Entity (E)))
then
Error_Msg_NE
- ("cannot reference eliminated protected subprogram", N, E);
+ ("cannot reference eliminated protected subprogram&", N, E);
-- Otherwise should not fall through, entry should be in table
diff --git a/gcc/ada/sem_elim.ads b/gcc/ada/sem_elim.ads
index cb1bf8b..b9c73f4 100644
--- a/gcc/ada/sem_elim.ads
+++ b/gcc/ada/sem_elim.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1997-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1997-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute 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 8d47589..a3a2864 100644
--- a/gcc/ada/sem_eval.adb
+++ b/gcc/ada/sem_eval.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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,39 +23,43 @@
-- --
------------------------------------------------------------------------------
-with Aspects; use Aspects;
-with Atree; use Atree;
-with Checks; use Checks;
-with Debug; use Debug;
-with Einfo; use Einfo;
-with Elists; use Elists;
-with Errout; use Errout;
-with Eval_Fat; use Eval_Fat;
-with Exp_Util; use Exp_Util;
-with Freeze; use Freeze;
-with Lib; use Lib;
-with Namet; use Namet;
-with Nmake; use Nmake;
-with Nlists; use Nlists;
-with Opt; use Opt;
-with Par_SCO; use Par_SCO;
-with Rtsfind; use Rtsfind;
-with Sem; use Sem;
-with Sem_Aux; use Sem_Aux;
-with Sem_Cat; use Sem_Cat;
-with Sem_Ch3; use Sem_Ch3;
-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;
-with Sem_Warn; use Sem_Warn;
-with Sinfo; use Sinfo;
-with Snames; use Snames;
-with Stand; use Stand;
-with Stringt; use Stringt;
-with Tbuild; use Tbuild;
+with Aspects; use Aspects;
+with Atree; use Atree;
+with Checks; use Checks;
+with Debug; use Debug;
+with Einfo; use Einfo;
+with Einfo.Entities; use Einfo.Entities;
+with Einfo.Utils; use Einfo.Utils;
+with Elists; use Elists;
+with Errout; use Errout;
+with Eval_Fat; use Eval_Fat;
+with Exp_Util; use Exp_Util;
+with Freeze; use Freeze;
+with Lib; use Lib;
+with Namet; use Namet;
+with Nmake; use Nmake;
+with Nlists; use Nlists;
+with Opt; use Opt;
+with Par_SCO; use Par_SCO;
+with Rtsfind; use Rtsfind;
+with Sem; use Sem;
+with Sem_Aux; use Sem_Aux;
+with Sem_Cat; use Sem_Cat;
+with Sem_Ch3; use Sem_Ch3;
+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;
+with Sem_Warn; use Sem_Warn;
+with Sinfo; use Sinfo;
+with Sinfo.Nodes; use Sinfo.Nodes;
+with Sinfo.Utils; use Sinfo.Utils;
+with Snames; use Snames;
+with Stand; use Stand;
+with Stringt; use Stringt;
+with Tbuild; use Tbuild;
package body Sem_Eval is
@@ -136,12 +140,22 @@ package body Sem_Eval is
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)).
+ -- function is a potentially static function (see RM2022 6.8(5.3)).
-----------------------
-- Local Subprograms --
-----------------------
+ procedure Check_Non_Static_Context_For_Overflow
+ (N : Node_Id;
+ Stat : Boolean;
+ Result : Uint);
+ -- For a signed integer type, check non-static overflow in Result when
+ -- Stat is False. This applies also inside inlined code, where the static
+ -- property may be an effect of the inlining, which should not be allowed
+ -- to remove run-time checks (whether during compilation, or even more
+ -- crucially in the special inlining-for-proof in GNATprove mode).
+
function Choice_Matches
(Expr : Node_Id;
Choice : Node_Id) return Match_Result;
@@ -649,6 +663,34 @@ package body Sem_Eval is
end if;
end Check_Non_Static_Context;
+ -------------------------------------------
+ -- Check_Non_Static_Context_For_Overflow --
+ -------------------------------------------
+
+ procedure Check_Non_Static_Context_For_Overflow
+ (N : Node_Id;
+ Stat : Boolean;
+ Result : Uint)
+ is
+ begin
+ if (not Stat or else In_Inlined_Body)
+ and then Is_Signed_Integer_Type (Etype (N))
+ then
+ declare
+ BT : constant Entity_Id := Base_Type (Etype (N));
+ Lo : constant Uint := Expr_Value (Type_Low_Bound (BT));
+ Hi : constant Uint := Expr_Value (Type_High_Bound (BT));
+ begin
+ if Result < Lo or else Result > Hi then
+ Apply_Compile_Time_Constraint_Error
+ (N, "value not in range of }??",
+ CE_Overflow_Check_Failed,
+ Ent => BT);
+ end if;
+ end;
+ end if;
+ end Check_Non_Static_Context_For_Overflow;
+
---------------------------------
-- Check_String_Literal_Length --
---------------------------------
@@ -2086,7 +2128,6 @@ package body Sem_Eval is
Apply_Compile_Time_Constraint_Error
(N, "division by zero", CE_Divide_By_Zero,
Warn => not Stat or SPARK_Mode = On);
- Set_Raises_Constraint_Error (N);
return;
-- Otherwise we can do the division
@@ -2143,25 +2184,10 @@ package body Sem_Eval is
if Is_Modular_Integer_Type (Ltype) then
Result := Result mod Modulus (Ltype);
-
- -- For a signed integer type, check non-static overflow
-
- elsif (not Stat) and then Is_Signed_Integer_Type (Ltype) then
- declare
- BT : constant Entity_Id := Base_Type (Ltype);
- Lo : constant Uint := Expr_Value (Type_Low_Bound (BT));
- Hi : constant Uint := Expr_Value (Type_High_Bound (BT));
- begin
- if Result < Lo or else Result > Hi then
- Apply_Compile_Time_Constraint_Error
- (N, "value not in range of }??",
- CE_Overflow_Check_Failed,
- Ent => BT);
- return;
- end if;
- end;
end if;
+ Check_Non_Static_Context_For_Overflow (N, Stat, Result);
+
-- If we get here we can fold the result
Fold_Uint (N, Result, Stat);
@@ -2277,7 +2303,7 @@ package body Sem_Eval is
then
Eval_Intrinsic_Call (N, Entity (Name (N)));
- -- Ada 202x (AI12-0075): If checking for potentially static expressions
+ -- Ada 2022 (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
@@ -2568,7 +2594,7 @@ package body Sem_Eval is
return;
end if;
- -- Ada 202x (AI12-0075): If checking for potentially static expressions
+ -- Ada 2022 (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)
@@ -2969,10 +2995,12 @@ package body Sem_Eval is
-- static if both operands are potentially static (RM 4.9(7), 4.9(20)).
procedure Eval_Logical_Op (N : Node_Id) is
- Left : constant Node_Id := Left_Opnd (N);
- Right : constant Node_Id := Right_Opnd (N);
- Stat : Boolean;
- Fold : Boolean;
+ Left : constant Node_Id := Left_Opnd (N);
+ Right : constant Node_Id := Right_Opnd (N);
+ Left_Int : Uint := No_Uint;
+ Right_Int : Uint := No_Uint;
+ Stat : Boolean;
+ Fold : Boolean;
begin
-- If not foldable we are done
@@ -2985,64 +3013,88 @@ package body Sem_Eval is
-- Compile time evaluation of logical operation
- declare
- Left_Int : constant Uint := Expr_Value (Left);
- Right_Int : constant Uint := Expr_Value (Right);
+ if Is_Modular_Integer_Type (Etype (N)) then
+ Left_Int := Expr_Value (Left);
+ Right_Int := Expr_Value (Right);
- begin
- if Is_Modular_Integer_Type (Etype (N)) then
- declare
- Left_Bits : Bits (0 .. UI_To_Int (Esize (Etype (N))) - 1);
- Right_Bits : Bits (0 .. UI_To_Int (Esize (Etype (N))) - 1);
+ declare
+ Left_Bits : Bits (0 .. UI_To_Int (Esize (Etype (N))) - 1);
+ Right_Bits : Bits (0 .. UI_To_Int (Esize (Etype (N))) - 1);
- begin
- To_Bits (Left_Int, Left_Bits);
- To_Bits (Right_Int, Right_Bits);
+ begin
+ To_Bits (Left_Int, Left_Bits);
+ To_Bits (Right_Int, Right_Bits);
- -- Note: should really be able to use array ops instead of
- -- 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.
+ -- Note: should really be able to use array ops instead of
+ -- 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
- Left_Bits (J) := Left_Bits (J) and Right_Bits (J);
- end loop;
+ if Nkind (N) = N_Op_And then
+ for J in Left_Bits'Range loop
+ Left_Bits (J) := Left_Bits (J) and Right_Bits (J);
+ end loop;
- elsif Nkind (N) = N_Op_Or then
- for J in Left_Bits'Range loop
- Left_Bits (J) := Left_Bits (J) or Right_Bits (J);
- end loop;
+ elsif Nkind (N) = N_Op_Or then
+ for J in Left_Bits'Range loop
+ Left_Bits (J) := Left_Bits (J) or Right_Bits (J);
+ end loop;
- else
- pragma Assert (Nkind (N) = N_Op_Xor);
+ else
+ pragma Assert (Nkind (N) = N_Op_Xor);
- for J in Left_Bits'Range loop
- Left_Bits (J) := Left_Bits (J) xor Right_Bits (J);
- end loop;
- end if;
+ for J in Left_Bits'Range loop
+ Left_Bits (J) := Left_Bits (J) xor Right_Bits (J);
+ end loop;
+ end if;
- Fold_Uint (N, From_Bits (Left_Bits, Etype (N)), Stat);
- end;
+ Fold_Uint (N, From_Bits (Left_Bits, Etype (N)), Stat);
+ end;
- else
- pragma Assert (Is_Boolean_Type (Etype (N)));
+ else
+ pragma Assert (Is_Boolean_Type (Etype (N)));
- if Nkind (N) = N_Op_And then
+ if Compile_Time_Known_Value (Left)
+ and then Compile_Time_Known_Value (Right)
+ then
+ Right_Int := Expr_Value (Right);
+ Left_Int := Expr_Value (Left);
+ end if;
+
+ if Nkind (N) = N_Op_And then
+
+ -- If Left or Right are not compile time known values it means
+ -- that the result is always False as per
+ -- Test_Expression_Is_Foldable.
+ -- Note that in this case, both Right_Int and Left_Int are set
+ -- to No_Uint, so need to test for both.
+
+ if Right_Int = No_Uint then
+ Fold_Uint (N, Uint_0, Stat);
+ else
Fold_Uint (N,
Test (Is_True (Left_Int) and then Is_True (Right_Int)), Stat);
+ end if;
+ elsif Nkind (N) = N_Op_Or then
- elsif Nkind (N) = N_Op_Or then
- Fold_Uint (N,
- Test (Is_True (Left_Int) or else Is_True (Right_Int)), Stat);
+ -- If Left or Right are not compile time known values it means
+ -- that the result is always True. as per
+ -- Test_Expression_Is_Foldable.
+ -- Note that in this case, both Right_Int and Left_Int are set
+ -- to No_Uint, so need to test for both.
+ if Right_Int = No_Uint then
+ Fold_Uint (N, Uint_1, Stat);
else
- pragma Assert (Nkind (N) = N_Op_Xor);
Fold_Uint (N,
- Test (Is_True (Left_Int) xor Is_True (Right_Int)), Stat);
+ Test (Is_True (Left_Int) or else Is_True (Right_Int)), Stat);
end if;
+ else
+ pragma Assert (Nkind (N) = N_Op_Xor);
+ Fold_Uint (N,
+ Test (Is_True (Left_Int) xor Is_True (Right_Int)), Stat);
end if;
- end;
+ end if;
end Eval_Logical_Op;
------------------------
@@ -3202,6 +3254,8 @@ package body Sem_Eval is
Result := Result mod Modulus (Etype (N));
end if;
+ Check_Non_Static_Context_For_Overflow (N, Stat, Result);
+
Fold_Uint (N, Result, Stat);
end if;
end;
@@ -3408,7 +3462,7 @@ 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 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.
+ -- The string case was relaxed in Ada 2022, 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
@@ -3749,12 +3803,12 @@ package body Sem_Eval is
and then Right_Len /= Uint_Minus_1
and then Left_Len /= Right_Len
then
- -- AI12-0201: comparison of string is static in Ada 202x
+ -- AI12-0201: comparison of string is static in Ada 2022
Fold_Uint
(N,
Test (Nkind (N) = N_Op_Ne),
- Static => Ada_Version >= Ada_2020
+ Static => Ada_Version >= Ada_2022
and then Is_String_Type (Left_Typ));
Warn_On_Known_Condition (N);
return;
@@ -3774,16 +3828,16 @@ package body Sem_Eval is
(N, Left, Right, Is_Static_Expression, Fold);
-- Comparisons of scalars can give static results.
- -- In addition starting with Ada 202x (AI12-0201), comparison of strings
+ -- In addition starting with Ada 2022 (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.
- -- ??? 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.
+ -- 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
+ -- 2022 has relaxed the rules, this doesn't really matter.
if Is_String_Type (Left_Typ) then
- if Ada_Version < Ada_2020
+ if Ada_Version < Ada_2022
and then (Comes_From_Source (N)
or else Nkind (N) not in N_Op_Eq | N_Op_Ne)
then
@@ -3830,6 +3884,11 @@ package body Sem_Eval is
-----------------------------
procedure Eval_Selected_Component (N : Node_Id) is
+ Node : Node_Id;
+ Comp : Node_Id;
+ C : Node_Id;
+ Nam : Name_Id;
+
begin
-- If an attribute reference or a LHS, nothing to do.
-- Also do not fold if N is an [in] out subprogram parameter.
@@ -3839,7 +3898,34 @@ package body Sem_Eval is
and then Is_LHS (N) = No
and then not Is_Actual_Out_Or_In_Out_Parameter (N)
then
- Fold (N);
+ -- Simplify a selected_component on an aggregate by extracting
+ -- the field directly.
+
+ Node := Unqualify (Prefix (N));
+
+ if Nkind (Node) = N_Aggregate
+ and then Compile_Time_Known_Aggregate (Node)
+ then
+ Comp := First (Component_Associations (Node));
+ Nam := Chars (Selector_Name (N));
+
+ while Present (Comp) loop
+ C := First (Choices (Comp));
+
+ while Present (C) loop
+ if Chars (C) = Nam then
+ Rewrite (N, Relocate_Node (Expression (Comp)));
+ return;
+ end if;
+
+ Next (C);
+ end loop;
+
+ Next (Comp);
+ end loop;
+ else
+ Fold (N);
+ end if;
end if;
end Eval_Selected_Component;
@@ -4047,7 +4133,7 @@ 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.
+ -- up to Ada 2012. AI12-0201 changes that with Ada 2022.
if Nkind (Original_Node (N)) = N_Type_Conversion
and then Ada_Version <= Ada_2012
@@ -4079,7 +4165,7 @@ package body Sem_Eval is
Len := String_Length (Strval (N));
- if UI_From_Int (Len) > String_Type_Len (Bas) then
+ if Len > String_Type_Len (Bas) then
-- Issue message. Note that this message is a warning if the
-- string literal is not marked as static (happens in some cases
@@ -4209,13 +4295,13 @@ package body Sem_Eval is
-- Conversion_OK is set, in which case it counts as integer.
-- Fold conversion, case of string type. The result is static starting
- -- with Ada 202x (AI12-0201).
+ -- with Ada 2022 (AI12-0201).
if Is_String_Type (Target_Type) then
Fold_Str
(N,
Strval (Get_String_Val (Operand)),
- Static => Ada_Version >= Ada_2020);
+ Static => Ada_Version >= Ada_2022);
return;
-- Fold conversion, case of integer target type
@@ -4306,10 +4392,7 @@ package body Sem_Eval is
return;
end if;
- if Etype (Right) = Universal_Integer
- or else
- Etype (Right) = Universal_Real
- then
+ if Is_Universal_Numeric_Type (Etype (Right)) then
Otype := Find_Universal_Operator_Type (N);
end if;
@@ -4343,6 +4426,8 @@ package body Sem_Eval is
Result := abs Rint;
end if;
+ Check_Non_Static_Context_For_Overflow (N, Stat, Result);
+
Fold_Uint (N, Result, Stat);
end;
@@ -4928,7 +5013,7 @@ package body Sem_Eval is
end if;
end Check_Elab_Call;
- Modulus : Uint;
+ Modulus, Val : Uint;
begin
if Compile_Time_Known_Value (Left)
@@ -4939,23 +5024,25 @@ package body Sem_Eval is
if Op = N_Op_Shift_Left then
Check_Elab_Call;
- declare
- Modulus : Uint;
- begin
- if Is_Modular_Integer_Type (Typ) then
- Modulus := Einfo.Modulus (Typ);
- else
- Modulus := Uint_2 ** RM_Size (Typ);
- end if;
+ if Is_Modular_Integer_Type (Typ) then
+ Modulus := Einfo.Entities.Modulus (Typ);
+ else
+ Modulus := Uint_2 ** RM_Size (Typ);
+ end if;
- -- Fold Shift_Left (X, Y) by computing (X * 2**Y) rem modulus
+ -- Fold Shift_Left (X, Y) by computing
+ -- (X * 2**Y) rem modulus [- Modulus]
- Fold_Uint
- (N,
- (Expr_Value (Left) * (Uint_2 ** Expr_Value (Right)))
- rem Modulus,
- Static => Static);
- end;
+ Val := (Expr_Value (Left) * (Uint_2 ** Expr_Value (Right)))
+ rem Modulus;
+
+ if Is_Modular_Integer_Type (Typ)
+ or else Val < Modulus / Uint_2
+ then
+ Fold_Uint (N, Val, Static => Static);
+ else
+ Fold_Uint (N, Val - Modulus, Static => Static);
+ end if;
elsif Op = N_Op_Shift_Right then
Check_Elab_Call;
@@ -4966,7 +5053,7 @@ package body Sem_Eval is
Fold_Uint (N, Expr_Value (Left), Static => Static);
else
if Is_Modular_Integer_Type (Typ) then
- Modulus := Einfo.Modulus (Typ);
+ Modulus := Einfo.Entities.Modulus (Typ);
else
Modulus := Uint_2 ** RM_Size (Typ);
end if;
@@ -4987,10 +5074,10 @@ package body Sem_Eval is
Check_Elab_Call;
declare
- Two_Y : constant Uint := Uint_2 ** Expr_Value (Right);
+ Two_Y : constant Uint := Uint_2 ** Expr_Value (Right);
begin
if Is_Modular_Integer_Type (Typ) then
- Modulus := Einfo.Modulus (Typ);
+ Modulus := Einfo.Entities.Modulus (Typ);
else
Modulus := Uint_2 ** RM_Size (Typ);
end if;
@@ -5494,23 +5581,16 @@ package body Sem_Eval is
return False;
end if;
- Anc_Subt := Ancestor_Subtype (Typ);
-
- if Anc_Subt = Empty then
- Anc_Subt := Base_T;
- end if;
-
- if Is_Generic_Type (Root_Type (Base_T))
- or else Is_Generic_Actual_Type (Base_T)
- then
- return False;
+ -- Then, check if the subtype is strictly static. This takes care of
+ -- checking for generics and predicates.
- elsif Has_Dynamic_Predicate_Aspect (Typ) then
+ if not Is_Static_Subtype (Typ) then
return False;
+ end if;
-- String types
- elsif Is_String_Type (Typ) then
+ if Is_String_Type (Typ) then
return
Ekind (Typ) = E_String_Literal_Subtype
or else
@@ -5524,6 +5604,12 @@ package body Sem_Eval is
return True;
else
+ Anc_Subt := Ancestor_Subtype (Typ);
+
+ if No (Anc_Subt) then
+ Anc_Subt := Base_T;
+ end if;
+
-- Scalar_Range (Typ) might be an N_Subtype_Indication, so use
-- Get_Type_{Low,High}_Bound.
@@ -6045,7 +6131,9 @@ package body Sem_Eval is
-- No message if we are dealing with System.Priority values in
-- CodePeer mode where the target runtime may have more priorities.
- elsif not CodePeer_Mode or else Etype (N) /= RTE (RE_Priority) then
+ elsif not CodePeer_Mode
+ or else not Is_RTE (Etype (N), RE_Priority)
+ then
-- Determine if the out-of-range violation constitutes a warning
-- or an error based on context, according to RM 4.9 (34/3).
@@ -6135,7 +6223,7 @@ package body Sem_Eval is
end;
else
- -- TBD: Implement Interval_Lists for real types
+ -- ??? Need to implement Interval_Lists for real types
return False;
end if;
@@ -6393,11 +6481,10 @@ package body Sem_Eval is
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.
+ -- Verify that we only start/stop checking for a potentially static
+ -- expression and do not start or stop it twice in a row.
- pragma Assert
- (not Checking_For_Potentially_Static_Expression or else not Value);
+ pragma Assert (Checking_For_Potentially_Static_Expression /= Value);
Checking_For_Potentially_Static_Expression := Value;
end Set_Checking_Potentially_Static_Expression;
@@ -6535,7 +6622,7 @@ package body Sem_Eval is
-- match if they are set (unless checking an actual for a formal derived
-- type). The use of 'Object_Size can cause this to be false even if the
-- types would otherwise match in the Ada 95 RM sense, but this deviation
- -- is adopted by AI12-059 which introduces Object_Size in Ada 2020.
+ -- is adopted by AI12-059 which introduces Object_Size in Ada 2022.
function Subtypes_Statically_Match
(T1 : Entity_Id;
@@ -7131,6 +7218,38 @@ package body Sem_Eval is
and then Compile_Time_Known_Value (Op2);
end if;
+ if not Fold
+ and then not Is_Modular_Integer_Type (Etype (N))
+ then
+ case Nkind (N) is
+ when N_Op_And =>
+
+ -- (False and XXX) = (XXX and False) = False
+
+ Fold :=
+ (Compile_Time_Known_Value (Op1)
+ and then Is_False (Expr_Value (Op1))
+ and then Side_Effect_Free (Op2))
+ or else (Compile_Time_Known_Value (Op2)
+ and then Is_False (Expr_Value (Op2))
+ and then Side_Effect_Free (Op1));
+
+ when N_Op_Or =>
+
+ -- (True and XXX) = (XXX and True) = True
+
+ Fold :=
+ (Compile_Time_Known_Value (Op1)
+ and then Is_True (Expr_Value (Op1))
+ and then Side_Effect_Free (Op2))
+ or else (Compile_Time_Known_Value (Op2)
+ and then Is_True (Expr_Value (Op2))
+ and then Side_Effect_Free (Op1));
+
+ when others => null;
+ end case;
+ end if;
+
return;
-- Else result is static and foldable. Both operands are static, and
@@ -7182,7 +7301,7 @@ package body Sem_Eval is
-- Universal types have no range limits, so always in range
- elsif Typ = Universal_Integer or else Typ = Universal_Real then
+ elsif Is_Universal_Numeric_Type (Typ) then
return In_Range;
-- Never known if not scalar type. Don't know if this can actually
diff --git a/gcc/ada/sem_eval.ads b/gcc/ada/sem_eval.ads
index 972cee6..5e1c2cb 100644
--- a/gcc/ada/sem_eval.ads
+++ b/gcc/ada/sem_eval.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -556,8 +556,7 @@ package Sem_Eval is
-- messages must always point to the same location as the parent message.
procedure Initialize;
- -- Initializes the internal data structures. Must be called before each
- -- separate main program unit (e.g. in a GNSA/ASIS context).
+ -- Initializes the internal data structures
private
-- The Eval routines are all marked inline, since they are called once
diff --git a/gcc/ada/sem_intr.adb b/gcc/ada/sem_intr.adb
index f3d9f44..ebedc0c 100644
--- a/gcc/ada/sem_intr.adb
+++ b/gcc/ada/sem_intr.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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,21 +25,25 @@
-- Processing for intrinsic subprogram declarations
-with Atree; use Atree;
-with Einfo; use Einfo;
-with Errout; use Errout;
-with Lib; use Lib;
-with Namet; use Namet;
-with Opt; use Opt;
-with Sem_Aux; use Sem_Aux;
-with Sem_Eval; use Sem_Eval;
-with Sem_Util; use Sem_Util;
-with Sinfo; use Sinfo;
-with Snames; use Snames;
-with Stand; use Stand;
-with Stringt; use Stringt;
-with Ttypes; use Ttypes;
-with Uintp; use Uintp;
+with Atree; use Atree;
+with Einfo; use Einfo;
+with Einfo.Entities; use Einfo.Entities;
+with Einfo.Utils; use Einfo.Utils;
+with Errout; use Errout;
+with Lib; use Lib;
+with Namet; use Namet;
+with Opt; use Opt;
+with Sem_Aux; use Sem_Aux;
+with Sem_Eval; use Sem_Eval;
+with Sem_Util; use Sem_Util;
+with Sinfo; use Sinfo;
+with Sinfo.Nodes; use Sinfo.Nodes;
+with Sinfo.Utils; use Sinfo.Utils;
+with Snames; use Snames;
+with Stand; use Stand;
+with Stringt; use Stringt;
+with Ttypes; use Ttypes;
+with Uintp; use Uintp;
package body Sem_Intr is
diff --git a/gcc/ada/sem_intr.ads b/gcc/ada/sem_intr.ads
index 224008c..9afa527 100644
--- a/gcc/ada/sem_intr.ads
+++ b/gcc/ada/sem_intr.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute 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 4130cd8..3bc6ce0 100644
--- a/gcc/ada/sem_mech.adb
+++ b/gcc/ada/sem_mech.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1996-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1996-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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,14 +23,17 @@
-- --
------------------------------------------------------------------------------
-with Atree; use Atree;
-with Einfo; use Einfo;
-with Errout; use Errout;
-with Namet; use Namet;
-with Sem; use Sem;
-with Sem_Aux; use Sem_Aux;
-with Sinfo; use Sinfo;
-with Snames; use Snames;
+with Atree; use Atree;
+with Einfo; use Einfo;
+with Einfo.Entities; use Einfo.Entities;
+with Einfo.Utils; use Einfo.Utils;
+with Errout; use Errout;
+with Namet; use Namet;
+with Sem; use Sem;
+with Sem_Aux; use Sem_Aux;
+with Sinfo; use Sinfo;
+with Sinfo.Nodes; use Sinfo.Nodes;
+with Snames; use Snames;
package body Sem_Mech is
diff --git a/gcc/ada/sem_mech.ads b/gcc/ada/sem_mech.ads
index 81b8c25..ceadc42 100644
--- a/gcc/ada/sem_mech.ads
+++ b/gcc/ada/sem_mech.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1996-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1996-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute 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 3ef5e82..0ff4e49 100644
--- a/gcc/ada/sem_prag.adb
+++ b/gcc/ada/sem_prag.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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,67 +29,71 @@
-- to complete the syntax checks. Certain pragmas are handled partially or
-- completely by the parser (see Par.Prag for further details).
-with Aspects; use Aspects;
-with Atree; use Atree;
-with Casing; use Casing;
-with Checks; use Checks;
-with Contracts; use Contracts;
-with Csets; use Csets;
-with Debug; use Debug;
-with Einfo; use Einfo;
-with Elists; use Elists;
-with Errout; use Errout;
-with Exp_Dist; use Exp_Dist;
-with Exp_Util; use Exp_Util;
-with Expander; use Expander;
-with Freeze; use Freeze;
-with Ghost; use Ghost;
-with GNAT_CUDA; use GNAT_CUDA;
-with Gnatvsn; use Gnatvsn;
-with Lib; use Lib;
-with Lib.Writ; use Lib.Writ;
-with Lib.Xref; use Lib.Xref;
-with Namet.Sp; use Namet.Sp;
-with Nlists; use Nlists;
-with Nmake; use Nmake;
-with Output; use Output;
-with Par_SCO; use Par_SCO;
-with Restrict; use Restrict;
-with Rident; use Rident;
-with Rtsfind; use Rtsfind;
-with Sem; use Sem;
-with Sem_Aux; use Sem_Aux;
-with Sem_Ch3; use Sem_Ch3;
-with Sem_Ch6; use Sem_Ch6;
-with Sem_Ch8; use Sem_Ch8;
-with Sem_Ch12; use Sem_Ch12;
-with Sem_Ch13; use Sem_Ch13;
-with Sem_Disp; use Sem_Disp;
-with Sem_Dist; use Sem_Dist;
-with Sem_Elab; use Sem_Elab;
-with Sem_Elim; use Sem_Elim;
-with Sem_Eval; use Sem_Eval;
-with Sem_Intr; use Sem_Intr;
-with Sem_Mech; use Sem_Mech;
-with Sem_Res; use Sem_Res;
-with Sem_Type; use Sem_Type;
-with Sem_Util; use Sem_Util;
-with Sem_Warn; use Sem_Warn;
-with Stand; use Stand;
-with Sinfo; use Sinfo;
-with Sinfo.CN; use Sinfo.CN;
-with Sinput; use Sinput;
-with Stringt; use Stringt;
-with Stylesw; use Stylesw;
+with Aspects; use Aspects;
+with Atree; use Atree;
+with Casing; use Casing;
+with Checks; use Checks;
+with Contracts; use Contracts;
+with Csets; use Csets;
+with Debug; use Debug;
+with Einfo; use Einfo;
+with Einfo.Entities; use Einfo.Entities;
+with Einfo.Utils; use Einfo.Utils;
+with Elists; use Elists;
+with Errout; use Errout;
+with Exp_Dist; use Exp_Dist;
+with Exp_Util; use Exp_Util;
+with Expander; use Expander;
+with Freeze; use Freeze;
+with Ghost; use Ghost;
+with GNAT_CUDA; use GNAT_CUDA;
+with Gnatvsn; use Gnatvsn;
+with Lib; use Lib;
+with Lib.Writ; use Lib.Writ;
+with Lib.Xref; use Lib.Xref;
+with Namet.Sp; use Namet.Sp;
+with Nlists; use Nlists;
+with Nmake; use Nmake;
+with Output; use Output;
+with Par_SCO; use Par_SCO;
+with Restrict; use Restrict;
+with Rident; use Rident;
+with Rtsfind; use Rtsfind;
+with Sem; use Sem;
+with Sem_Aux; use Sem_Aux;
+with Sem_Ch3; use Sem_Ch3;
+with Sem_Ch6; use Sem_Ch6;
+with Sem_Ch8; use Sem_Ch8;
+with Sem_Ch12; use Sem_Ch12;
+with Sem_Ch13; use Sem_Ch13;
+with Sem_Disp; use Sem_Disp;
+with Sem_Dist; use Sem_Dist;
+with Sem_Elab; use Sem_Elab;
+with Sem_Elim; use Sem_Elim;
+with Sem_Eval; use Sem_Eval;
+with Sem_Intr; use Sem_Intr;
+with Sem_Mech; use Sem_Mech;
+with Sem_Res; use Sem_Res;
+with Sem_Type; use Sem_Type;
+with Sem_Util; use Sem_Util;
+with Sem_Warn; use Sem_Warn;
+with Stand; use Stand;
+with Sinfo; use Sinfo;
+with Sinfo.Nodes; use Sinfo.Nodes;
+with Sinfo.Utils; use Sinfo.Utils;
+with Sinfo.CN; use Sinfo.CN;
+with Sinput; use Sinput;
+with Stringt; use Stringt;
+with Stylesw; use Stylesw;
with Table;
-with Targparm; use Targparm;
-with Tbuild; use Tbuild;
+with Targparm; use Targparm;
+with Tbuild; use Tbuild;
with Ttypes;
-with Uintp; use Uintp;
-with Uname; use Uname;
-with Urealp; use Urealp;
-with Validsw; use Validsw;
-with Warnsw; use Warnsw;
+with Uintp; use Uintp;
+with Uname; use Uname;
+with Urealp; use Urealp;
+with Validsw; use Validsw;
+with Warnsw; use Warnsw;
with System.Case_Util;
@@ -243,6 +247,7 @@ package body Sem_Prag is
-- Constant_After_Elaboration
-- Effective_Reads
-- Effective_Writers
+ -- No_Caching
-- Part_Of
-- Find the first source declaration or statement found while traversing
-- the previous node chain starting from pragma Prag. If flag Do_Checks is
@@ -566,8 +571,8 @@ package body Sem_Prag is
-- Check that the expression is a proper aggregate (no parentheses)
if Paren_Count (CCases) /= 0 then
- Error_Msg -- CODEFIX
- ("redundant parentheses", First_Sloc (CCases));
+ Error_Msg_F -- CODEFIX
+ ("redundant parentheses", CCases);
end if;
-- Ensure that the formal parameters are visible when analyzing all
@@ -717,9 +722,7 @@ package body Sem_Prag is
elsif Ekind (Item_Id) = E_Constant then
Add_Str_To_Name_Buffer ("constant");
- elsif Ekind (Item_Id) in
- E_Generic_In_Out_Parameter | E_Generic_In_Parameter
- then
+ elsif Is_Formal_Object (Item_Id) then
Add_Str_To_Name_Buffer ("generic parameter");
elsif Is_Formal (Item_Id) then
@@ -1136,6 +1139,17 @@ package body Sem_Prag is
(State_Id => Item_Id,
Ref => Item);
end if;
+
+ elsif Ekind (Item_Id) in E_Constant | E_Variable
+ and then Present (Ultimate_Overlaid_Entity (Item_Id))
+ then
+ SPARK_Msg_NE
+ ("overlaying object & cannot appear in Depends",
+ Item, Item_Id);
+ SPARK_Msg_NE
+ ("\use the overlaid object & instead",
+ Item, Ultimate_Overlaid_Entity (Item_Id));
+ return;
end if;
-- When the item renames an entire object, replace the
@@ -1282,17 +1296,22 @@ package body Sem_Prag is
(Item_Is_Input : out Boolean;
Item_Is_Output : out Boolean)
is
- -- A constant or IN parameter of access-to-variable type should be
+ -- A constant or an IN parameter of a procedure or a protected
+ -- entry, if it is of an access-to-variable type, should be
-- handled like a variable, as the underlying memory pointed-to
-- can be modified. Use Adjusted_Kind to do this adjustment.
Adjusted_Kind : Entity_Kind := Ekind (Item_Id);
begin
- if Ekind (Item_Id) in E_Constant
- | E_Generic_In_Parameter
- | E_In_Parameter
+ if (Ekind (Item_Id) in E_Constant | E_Generic_In_Parameter
+ or else
+ (Ekind (Item_Id) = E_In_Parameter
+ and then Ekind (Scope (Item_Id))
+ not in E_Function | E_Generic_Function))
and then Is_Access_Variable (Etype (Item_Id))
+ and then Ekind (Spec_Id) not in E_Function
+ | E_Generic_Function
then
Adjusted_Kind := E_Variable;
end if;
@@ -1476,8 +1495,6 @@ package body Sem_Prag is
(Item_Is_Input : Boolean;
Item_Is_Output : Boolean)
is
- Error_Msg : Name_Id;
-
begin
Name_Len := 0;
@@ -1490,8 +1507,7 @@ package body Sem_Prag is
Add_Str_To_Name_Buffer
(" & cannot appear in dependence relation");
- Error_Msg := Name_Find;
- SPARK_Msg_NE (Get_Name_String (Error_Msg), Item, Item_Id);
+ SPARK_Msg_NE (To_String (Global_Name_Buffer), Item, Item_Id);
Error_Msg_Name_1 := Chars (Spec_Id);
SPARK_Msg_NE
@@ -1520,8 +1536,8 @@ package body Sem_Prag is
end if;
Add_Str_To_Name_Buffer (" in dependence relation");
- Error_Msg := Name_Find;
- SPARK_Msg_NE (Get_Name_String (Error_Msg), Item, Item_Id);
+
+ SPARK_Msg_NE (To_String (Global_Name_Buffer), Item, Item_Id);
end if;
end Role_Error;
@@ -1573,8 +1589,6 @@ package body Sem_Prag is
-----------------
procedure Usage_Error (Item_Id : Entity_Id) is
- Error_Msg : Name_Id;
-
begin
-- Input case
@@ -1592,8 +1606,7 @@ package body Sem_Prag is
Add_Str_To_Name_Buffer
(" & is missing from input dependence list");
- Error_Msg := Name_Find;
- SPARK_Msg_NE (Get_Name_String (Error_Msg), N, Item_Id);
+ SPARK_Msg_NE (To_String (Global_Name_Buffer), N, Item_Id);
SPARK_Msg_NE
("\add `null ='> &` dependency to ignore this input",
N, Item_Id);
@@ -1608,8 +1621,7 @@ package body Sem_Prag is
Add_Str_To_Name_Buffer
(" & is missing from output dependence list");
- Error_Msg := Name_Find;
- SPARK_Msg_NE (Get_Name_String (Error_Msg), N, Item_Id);
+ SPARK_Msg_NE (To_String (Global_Name_Buffer), N, Item_Id);
end if;
end Usage_Error;
@@ -2386,6 +2398,17 @@ package body Sem_Prag is
elsif Is_Formal_Object (Item_Id) then
null;
+ elsif Ekind (Item_Id) in E_Constant | E_Variable
+ and then Present (Ultimate_Overlaid_Entity (Item_Id))
+ then
+ SPARK_Msg_NE
+ ("overlaying object & cannot appear in Global",
+ Item, Item_Id);
+ SPARK_Msg_NE
+ ("\use the overlaid object & instead",
+ Item, Ultimate_Overlaid_Entity (Item_Id));
+ return;
+
-- The only legal references are those to abstract states,
-- objects and various kinds of constants (SPARK RM 6.1.4(4)).
@@ -2432,10 +2455,13 @@ package body Sem_Prag is
SPARK_Msg_N ("\use its constituents instead", Item);
return;
- -- An external state cannot appear as a global item of a
- -- nonvolatile function (SPARK RM 7.1.3(8)).
+ -- An external state which has Async_Writers or
+ -- Effective_Reads enabled cannot appear as a global item
+ -- of a nonvolatile function (SPARK RM 7.1.3(8)).
elsif Is_External_State (Item_Id)
+ and then (Async_Writers_Enabled (Item_Id)
+ or else Effective_Reads_Enabled (Item_Id))
and then Ekind (Spec_Id) in E_Function | E_Generic_Function
and then not Is_Volatile_Function (Spec_Id)
then
@@ -2456,17 +2482,31 @@ package body Sem_Prag is
-- Constant related checks
- elsif Ekind (Item_Id) = E_Constant
- and then not Is_Access_Type (Etype (Item_Id))
- then
+ elsif Ekind (Item_Id) = E_Constant then
- -- Unless it is of an access type, a constant is a read-only
- -- item, therefore it cannot act as an output.
+ -- Constant is a read-only item, therefore it cannot act as
+ -- an output.
if Global_Mode in Name_In_Out | Name_Output then
- SPARK_Msg_NE
- ("constant & cannot act as output", Item, Item_Id);
- return;
+
+ -- Constant of an access-to-variable type is a read-write
+ -- item in procedures, generic procedures, protected
+ -- entries and tasks.
+
+ if Is_Access_Variable (Etype (Item_Id))
+ and then (Ekind (Spec_Id) in E_Entry
+ | E_Entry_Family
+ | E_Procedure
+ | E_Generic_Procedure
+ | E_Task_Type
+ or else Is_Single_Task_Object (Spec_Id))
+ then
+ null;
+ else
+ SPARK_Msg_NE
+ ("constant & cannot act as output", Item, Item_Id);
+ return;
+ end if;
end if;
-- Loop parameter related checks
@@ -2633,13 +2673,9 @@ package body Sem_Prag is
Context := Anonymous_Object (Context);
end if;
- if (Is_Subprogram (Context)
- or else Ekind (Context) = E_Task_Type
- or else Is_Single_Task_Object (Context))
- and then
- (Present (Get_Pragma (Context, Pragma_Global))
- or else
- Present (Get_Pragma (Context, Pragma_Refined_Global)))
+ if Is_Subprogram_Or_Entry (Context)
+ or else Ekind (Context) = E_Task_Type
+ or else Is_Single_Task_Object (Context)
then
Collect_Subprogram_Inputs_Outputs
(Subp_Id => Context,
@@ -2648,8 +2684,8 @@ package body Sem_Prag is
Global_Seen => Dummy);
-- The item is classified as In_Out or Output but appears as
- -- an Input in an enclosing subprogram or task unit (SPARK
- -- RM 6.1.4(12)).
+ -- an Input or a formal parameter of mode IN in an enclosing
+ -- subprogram or task unit (SPARK RM 6.1.4(13)).
if Appears_In (Inputs, Item_Id)
and then not Appears_In (Outputs, Item_Id)
@@ -2658,7 +2694,7 @@ package body Sem_Prag is
("global item & cannot have mode In_Out or Output",
Item, Item_Id);
- if Is_Subprogram (Context) then
+ if Is_Subprogram_Or_Entry (Context) then
SPARK_Msg_NE
(Fix_Msg (Subp_Id, "\item already appears as input "
& "of subprogram &"), Item, Context);
@@ -2970,6 +3006,16 @@ package body Sem_Prag is
if Item_Id = Any_Id then
null;
+ elsif Ekind (Item_Id) in E_Constant | E_Variable
+ and then Present (Ultimate_Overlaid_Entity (Item_Id))
+ then
+ SPARK_Msg_NE
+ ("overlaying object & cannot appear in Initializes",
+ Item, Item_Id);
+ SPARK_Msg_NE
+ ("\use the overlaid object & instead",
+ Item, Ultimate_Overlaid_Entity (Item_Id));
+
-- The state or variable must be declared in the visible
-- declarations of the package (SPARK RM 7.1.5(7)).
@@ -3094,9 +3140,7 @@ package body Sem_Prag is
-- it is allowed for an initialization item to depend
-- on an input item.
- if Ekind (Input_Id) in E_Generic_In_Out_Parameter
- | E_Generic_In_Parameter
- then
+ if Is_Formal_Object (Input_Id) then
null;
elsif Ekind (Input_Id) in E_Constant | E_Variable
@@ -3114,6 +3158,18 @@ package body Sem_Prag is
end if;
end if;
+ if Ekind (Input_Id) in E_Constant | E_Variable
+ and then Present (Ultimate_Overlaid_Entity (Input_Id))
+ then
+ SPARK_Msg_NE
+ ("overlaying object & cannot appear in Initializes",
+ Input, Input_Id);
+ SPARK_Msg_NE
+ ("\use the overlaid object & instead",
+ Input, Ultimate_Overlaid_Entity (Input_Id));
+ return;
+ end if;
+
-- Detect a duplicate use of the same input item
-- (SPARK RM 7.1.5(5)).
@@ -4074,9 +4130,9 @@ package body Sem_Prag is
procedure Check_Static_Constraint (Constr : Node_Id);
-- Constr is a constraint from an N_Subtype_Indication node from a
- -- component constraint in an Unchecked_Union type. This routine checks
- -- that the constraint is static as required by the restrictions for
- -- Unchecked_Union.
+ -- component constraint in an Unchecked_Union type, a range, or a
+ -- discriminant association. This routine checks that the constraint
+ -- is static as required by the restrictions for Unchecked_Union.
procedure Check_Valid_Configuration_Pragma;
-- Legality checks for placement of a configuration pragma
@@ -4809,10 +4865,10 @@ package body Sem_Prag is
then
null;
- -- For Ada 2020, pre/postconditions can appear on formal subprograms
+ -- For Ada 2022, pre/postconditions can appear on formal subprograms
elsif Nkind (Subp_Decl) = N_Formal_Concrete_Subprogram_Declaration
- and then Ada_Version >= Ada_2020
+ and then Ada_Version >= Ada_2022
then
null;
@@ -6449,11 +6505,6 @@ package body Sem_Prag is
-- Check_Static_Constraint --
-----------------------------
- -- Note: for convenience in writing this procedure, in addition to
- -- the officially (i.e. by spec) allowed argument which is always a
- -- constraint, it also allows ranges and discriminant associations.
- -- Above is not clear ???
-
procedure Check_Static_Constraint (Constr : Node_Id) is
procedure Require_Static (E : Node_Id);
@@ -6884,7 +6935,7 @@ package body Sem_Prag is
Proc : Entity_Id := Empty;
begin
- -- The body of this procedure needs some comments ???
+ -- Perform sanity checks on Name
if not Is_Entity_Name (Name) then
Error_Pragma_Arg
@@ -6900,6 +6951,9 @@ package body Sem_Prag is
("argument of pragma% must be parameterless procedure", Arg);
end if;
+ -- Otherwise, search through interpretations looking for one which
+ -- has no parameters.
+
else
declare
Found : Boolean := False;
@@ -6914,13 +6968,20 @@ package body Sem_Prag is
if Ekind (Proc) = E_Procedure
and then No (First_Formal (Proc))
then
+ -- We found an interpretation, note it and continue
+ -- looking looking to verify it is unique.
+
if not Found then
Found := True;
Set_Entity (Name, Proc);
Set_Is_Overloaded (Name, False);
+
+ -- Two procedures with the same name, log an error
+ -- since the name is ambiguous.
+
else
Error_Pragma_Arg
- ("ambiguous handler name for pragma% ", Arg);
+ ("ambiguous handler name for pragma%", Arg);
end if;
end if;
@@ -6928,9 +6989,13 @@ package body Sem_Prag is
end loop;
if not Found then
+ -- Issue an error if we haven't found a suitable match for
+ -- Name.
+
Error_Pragma_Arg
("argument of pragma% must be parameterless procedure",
Arg);
+
else
Proc := Entity (Name);
end if;
@@ -7249,7 +7314,7 @@ package body Sem_Prag is
procedure Process_Atomic_Independent_Shared_Volatile is
procedure Check_Full_Access_Only (Ent : Entity_Id);
-- Apply legality checks to type or object Ent subject to the
- -- Full_Access_Only aspect in Ada 2020 (RM C.6(8.2)).
+ -- Full_Access_Only aspect in Ada 2022 (RM C.6(8.2)).
procedure Mark_Component_Or_Object (Ent : Entity_Id);
-- Appropriately set flags on the given entity, either an array or
@@ -7421,7 +7486,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 2022, the pragma can apply to a formal type, for which
-- there may be no underlying type.
if Prag_Id = Pragma_Atomic
@@ -7497,7 +7562,7 @@ package body Sem_Prag is
end if;
if not Has_Alignment_Clause (Ent) then
- Set_Alignment (Ent, Uint_0);
+ Init_Alignment (Ent);
end if;
end Set_Atomic_VFA;
@@ -7532,14 +7597,14 @@ package body Sem_Prag is
Check_Duplicate_Pragma (E);
- -- Check the constraints of Full_Access_Only in Ada 2020. Note that
+ -- Check the constraints of Full_Access_Only in Ada 2022. Note that
-- they do not apply to GNAT's Volatile_Full_Access because 1) this
-- aspect subsumes the Volatile aspect and 2) nesting is supported
-- for this aspect and the outermost enclosing VFA object prevails.
-- Note also that we used to forbid specifying both Atomic and VFA on
-- the same type or object, but the restriction has been lifted in
- -- light of the semantics of Full_Access_Only and Atomic in Ada 2020.
+ -- light of the semantics of Full_Access_Only and Atomic in Ada 2022.
if Prag_Id = Pragma_Volatile_Full_Access
and then From_Aspect_Specification (N)
@@ -9118,7 +9183,10 @@ package body Sem_Prag is
Def_Id := Entity (Def_Id);
Kill_Size_Check_Code (Def_Id);
- Note_Possible_Modification (Get_Pragma_Arg (Arg1), Sure => False);
+ if Ekind (Def_Id) /= E_Constant then
+ Note_Possible_Modification
+ (Get_Pragma_Arg (Arg1), Sure => False);
+ end if;
else
Process_Convention (C, Def_Id);
@@ -9128,7 +9196,10 @@ package body Sem_Prag is
Mark_Ghost_Pragma (N, Def_Id);
Kill_Size_Check_Code (Def_Id);
- Note_Possible_Modification (Get_Pragma_Arg (Arg2), Sure => False);
+ if Ekind (Def_Id) /= E_Constant then
+ Note_Possible_Modification
+ (Get_Pragma_Arg (Arg2), Sure => False);
+ end if;
end if;
-- Various error checks
@@ -9233,7 +9304,9 @@ package body Sem_Prag is
-- just the same scope). If the pragma comes from an aspect
-- specification we know that it is part of the declaration.
- elsif Parent (Unit_Declaration_Node (Def_Id)) /= Parent (N)
+ elsif (No (Unit_Declaration_Node (Def_Id))
+ or else Parent (Unit_Declaration_Node (Def_Id)) /=
+ Parent (N))
and then Nkind (Parent (N)) /= N_Compilation_Unit_Aux
and then not From_Aspect_Specification (N)
then
@@ -9824,7 +9897,7 @@ package body Sem_Prag is
-- inlineable either.
elsif Is_Generic_Instance (Subp)
- or else Nkind (Parent (Parent (Subp))) = N_Subprogram_Declaration
+ or else Parent_Kind (Parent (Subp)) = N_Subprogram_Declaration
then
null;
@@ -9870,7 +9943,11 @@ package body Sem_Prag is
if In_Same_Source_Unit (Subp, Inner_Subp) then
Set_Inline_Flags (Inner_Subp);
- Decl := Parent (Parent (Inner_Subp));
+ if Present (Parent (Inner_Subp)) then
+ Decl := Parent (Parent (Inner_Subp));
+ else
+ Decl := Empty;
+ end if;
if Nkind (Decl) = N_Subprogram_Declaration
and then Present (Corresponding_Body (Decl))
@@ -10453,6 +10530,41 @@ package body Sem_Prag is
Add_To_Config_Boolean_Restrictions (No_Elaboration_Code);
end if;
+ -- Special processing for No_Dynamic_Accessibility_Checks to
+ -- disallow exclusive specification in a body or subunit.
+
+ elsif R_Id = No_Dynamic_Accessibility_Checks
+ -- Check if the restriction is within configuration pragma
+ -- in a similar way to No_Elaboration_Code.
+
+ and then not (Current_Sem_Unit = Main_Unit
+ or else In_Extended_Main_Source_Unit (N))
+
+ and then Nkind (Unit (Parent (N))) = N_Compilation_Unit
+
+ and then (Nkind (Unit (Parent (N))) = N_Package_Body
+ or else Nkind (Unit (Parent (N))) = N_Subunit)
+
+ and then not Restriction_Active
+ (No_Dynamic_Accessibility_Checks)
+ then
+ Error_Msg_N
+ ("invalid specification of " &
+ """No_Dynamic_Accessibility_Checks""", N);
+
+ if Nkind (Unit (Parent (N))) = N_Package_Body then
+ Error_Msg_N
+ ("\restriction cannot be specified in a package " &
+ "body", N);
+
+ elsif Nkind (Unit (Parent (N))) = N_Subunit then
+ Error_Msg_N
+ ("\restriction cannot be specified in a subunit", N);
+ end if;
+
+ Error_Msg_N
+ ("\unless also specified in spec", N);
+
-- Special processing for No_Tasking restriction (not just a
-- warning) when it appears as a configuration pragma.
@@ -10860,8 +10972,8 @@ package body Sem_Prag is
procedure Record_Independence_Check (N : Node_Id; E : Entity_Id) is
pragma Unreferenced (N, E);
begin
- -- For GCC back ends the validation is done a priori
- -- ??? This code is dead, might be useful in the future
+ -- For GCC back ends the validation is done a priori. This code is
+ -- dead, but might be useful in the future.
-- if not AAMP_On_Target then
-- return;
@@ -10933,10 +11045,6 @@ package body Sem_Prag is
end if;
end if;
- if Warn_On_Export_Import and then Is_Type (E) then
- Error_Msg_NE ("exporting a type has no effect?x?", Arg, E);
- end if;
-
if Warn_On_Export_Import and Inside_A_Generic then
Error_Msg_NE
("all instances of& will have the same external name?x?",
@@ -11329,7 +11437,7 @@ package body Sem_Prag is
Warn => Treat_Restrictions_As_Warnings,
Profile => Ravenscar);
- -- Set the following restriction which was added to Ada 2020,
+ -- Set the following restriction which was added to Ada 2022,
-- but as a binding interpretation:
-- No_Dependence => Ada.Synchronous_Barriers
-- for Ravenscar (and therefore for Ravenscar variants) but not
@@ -11973,7 +12081,7 @@ package body Sem_Prag is
Set_Comes_From_Source (State_Id, not Is_Null);
Set_Parent (State_Id, State);
- Set_Ekind (State_Id, E_Abstract_State);
+ Mutate_Ekind (State_Id, E_Abstract_State);
Set_Etype (State_Id, Standard_Void_Type);
Set_Encapsulating_State (State_Id, Empty);
@@ -12524,26 +12632,65 @@ package body Sem_Prag is
end;
--------------
- -- Ada_2020 --
+ -- Ada_2022 --
--------------
- -- pragma Ada_2020;
+ -- pragma Ada_2022;
+ -- pragma Ada_2022 (LOCAL_NAME):
-- Note: this pragma also has some specific processing in Par.Prag
- -- because we want to set the Ada 2020 version mode during parsing.
+ -- because we want to set the Ada 2022 version mode during parsing.
+
+ -- The one argument form is used for managing the transition from Ada
+ -- 2012 to Ada 2022 in the run-time library. If an entity is marked
+ -- as Ada_2022 only, then referencing the entity in any pre-Ada_2022
+ -- mode will generate a warning;for calls to Ada_2022 only primitives
+ -- that require overriding an error will be reported. In addition, in
+ -- any pre-Ada_2022 mode, a preference rule is established which does
+ -- not choose such an entity unless it is unambiguously specified.
+ -- This avoids extra subprograms marked this way from generating
+ -- ambiguities in otherwise legal pre-Ada 2022 programs. The one
+ -- argument form is intended for exclusive use in the GNAT run-time
+ -- library.
+
+ when Pragma_Ada_2022 =>
+ declare
+ E_Id : Node_Id;
- when Pragma_Ada_2020 =>
+ begin
GNAT_Pragma;
- Check_Arg_Count (0);
+ if Arg_Count = 1 then
+ Check_Arg_Is_Local_Name (Arg1);
+ E_Id := Get_Pragma_Arg (Arg1);
- Check_Valid_Configuration_Pragma;
+ if Etype (E_Id) = Any_Type then
+ return;
+ end if;
+
+ Set_Is_Ada_2022_Only (Entity (E_Id));
+ Record_Rep_Item (Entity (E_Id), N);
+
+ else
+ Check_Arg_Count (0);
- -- Now set appropriate Ada mode
+ -- For Ada_2022 we unconditionally enforce the documented
+ -- configuration pragma placement, since we do not want to
+ -- tolerate mixed modes in a unit involving Ada 2022. That
+ -- would cause real difficulties for those cases where there
+ -- are incompatibilities between Ada 2012 and Ada 2022. We
+ -- could allow mixing of Ada 2012 and Ada 2022 but it's not
+ -- worth it.
- Ada_Version := Ada_2020;
- Ada_Version_Explicit := Ada_2020;
- Ada_Version_Pragma := N;
+ Check_Valid_Configuration_Pragma;
+
+ -- Now set appropriate Ada mode
+
+ Ada_Version := Ada_2022;
+ Ada_Version_Explicit := Ada_2022;
+ Ada_Version_Pragma := N;
+ end if;
+ end;
-------------------------------------
-- Aggregate_Individually_Assign --
@@ -12623,7 +12770,7 @@ package body Sem_Prag is
-- external tool and a tool-specific function. These arguments are
-- not analyzed.
- when Pragma_Annotate => Annotate : declare
+ when Pragma_Annotate | Pragma_GNAT_Annotate => Annotate : declare
Arg : Node_Id;
Expr : Node_Id;
Nam_Arg : Node_Id;
@@ -13426,7 +13573,7 @@ package body Sem_Prag is
Arg1);
end if;
- -- Only other possibility is Access-to-class-wide type
+ -- Only other possibility is access-to-class-wide type
elsif Is_Access_Type (Nm)
and then Is_Class_Wide_Type (Designated_Type (Nm))
@@ -13502,7 +13649,7 @@ package body Sem_Prag is
and then Nkind (Object_Definition (D)) =
N_Constrained_Array_Definition)
or else
- (Ada_Version >= Ada_2020
+ (Ada_Version >= Ada_2022
and then Nkind (D) = N_Formal_Type_Declaration)
then
-- The flag is set on the base type, or on the object
@@ -14591,7 +14738,6 @@ package body Sem_Prag is
-- [, [Link_Name =>] static_string_EXPRESSION ]);
when Pragma_CPP_Constructor => CPP_Constructor : declare
- Elmt : Elmt_Id;
Id : Entity_Id;
Def_Id : Entity_Id;
Tag_Typ : Entity_Id;
@@ -14658,12 +14804,7 @@ package body Sem_Prag is
then
Tag_Typ := Etype (Def_Id);
- Elmt := First_Elmt (Primitive_Operations (Tag_Typ));
- while Present (Elmt) and then Node (Elmt) /= Def_Id loop
- Next_Elmt (Elmt);
- end loop;
-
- Remove_Elmt (Primitive_Operations (Tag_Typ), Elmt);
+ Remove (Primitive_Operations (Tag_Typ), Def_Id);
Set_Is_Dispatching_Operation (Def_Id, False);
end if;
@@ -14724,6 +14865,8 @@ package body Sem_Prag is
end if;
if Nkind (N) = N_Aggregate
+ and then not Null_Record_Present (N)
+ and then No (Component_Associations (N))
and then List_Length (Expressions (N)) = 3
then
Expr := First (Expressions (N));
@@ -14745,7 +14888,7 @@ package body Sem_Prag is
Shared_Memory : Node_Id;
Stream : Node_Id;
- -- Start of processing for CUDA_Execute
+ -- Start of processing for CUDA_Execute
begin
GNAT_Pragma;
@@ -14754,7 +14897,7 @@ package body Sem_Prag is
Analyze_And_Resolve (Kernel_Call);
if Nkind (Kernel_Call) /= N_Function_Call
- or else Etype (Kernel_Call) /= Standard_Void_Type
+ 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
@@ -14795,7 +14938,7 @@ package body Sem_Prag is
-- CUDA_Global --
-----------------
- -- pragma CUDA_Global (IDENTIFIER);
+ -- pragma CUDA_Global ([Entity =>] IDENTIFIER);
when Pragma_CUDA_Global => CUDA_Global : declare
Arg_Node : Node_Id;
@@ -14803,8 +14946,7 @@ package body Sem_Prag is
Pack_Id : Entity_Id;
begin
GNAT_Pragma;
- Check_At_Least_N_Arguments (1);
- Check_At_Most_N_Arguments (1);
+ Check_Arg_Count (1);
Check_Optional_Identifier (Arg1, Name_Entity);
Check_Arg_Is_Local_Name (Arg1);
@@ -15041,9 +15183,8 @@ package body Sem_Prag is
else
-- All other cases: diagnose error
- Error_Msg
- ("argument of pragma ""Debug"" is not procedure call",
- Sloc (Call));
+ Error_Msg_N
+ ("argument of pragma ""Debug"" is not procedure call", Call);
return;
end if;
@@ -16097,7 +16238,8 @@ package body Sem_Prag is
begin
Set_Is_Exported (Id2, Is_Exported (Def_Id));
Set_First_Rep_Item (Id2, First_Rep_Item (Def_Id));
- Set_Interface_Name (Id2, Einfo.Interface_Name (Def_Id));
+ Set_Interface_Name
+ (Id2, Einfo.Entities.Interface_Name (Def_Id));
end;
end if;
end Export;
@@ -16274,25 +16416,6 @@ package body Sem_Prag is
Arg_Mechanism => Mechanism);
end Export_Procedure;
- ------------------
- -- Export_Value --
- ------------------
-
- -- pragma Export_Value (
- -- [Value =>] static_integer_EXPRESSION,
- -- [Link_Name =>] static_string_EXPRESSION);
-
- when Pragma_Export_Value =>
- GNAT_Pragma;
- Check_Arg_Order ((Name_Value, Name_Link_Name));
- Check_Arg_Count (2);
-
- Check_Optional_Identifier (Arg1, Name_Value);
- Check_Arg_Is_OK_Static_Expression (Arg1, Any_Integer);
-
- Check_Optional_Identifier (Arg2, Name_Link_Name);
- Check_Arg_Is_OK_Static_Expression (Arg2, Standard_String);
-
-----------------------------
-- Export_Valued_Procedure --
-----------------------------
@@ -16402,11 +16525,8 @@ package body Sem_Prag is
Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
if Chars (Get_Pragma_Arg (Arg1)) = Name_On then
- Extensions_Allowed := True;
- Ada_Version := Ada_Version_Type'Last;
-
+ Ada_Version := Ada_With_Extensions;
else
- Extensions_Allowed := False;
Ada_Version := Ada_Version_Explicit;
Ada_Version_Pragma := Empty;
end if;
@@ -19787,7 +19907,7 @@ package body Sem_Prag is
raise Pragma_Exit;
end if;
- -- Loop to find matching procedures or functions (Ada 2020)
+ -- Loop to find matching procedures or functions (Ada 2022)
E := Entity (Id);
@@ -19795,10 +19915,10 @@ package body Sem_Prag is
while Present (E)
and then Scope (E) = Current_Scope
loop
- -- Ada 2020 (AI12-0269): A function can be No_Return
+ -- Ada 2022 (AI12-0269): A function can be No_Return
if Ekind (E) in E_Generic_Procedure | E_Procedure
- or else (Ada_Version >= Ada_2020
+ or else (Ada_Version >= Ada_2022
and then
Ekind (E) in E_Generic_Function | E_Function)
then
@@ -19890,7 +20010,7 @@ package body Sem_Prag is
then
Set_No_Return (Entity (Id));
- elsif Ada_Version >= Ada_2020 then
+ elsif Ada_Version >= Ada_2022 then
Error_Pragma_Arg
("no subprogram& found for pragma%", Arg);
@@ -20403,7 +20523,8 @@ package body Sem_Prag is
elsif Chars (Argx) = Name_Eliminated then
if Ttypes.Standard_Long_Long_Integer_Size /= 64 then
Error_Pragma_Arg
- ("Eliminated not implemented on this target", Argx);
+ ("Eliminated requires Long_Long_Integer'Size = 64",
+ Argx);
else
return Eliminated;
end if;
@@ -24919,16 +25040,6 @@ package body Sem_Prag is
Record_Rep_Item (E, N);
end Universal_Alias;
- --------------------
- -- Universal_Data --
- --------------------
-
- -- pragma Universal_Data [(library_unit_NAME)];
-
- when Pragma_Universal_Data =>
- GNAT_Pragma;
- Error_Pragma ("??pragma% ignored (applies only to AAMP)");
-
----------------
-- Unmodified --
----------------
@@ -25632,9 +25743,9 @@ package body Sem_Prag is
Set_Specific_Warning_On (Loc, Message, Err);
if Err then
- Error_Msg
+ Error_Msg_N
("??pragma Warnings On with no matching "
- & "Warnings Off", Loc);
+ & "Warnings Off", N);
end if;
end if;
end;
@@ -29206,8 +29317,8 @@ package body Sem_Prag is
-- Check that the expression is a proper aggregate (no parentheses)
if Paren_Count (Variants) /= 0 then
- Error_Msg -- CODEFIX
- ("redundant parentheses", First_Sloc (Variants));
+ Error_Msg_F -- CODEFIX
+ ("redundant parentheses", Variants);
end if;
-- Ensure that the formal parameters are visible when analyzing all
@@ -30245,19 +30356,9 @@ package body Sem_Prag is
-- Process all formal parameters
- Formal := First_Entity (Spec_Id);
+ Formal := First_Formal (Spec_Id);
while Present (Formal) loop
if Ekind (Formal) in E_In_Out_Parameter | E_In_Parameter then
-
- -- IN parameters can act as output when the related type is
- -- access-to-variable.
-
- if Ekind (Formal) = E_In_Parameter
- and then Is_Access_Variable (Etype (Formal))
- then
- Append_New_Elmt (Formal, Subp_Outputs);
- end if;
-
Append_New_Elmt (Formal, Subp_Inputs);
end if;
@@ -30275,7 +30376,18 @@ package body Sem_Prag is
end if;
end if;
- Next_Entity (Formal);
+ -- IN parameters of procedures and protected entries can act as
+ -- outputs when the related type is access-to-variable.
+
+ if Ekind (Formal) = E_In_Parameter
+ and then Ekind (Spec_Id) not in E_Function
+ | E_Generic_Function
+ and then Is_Access_Variable (Etype (Formal))
+ then
+ Append_New_Elmt (Formal, Subp_Outputs);
+ end if;
+
+ Next_Formal (Formal);
end loop;
-- Otherwise the input denotes a task type, a task body, or the
@@ -30475,6 +30587,16 @@ package body Sem_Prag is
Stmt : Node_Id;
begin
+ -- If the pragma comes from an aspect on a compilation unit that is a
+ -- package instance, then return the original package instantiation
+ -- node.
+
+ if Nkind (Parent (Prag)) = N_Compilation_Unit_Aux then
+ return
+ Get_Unit_Instantiation_Node
+ (Defining_Entity (Unit (Enclosing_Comp_Unit_Node (Prag))));
+ end if;
+
Stmt := Prev (Prag);
while Present (Stmt) loop
@@ -30639,17 +30761,17 @@ package body Sem_Prag is
elsif Present (Generic_Parent (Specification (Stmt))) then
return Stmt;
- -- Ada 2020: contract on formal subprogram or on generated
+ -- Ada 2022: 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
+ and then Ada_Version >= Ada_2022
then
return Stmt;
elsif Is_Access_Subprogram_Wrapper (Defining_Entity (Stmt))
- and then Ada_Version >= Ada_2020
+ and then Ada_Version >= Ada_2022
then
return Stmt;
end if;
@@ -30678,14 +30800,19 @@ package body Sem_Prag is
elsif Nkind (Context) = N_Entry_Body then
return Context;
- -- The pragma appears inside the statements of a subprogram body. This
- -- placement is the result of subprogram contract expansion.
+ -- The pragma appears inside the statements of a subprogram body at
+ -- some nested level.
elsif Is_Statement (Context)
and then Present (Enclosing_HSS (Context))
then
return Parent (Enclosing_HSS (Context));
+ -- The pragma appears directly in the statements of a subprogram body
+
+ elsif Nkind (Context) = N_Handled_Sequence_Of_Statements then
+ return Parent (Context);
+
-- The pragma appears inside the declarative part of a package body
elsif Nkind (Context) = N_Package_Body then
@@ -30847,7 +30974,7 @@ package body Sem_Prag is
-- Follow subprogram renaming chain
if Is_Subprogram (Def_Id)
- and then Nkind (Parent (Declaration_Node (Def_Id))) =
+ and then Parent_Kind (Declaration_Node (Def_Id)) =
N_Subprogram_Renaming_Declaration
and then Present (Alias (Def_Id))
then
@@ -31118,7 +31245,7 @@ package body Sem_Prag is
Pragma_Ada_2005 => -1,
Pragma_Ada_12 => -1,
Pragma_Ada_2012 => -1,
- Pragma_Ada_2020 => -1,
+ Pragma_Ada_2022 => -1,
Pragma_Aggregate_Individually_Assign => 0,
Pragma_All_Calls_Remote => -1,
Pragma_Allow_Integer_Address => -1,
@@ -31184,7 +31311,6 @@ package body Sem_Prag is
Pragma_Export_Function => -1,
Pragma_Export_Object => -1,
Pragma_Export_Procedure => -1,
- Pragma_Export_Value => -1,
Pragma_Export_Valued_Procedure => -1,
Pragma_Extend_System => -1,
Pragma_Extensions_Allowed => 0,
@@ -31196,6 +31322,7 @@ package body Sem_Prag is
Pragma_Finalize_Storage_Only => 0,
Pragma_Ghost => 0,
Pragma_Global => -1,
+ Pragma_GNAT_Annotate => 93,
Pragma_Ident => -1,
Pragma_Ignore_Pragma => 0,
Pragma_Implementation_Defined => -1,
@@ -31339,7 +31466,6 @@ package body Sem_Prag is
Pragma_Unevaluated_Use_Of_Old => 0,
Pragma_Unimplemented_Unit => 0,
Pragma_Universal_Aliasing => 0,
- Pragma_Universal_Data => 0,
Pragma_Unmodified => 0,
Pragma_Unreferenced => 0,
Pragma_Unreferenced_Objects => 0,
diff --git a/gcc/ada/sem_prag.ads b/gcc/ada/sem_prag.ads
index fd7a0cd..e166481 100644
--- a/gcc/ada/sem_prag.ads
+++ b/gcc/ada/sem_prag.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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,7 @@ package Sem_Prag is
Pragma_Favor_Top_Level => True,
Pragma_Ghost => True,
Pragma_Global => True,
+ Pragma_GNAT_Annotate => True,
Pragma_Import => True,
Pragma_Independent => True,
Pragma_Independent_Components => True,
@@ -115,7 +116,6 @@ package Sem_Prag is
Pragma_Type_Invariant => True,
Pragma_Unchecked_Union => True,
Pragma_Universal_Aliasing => True,
- Pragma_Universal_Data => True,
Pragma_Unmodified => True,
Pragma_Unreferenced => True,
Pragma_Unreferenced_Objects => True,
@@ -360,9 +360,9 @@ package Sem_Prag is
Subp_Outputs : in out Elist_Id;
Global_Seen : out Boolean);
-- Subsidiary to the analysis of pragmas Depends, Global, Refined_Depends
- -- and Refined_Global. The routine is also used by GNATprove. Collect all
- -- inputs and outputs of subprogram Subp_Id in lists Subp_Inputs (inputs)
- -- and Subp_Outputs (outputs). The inputs and outputs are gathered from:
+ -- and Refined_Global. Collect all inputs and outputs of subprogram Subp_Id
+ -- in lists Subp_Inputs (inputs) and Subp_Outputs (outputs). The inputs and
+ -- outputs are gathered from:
-- 1) The formal parameters of the subprogram
-- 2) The generic formal parameters of the generic subprogram
-- 3) The current instance of a concurrent type
diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb
index f6e0eab..03d747e 100644
--- a/gcc/ada/sem_res.adb
+++ b/gcc/ada/sem_res.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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,65 +23,70 @@
-- --
------------------------------------------------------------------------------
-with Aspects; use Aspects;
-with Atree; use Atree;
-with Checks; use Checks;
-with Debug; use Debug;
-with Debug_A; use Debug_A;
-with Einfo; use Einfo;
-with Errout; use Errout;
-with Expander; use Expander;
-with Exp_Ch6; use Exp_Ch6;
-with Exp_Ch7; use Exp_Ch7;
-with Exp_Disp; use Exp_Disp;
-with Exp_Tss; use Exp_Tss;
-with Exp_Util; use Exp_Util;
-with Freeze; use Freeze;
-with Ghost; use Ghost;
-with Inline; use Inline;
-with Itypes; use Itypes;
-with Lib; use Lib;
-with Lib.Xref; use Lib.Xref;
-with Namet; use Namet;
-with Nmake; use Nmake;
-with Nlists; use Nlists;
-with Opt; use Opt;
-with Output; use Output;
-with Par_SCO; use Par_SCO;
-with Restrict; use Restrict;
-with Rident; use Rident;
-with Rtsfind; use Rtsfind;
-with Sem; use Sem;
-with Sem_Aggr; use Sem_Aggr;
-with Sem_Attr; use Sem_Attr;
-with Sem_Aux; use Sem_Aux;
-with Sem_Cat; use Sem_Cat;
-with Sem_Ch3; use Sem_Ch3;
-with Sem_Ch4; use Sem_Ch4;
-with Sem_Ch6; use Sem_Ch6;
-with Sem_Ch8; use Sem_Ch8;
-with Sem_Ch13; use Sem_Ch13;
-with Sem_Dim; use Sem_Dim;
-with Sem_Disp; use Sem_Disp;
-with Sem_Dist; use Sem_Dist;
-with Sem_Elab; use Sem_Elab;
-with Sem_Elim; use Sem_Elim;
-with Sem_Eval; use Sem_Eval;
-with Sem_Intr; use Sem_Intr;
-with Sem_Mech; use Sem_Mech;
-with Sem_Type; use Sem_Type;
-with Sem_Util; use Sem_Util;
-with Sem_Warn; use Sem_Warn;
-with Sinfo; use Sinfo;
-with Sinfo.CN; use Sinfo.CN;
-with Snames; use Snames;
-with Stand; use Stand;
-with Stringt; use Stringt;
-with Style; use Style;
-with Targparm; use Targparm;
-with Tbuild; use Tbuild;
-with Uintp; use Uintp;
-with Urealp; use Urealp;
+with Aspects; use Aspects;
+with Atree; use Atree;
+with Checks; use Checks;
+with Debug; use Debug;
+with Debug_A; use Debug_A;
+with Einfo; use Einfo;
+with Einfo.Entities; use Einfo.Entities;
+with Einfo.Utils; use Einfo.Utils;
+with Errout; use Errout;
+with Expander; use Expander;
+with Exp_Ch6; use Exp_Ch6;
+with Exp_Ch7; use Exp_Ch7;
+with Exp_Disp; use Exp_Disp;
+with Exp_Tss; use Exp_Tss;
+with Exp_Util; use Exp_Util;
+with Freeze; use Freeze;
+with Ghost; use Ghost;
+with Inline; use Inline;
+with Itypes; use Itypes;
+with Lib; use Lib;
+with Lib.Xref; use Lib.Xref;
+with Namet; use Namet;
+with Nmake; use Nmake;
+with Nlists; use Nlists;
+with Opt; use Opt;
+with Output; use Output;
+with Par_SCO; use Par_SCO;
+with Restrict; use Restrict;
+with Rident; use Rident;
+with Rtsfind; use Rtsfind;
+with Sem; use Sem;
+with Sem_Aggr; use Sem_Aggr;
+with Sem_Attr; use Sem_Attr;
+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_Ch4; use Sem_Ch4;
+with Sem_Ch6; use Sem_Ch6;
+with Sem_Ch8; use Sem_Ch8;
+with Sem_Ch13; use Sem_Ch13;
+with Sem_Dim; use Sem_Dim;
+with Sem_Disp; use Sem_Disp;
+with Sem_Dist; use Sem_Dist;
+with Sem_Elab; use Sem_Elab;
+with Sem_Elim; use Sem_Elim;
+with Sem_Eval; use Sem_Eval;
+with Sem_Intr; use Sem_Intr;
+with Sem_Mech; use Sem_Mech;
+with Sem_Type; use Sem_Type;
+with Sem_Util; use Sem_Util;
+with Sem_Warn; use Sem_Warn;
+with Sinfo; use Sinfo;
+with Sinfo.Nodes; use Sinfo.Nodes;
+with Sinfo.Utils; use Sinfo.Utils;
+with Sinfo.CN; use Sinfo.CN;
+with Snames; use Snames;
+with Stand; use Stand;
+with Stringt; use Stringt;
+with Style; use Style;
+with Targparm; use Targparm;
+with Tbuild; use Tbuild;
+with Uintp; use Uintp;
+with Urealp; use Urealp;
package body Sem_Res is
@@ -649,9 +654,9 @@ package body Sem_Res is
end if;
end Check_For_Visible_Operator;
- ----------------------------------
- -- Check_Fully_Declared_Prefix --
- ----------------------------------
+ ---------------------------------
+ -- Check_Fully_Declared_Prefix --
+ ---------------------------------
procedure Check_Fully_Declared_Prefix
(Typ : Entity_Id;
@@ -1285,8 +1290,10 @@ package body Sem_Res is
Check_Parameterless_Call (Explicit_Actual_Parameter (N));
elsif Nkind (N) = N_Operator_Symbol then
- Change_Operator_Symbol_To_String_Literal (N);
+ Set_Etype (N, Empty);
+ Set_Entity (N, Empty);
Set_Is_Overloaded (N, False);
+ Change_Operator_Symbol_To_String_Literal (N);
Set_Etype (N, Any_String);
end if;
end Check_Parameterless_Call;
@@ -1879,9 +1886,9 @@ package body Sem_Res is
Expander_Mode_Restore;
Full_Analysis := Save_Full_Analysis;
- Set_Must_Not_Freeze (N, Save_Must_Not_Freeze);
if not With_Freezing then
+ Set_Must_Not_Freeze (N, Save_Must_Not_Freeze);
Inside_Preanalysis_Without_Freezing :=
Inside_Preanalysis_Without_Freezing - 1;
end if;
@@ -2114,7 +2121,7 @@ package body Sem_Res is
end loop;
end if;
- -- Additional message and hint if the ambiguity involves an Ada2020
+ -- Additional message and hint if the ambiguity involves an Ada 2022
-- container aggregate.
Check_Ambiguous_Aggregate (N);
@@ -2233,7 +2240,7 @@ package body Sem_Res is
then
Is_Remote := False;
Error_Msg_N
- ("prefix must statically denote a remote subprogram ",
+ ("prefix must statically denote a remote subprogram",
N);
end if;
@@ -2344,8 +2351,7 @@ package body Sem_Res is
if Ada_Version >= Ada_2005
and then It.Typ = Typ
- and then Typ /= Universal_Integer
- and then Typ /= Universal_Real
+ and then not Is_Universal_Numeric_Type (Typ)
and then Present (It.Abstract_Op)
then
if Debug_Flag_V then
@@ -2781,7 +2787,7 @@ package body Sem_Res is
elsif Nkind (N) = N_Aggregate
and then Etype (N) = Any_Composite
then
- if Ada_Version >= Ada_2020
+ if Ada_Version >= Ada_2022
and then Has_Aspect (Typ, Aspect_Aggregate)
then
Resolve_Container_Aggregate (N, Typ);
@@ -2928,6 +2934,11 @@ package body Sem_Res is
else
UI_Image (Norm_Num (Expr_Value_R (Expr)), Decimal);
Start_String;
+
+ if UR_Is_Negative (Expr_Value_R (Expr)) then
+ Store_String_Chars ("-");
+ end if;
+
Store_String_Chars
(UI_Image_Buffer (1 .. UI_Image_Length));
Param1 := Make_String_Literal (Loc, End_String);
@@ -3385,12 +3396,9 @@ package body Sem_Res is
-- Here we are resolving the corresponding expanded body, so we do
-- need to perform normal freezing.
- -- As elsewhere we do not emit freeze node within a generic. We make
- -- an exception for entities that are expressions, only to detect
- -- misuses of deferred constants and preserve the output of various
- -- tests.
+ -- As elsewhere we do not emit freeze node within a generic.
- if not Inside_A_Generic or else Is_Entity_Name (N) then
+ if not Inside_A_Generic then
Freeze_Expression (N);
end if;
@@ -3749,26 +3757,34 @@ package body Sem_Res is
Id : Entity_Id;
begin
- -- Do not consider nested function calls because they have already
- -- been processed during their own resolution.
+ case Nkind (N) is
+ -- Do not consider nested function calls because they have
+ -- already been processed during their own resolution.
- if Nkind (N) = N_Function_Call then
- return Skip;
+ when N_Function_Call =>
+ return Skip;
- elsif Is_Entity_Name (N) and then Present (Entity (N)) then
- Id := Entity (N);
+ when N_Identifier | N_Expanded_Name =>
+ Id := Entity (N);
+
+ if Present (Id)
+ and then Is_Object (Id)
+ and then Is_Effectively_Volatile_For_Reading (Id)
+ and then
+ not Is_OK_Volatile_Context (Context => Parent (N),
+ Obj_Ref => N,
+ Check_Actuals => True)
+ then
+ Error_Msg_N
+ ("volatile object cannot appear in this context"
+ & " (SPARK RM 7.1.3(10))", N);
+ end if;
- if Is_Object (Id)
- and then Is_Effectively_Volatile_For_Reading (Id)
- then
- Error_Msg_N
- ("volatile object cannot appear in this context (SPARK "
- & "RM 7.1.3(10))", N);
return Skip;
- end if;
- end if;
- return OK;
+ when others =>
+ return OK;
+ end case;
end Flag_Object;
procedure Flag_Objects is new Traverse_Proc (Flag_Object);
@@ -4747,6 +4763,13 @@ package body Sem_Res is
-- Expand_Actuals routine in Exp_Ch6.
end if;
+ -- If the formal is of an unconstrained array subtype with fixed
+ -- lower bound, then sliding to that bound may be needed.
+
+ if Is_Fixed_Lower_Bound_Array_Subtype (F_Typ) then
+ Expand_Sliding_Conversion (A, F_Typ);
+ end if;
+
-- An actual associated with an access parameter is implicitly
-- converted to the anonymous access type of the formal and must
-- satisfy the legality checks for access conversions.
@@ -4774,11 +4797,11 @@ package body Sem_Res is
-- Check illegal cases of atomic/volatile/VFA actual (RM C.6(12))
- if (Is_By_Reference_Type (Etype (F)) or else Is_Aliased (F))
+ if (Is_By_Reference_Type (F_Typ) or else Is_Aliased (F))
and then Comes_From_Source (N)
then
if Is_Atomic_Object (A)
- and then not Is_Atomic (Etype (F))
+ and then not Is_Atomic (F_Typ)
then
Error_Msg_NE
("cannot pass atomic object to nonatomic formal&",
@@ -4786,8 +4809,8 @@ package body Sem_Res is
Error_Msg_N
("\which is passed by reference (RM C.6(12))", A);
- elsif Is_Volatile_Object (A)
- and then not Is_Volatile (Etype (F))
+ elsif Is_Volatile_Object_Ref (A)
+ and then not Is_Volatile (F_Typ)
then
Error_Msg_NE
("cannot pass volatile object to nonvolatile formal&",
@@ -4795,8 +4818,8 @@ package body Sem_Res is
Error_Msg_N
("\which is passed by reference (RM C.6(12))", A);
- elsif Is_Volatile_Full_Access_Object (A)
- and then not Is_Volatile_Full_Access (Etype (F))
+ elsif Is_Volatile_Full_Access_Object_Ref (A)
+ and then not Is_Volatile_Full_Access (F_Typ)
then
Error_Msg_NE
("cannot pass full access object to nonfull access "
@@ -4806,9 +4829,9 @@ package body Sem_Res is
end if;
-- Check for nonatomic subcomponent of a full access object
- -- in Ada 2020 (RM C.6 (12)).
+ -- in Ada 2022 (RM C.6 (12)).
- if Ada_Version >= Ada_2020
+ if Ada_Version >= Ada_2022
and then Is_Subcomponent_Of_Full_Access_Object (A)
and then not Is_Atomic_Object (A)
then
@@ -4831,9 +4854,9 @@ package body Sem_Res is
if Is_Controlling_Formal (F) then
Set_Is_Controlling_Actual (A);
- if Ekind (Etype (F)) = E_Anonymous_Access_Type then
+ if Ekind (F_Typ) = E_Anonymous_Access_Type then
declare
- Desig : constant Entity_Id := Designated_Type (Etype (F));
+ Desig : constant Entity_Id := Designated_Type (F_Typ);
begin
if Ekind (Desig) = E_Incomplete_Type
and then No (Full_View (Desig))
@@ -4938,40 +4961,14 @@ package body Sem_Res is
if SPARK_Mode = On and then Comes_From_Source (A) then
- -- An effectively volatile object for reading may act as an
- -- actual when the corresponding formal is of a non-scalar
- -- effectively volatile type for reading (SPARK RM 7.1.3(10)).
-
- if not Is_Scalar_Type (Etype (F))
- and then Is_Effectively_Volatile_For_Reading (Etype (F))
- then
- null;
-
- -- An effectively volatile object for reading may act as an
- -- actual in a call to an instance of Unchecked_Conversion.
- -- (SPARK RM 7.1.3(10)).
-
- elsif Is_Unchecked_Conversion_Instance (Nam) then
- null;
-
- -- The actual denotes an object
+ -- Inspect the expression and flag each effectively volatile
+ -- object for reading as illegal because it appears within
+ -- an interfering context. Note that this is usually done
+ -- in Resolve_Entity_Name, but when the effectively volatile
+ -- object for reading appears as an actual in a call, the call
+ -- must be resolved first.
- elsif Is_Effectively_Volatile_Object_For_Reading (A) then
- Error_Msg_N
- ("volatile object cannot act as actual in a call (SPARK "
- & "RM 7.1.3(10))", A);
-
- -- Otherwise the actual denotes an expression. Inspect the
- -- expression and flag each effectively volatile object
- -- for reading as illegal because it apprears within an
- -- interfering context. Note that this is usually done in
- -- Resolve_Entity_Name, but when the effectively volatile
- -- object for reading appears as an actual in a call, the
- -- call must be resolved first.
-
- else
- Flag_Effectively_Volatile_Objects (A);
- end if;
+ Flag_Effectively_Volatile_Objects (A);
-- An effectively volatile variable cannot act as an actual
-- parameter in a procedure call when the variable has enabled
@@ -5036,6 +5033,41 @@ package body Sem_Res is
end if;
end if;
+ -- (AI12-0397): The target of a subprogram call that occurs within
+ -- the expression of an Default_Initial_Condition aspect and has
+ -- an actual that is the current instance of the type must be
+ -- either a primitive of the type or a class-wide subprogram,
+ -- because the type of the current instance in such an aspect is
+ -- considered to be a notional formal derived type whose only
+ -- operations correspond to the primitives of the enclosing type.
+ -- Nonprimitives can be called, but the current instance must be
+ -- converted rather than passed directly. Note that a current
+ -- instance of a type with DIC will occur as a reference to an
+ -- in-mode formal of an enclosing DIC procedure or partial DIC
+ -- procedure. (It seems that this check should perhaps also apply
+ -- to calls within Type_Invariant'Class, but not Type_Invariant,
+ -- aspects???)
+
+ if Nkind (A) = N_Identifier
+ and then Ekind (Entity (A)) = E_In_Parameter
+
+ and then Is_Subprogram (Scope (Entity (A)))
+ and then Is_DIC_Procedure (Scope (Entity (A)))
+
+ -- We check Comes_From_Source to exclude inherited primitives
+ -- from being flagged, because such subprograms turn out to not
+ -- always have the Is_Primitive flag set. ???
+
+ and then Comes_From_Source (Nam)
+
+ and then not Is_Primitive (Nam)
+ and then not Is_Class_Wide_Type (F_Typ)
+ then
+ Error_Msg_NE
+ ("call to nonprimitive & with current instance not allowed " &
+ "for aspect", A, Nam);
+ end if;
+
Next_Actual (A);
-- Case where actual is not present
@@ -5696,14 +5728,12 @@ package body Sem_Res is
if not Is_Overloaded (N) then
T := Etype (N);
return Base_Type (T) = Base_Type (Standard_Integer)
- or else T = Universal_Integer
- or else T = Universal_Real;
+ or else Is_Universal_Numeric_Type (T);
else
Get_First_Interp (N, Index, It);
while Present (It.Typ) loop
if Base_Type (It.Typ) = Base_Type (Standard_Integer)
- or else It.Typ = Universal_Integer
- or else It.Typ = Universal_Real
+ or else Is_Universal_Numeric_Type (It.Typ)
then
return True;
end if;
@@ -5738,8 +5768,7 @@ package body Sem_Res is
elsif Universal_Interpretation (N) = Universal_Real
and then (T = Base_Type (Standard_Integer)
- or else T = Universal_Integer
- or else T = Universal_Real)
+ or else Is_Universal_Numeric_Type (T))
then
-- A universal real can appear in a fixed-type context. We resolve
-- the literal with that context, even though this might raise an
@@ -5872,9 +5901,7 @@ package body Sem_Res is
procedure Set_Operand_Type (N : Node_Id) is
begin
- if Etype (N) = Universal_Integer
- or else Etype (N) = Universal_Real
- then
+ if Is_Universal_Numeric_Type (Etype (N)) then
Set_Etype (N, T);
end if;
end Set_Operand_Type;
@@ -5899,7 +5926,7 @@ package body Sem_Res is
-- Set the type of the node to its universal interpretation because
-- legality checks on an exponentiation operand need the context.
- elsif (B_Typ = Universal_Integer or else B_Typ = Universal_Real)
+ elsif Is_Universal_Numeric_Type (B_Typ)
and then Present (Universal_Interpretation (L))
and then Present (Universal_Interpretation (R))
then
@@ -6012,9 +6039,9 @@ package body Sem_Res is
end if;
else
- if (TL = Universal_Integer or else TL = Universal_Real)
+ if Is_Universal_Numeric_Type (TL)
and then
- (TR = Universal_Integer or else TR = Universal_Real)
+ Is_Universal_Numeric_Type (TR)
then
Check_For_Visible_Operator (N, B_Typ);
end if;
@@ -6124,13 +6151,6 @@ package body Sem_Res is
raise Program_Error;
end case;
- -- In GNATprove mode, we enable the division check so that
- -- GNATprove will issue a message if it cannot be proved.
-
- if GNATprove_Mode then
- Activate_Division_Check (N);
- end if;
-
-- Otherwise just set the flag to check at run time
else
@@ -6645,7 +6665,7 @@ 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
+ -- Ada 2022 (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
@@ -7076,7 +7096,7 @@ 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
+ -- Ada 2022 (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
@@ -7506,7 +7526,7 @@ package body Sem_Res is
end;
if Need_Transient_Scope then
- Establish_Transient_Scope (Decl, True);
+ Establish_Transient_Scope (Decl, Manage_Sec_Stack => True);
else
Push_Scope (Scope (Defining_Identifier (Decl)));
end if;
@@ -7646,8 +7666,7 @@ package body Sem_Res is
Expr : Node_Id) return Boolean
is
begin
- if Nkind (Context) in
- N_Assignment_Statement | N_Object_Declaration
+ if Nkind (Context) in N_Assignment_Statement | N_Object_Declaration
and then Expression (Context) = Expr
then
return True;
@@ -7689,6 +7708,11 @@ package body Sem_Res is
while Present (N) loop
if Nkind (N) = N_Attribute_Reference then
return True;
+
+ -- Prevent the search from going too far
+
+ elsif Is_Body_Or_Package_Declaration (N) then
+ return False;
end if;
N := Parent (N);
@@ -7734,10 +7758,12 @@ package body Sem_Res is
-- Case of (sub)type name appearing in a context where an expression
-- is expected. This is legal if occurrence is a current instance.
- -- See RM 8.6 (17/3).
+ -- See RM 8.6 (17/3). It is also legal if the expression is
+ -- part of a choice pattern for a case stmt/expr having a
+ -- non-discrete selecting expression.
elsif Is_Type (E) then
- if Is_Current_Instance (N) then
+ if Is_Current_Instance (N) or else Is_Case_Choice_Pattern (N) then
null;
-- Any other use is an error
@@ -7831,7 +7857,8 @@ package body Sem_Res is
if Is_Object (E)
and then Is_Effectively_Volatile_For_Reading (E)
- and then not Is_OK_Volatile_Context (Par, N)
+ and then
+ not Is_OK_Volatile_Context (Par, N, Check_Actuals => False)
then
SPARK_Msg_N
("volatile object cannot appear in this context "
@@ -8791,18 +8818,12 @@ package body Sem_Res is
or else Is_Private_Type (T))
then
if Etype (L) /= T then
- Rewrite (L,
- Make_Unchecked_Type_Conversion (Sloc (L),
- Subtype_Mark => New_Occurrence_Of (T, Sloc (L)),
- Expression => Relocate_Node (L)));
+ Rewrite (L, Unchecked_Convert_To (T, L));
Analyze_And_Resolve (L, T);
end if;
if (Etype (R)) /= T then
- Rewrite (R,
- Make_Unchecked_Type_Conversion (Sloc (R),
- Subtype_Mark => New_Occurrence_Of (Etype (L), Sloc (R)),
- Expression => Relocate_Node (R)));
+ Rewrite (R, Unchecked_Convert_To (Etype (L), R));
Analyze_And_Resolve (R, T);
end if;
end if;
@@ -9065,6 +9086,16 @@ package body Sem_Res is
-- that the context in general allows sliding, while a qualified
-- expression forces equality of bounds.
+ Result_Type : Entity_Id := Typ;
+ -- So in most cases the type of the If_Expression and of its
+ -- dependent expressions is that of the context. However, if
+ -- the expression is the index of an Indexed_Component, we must
+ -- ensure that a proper index check is applied, rather than a
+ -- range check on the index type (which might be discriminant
+ -- dependent). In this case we resolve with the base type of the
+ -- index type, and the index check is generated in the resolution
+ -- of the indexed_component above.
+
-----------------
-- Apply_Check --
-----------------
@@ -9088,10 +9119,10 @@ package body Sem_Res is
else
Rewrite (Expr,
Make_Qualified_Expression (Loc,
- Subtype_Mark => New_Occurrence_Of (Typ, Loc),
+ Subtype_Mark => New_Occurrence_Of (Result_Type, Loc),
Expression => Relocate_Node (Expr)));
- Analyze_And_Resolve (Expr, Typ);
+ Analyze_And_Resolve (Expr, Result_Type);
end if;
end Apply_Check;
@@ -9110,6 +9141,13 @@ package body Sem_Res is
return;
end if;
+ if Present (Parent (N))
+ and then (Nkind (Parent (N)) = N_Indexed_Component
+ or else Nkind (Parent (Parent (N))) = N_Indexed_Component)
+ then
+ Result_Type := Base_Type (Typ);
+ end if;
+
Then_Expr := Next (Condition);
if No (Then_Expr) then
@@ -9119,7 +9157,7 @@ package body Sem_Res is
Else_Expr := Next (Then_Expr);
Resolve (Condition, Any_Boolean);
- Resolve (Then_Expr, Typ);
+ Resolve (Then_Expr, Result_Type);
Apply_Check (Then_Expr);
-- If ELSE expression present, just resolve using the determined type
@@ -9133,7 +9171,7 @@ package body Sem_Res is
Resolve (Else_Expr, Any_Real);
else
- Resolve (Else_Expr, Typ);
+ Resolve (Else_Expr, Result_Type);
end if;
Apply_Check (Else_Expr);
@@ -9157,7 +9195,7 @@ package body Sem_Res is
elsif Root_Type (Typ) = Standard_Boolean then
Else_Expr :=
Convert_To (Typ, New_Occurrence_Of (Standard_True, Sloc (N)));
- Analyze_And_Resolve (Else_Expr, Typ);
+ Analyze_And_Resolve (Else_Expr, Result_Type);
Append_To (Expressions (N), Else_Expr);
else
@@ -9165,7 +9203,7 @@ package body Sem_Res is
Append_To (Expressions (N), Error);
end if;
- Set_Etype (N, Typ);
+ Set_Etype (N, Result_Type);
if not Error_Posted (N) then
Eval_If_Expression (N);
@@ -9330,7 +9368,7 @@ package body Sem_Res is
end if;
-- 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
+ -- worth a warning before Ada 2022, 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.
@@ -9341,7 +9379,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
+ and then Ada_Version < Ada_2022
then
Error_Msg_N
("??access to non-atomic component of atomic array", Prefix (N));
@@ -9756,10 +9794,7 @@ package body Sem_Res is
goto SM_Exit;
elsif not Is_Overloaded (R)
- and then
- (Etype (R) = Universal_Integer
- or else
- Etype (R) = Universal_Real)
+ and then Is_Universal_Numeric_Type (Etype (R))
and then Is_Overloaded (L)
then
T := Etype (R);
@@ -10201,9 +10236,7 @@ package body Sem_Res is
return;
end if;
- if Etype (Left_Opnd (N)) = Universal_Integer
- or else Etype (Left_Opnd (N)) = Universal_Real
- then
+ if Is_Universal_Numeric_Type (Etype (Left_Opnd (N))) then
Check_For_Visible_Operator (N, B_Typ);
end if;
@@ -10466,8 +10499,57 @@ package body Sem_Res is
if Typ = Raise_Type then
Error_Msg_N ("cannot find unique type for raise expression", N);
Set_Etype (N, Any_Type);
+
else
Set_Etype (N, Typ);
+
+ -- Apply check for required parentheses in the enclosing
+ -- context of raise_expressions (RM 11.3 (2)), including default
+ -- expressions in contexts that can include aspect specifications,
+ -- and ancestor parts of extension aggregates.
+
+ declare
+ Par : Node_Id := Parent (N);
+ Parentheses_Found : Boolean := Paren_Count (N) > 0;
+
+ begin
+ while Present (Par)
+ and then Nkind (Par) in N_Has_Etype
+ loop
+ if Paren_Count (Par) > 0 then
+ Parentheses_Found := True;
+ end if;
+
+ if Nkind (Par) = N_Extension_Aggregate
+ and then N = Ancestor_Part (Par)
+ then
+ exit;
+ end if;
+
+ Par := Parent (Par);
+ end loop;
+
+ if not Parentheses_Found
+ and then Comes_From_Source (Par)
+ and then
+ ((Nkind (Par) in N_Modular_Type_Definition
+ | N_Floating_Point_Definition
+ | N_Ordinary_Fixed_Point_Definition
+ | N_Decimal_Fixed_Point_Definition
+ | N_Extension_Aggregate
+ | N_Discriminant_Specification
+ | N_Parameter_Specification
+ | N_Formal_Object_Declaration)
+
+ or else (Nkind (Par) = N_Object_Declaration
+ and then
+ Nkind (Parent (Par)) /= N_Extended_Return_Statement))
+ then
+ Error_Msg_N
+ ("raise_expression must be parenthesized in this context",
+ N);
+ end if;
+ end;
end if;
end Resolve_Raise_Expression;
@@ -10501,12 +10583,9 @@ package body Sem_Res is
PL : constant Node_Id := Prefix (Lorig);
PH : constant Node_Id := Prefix (Horig);
begin
- if Is_Entity_Name (PL)
+ return Is_Entity_Name (PL)
and then Is_Entity_Name (PH)
- and then Entity (PL) = Entity (PH)
- then
- return True;
- end if;
+ and then Entity (PL) = Entity (PH);
end;
end if;
@@ -10575,11 +10654,11 @@ package body Sem_Res is
if Is_Discrete_Type (Typ) and then Expander_Active then
if Is_OK_Static_Expression (L) then
- Fold_Uint (L, Expr_Value (L), Is_OK_Static_Expression (L));
+ Fold_Uint (L, Expr_Value (L), Static => True);
end if;
if Is_OK_Static_Expression (H) then
- Fold_Uint (H, Expr_Value (H), Is_OK_Static_Expression (H));
+ Fold_Uint (H, Expr_Value (H), Static => True);
end if;
end if;
end Resolve_Range;
@@ -10919,7 +10998,7 @@ package body Sem_Res is
if Nkind (N) = N_Selected_Component then
-- 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
+ -- is worth a warning before Ada 2022, 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.
@@ -10927,7 +11006,7 @@ package body Sem_Res is
if 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
+ and then Ada_Version < Ada_2022
then
Error_Msg_N
("??access to non-atomic component of atomic record",
@@ -11530,14 +11609,14 @@ package body Sem_Res is
Comp_Typ_Hi : constant Node_Id :=
Type_High_Bound (Component_Type (Typ));
- Char_Val : Uint;
+ Char_Val : Int;
begin
if Compile_Time_Known_Value (Comp_Typ_Lo)
and then Compile_Time_Known_Value (Comp_Typ_Hi)
then
for J in 1 .. Strlen loop
- Char_Val := UI_From_Int (Int (Get_String_Char (Str, J)));
+ Char_Val := Int (Get_String_Char (Str, J));
if Char_Val < Expr_Value (Comp_Typ_Lo)
or else Char_Val > Expr_Value (Comp_Typ_Hi)
@@ -11562,7 +11641,7 @@ package body Sem_Res is
-- heavy artillery for this situation, but it is hard work to avoid.
declare
- Lits : constant List_Id := New_List;
+ Lits : constant List_Id := New_List;
P : Source_Ptr := Loc + 1;
C : Char_Code;
@@ -12045,16 +12124,35 @@ package body Sem_Res is
-- Deal with universal cases
- if Etype (R) = Universal_Integer
- or else
- Etype (R) = Universal_Real
- then
+ if Is_Universal_Numeric_Type (Etype (R)) then
Check_For_Visible_Operator (N, B_Typ);
end if;
Set_Etype (N, B_Typ);
Resolve (R, B_Typ);
+ -- Generate warning for negative literal of a modular type, unless it is
+ -- enclosed directly in a type qualification or a type conversion, as it
+ -- is likely not what the user intended. We don't issue the warning for
+ -- the common use of -1 to denote OxFFFF_FFFF...
+
+ if Warn_On_Suspicious_Modulus_Value
+ and then Nkind (N) = N_Op_Minus
+ and then Nkind (R) = N_Integer_Literal
+ and then Is_Modular_Integer_Type (B_Typ)
+ and then Nkind (Parent (N)) not in N_Qualified_Expression
+ | N_Type_Conversion
+ and then Expr_Value (R) > Uint_1
+ then
+ Error_Msg_N
+ ("?M?negative literal of modular type is in fact positive", N);
+ Error_Msg_Uint_1 := (-Expr_Value (R)) mod Modulus (B_Typ);
+ Error_Msg_Uint_2 := Expr_Value (R);
+ Error_Msg_N ("\do you really mean^ when writing -^ '?", N);
+ Error_Msg_N
+ ("\if you do, use qualification to avoid this warning", N);
+ end if;
+
-- Generate warning for expressions like abs (x mod 2)
if Warn_On_Redundant_Constructs
@@ -12496,10 +12594,9 @@ package body Sem_Res is
-- the point where actions for the slice are analyzed). Note that this
-- is different from freezing the itype immediately, which might be
-- premature (e.g. if the slice is within a transient scope). This needs
- -- to be done only if expansion is enabled, or in GNATprove mode to
- -- capture the associated run-time exceptions if any.
+ -- to be done only if expansion is enabled.
- elsif Expander_Active or GNATprove_Mode then
+ elsif Expander_Active then
Ensure_Defined (Typ => Slice_Subtype, N => N);
end if;
end Set_Slice_Subtype;
@@ -12630,10 +12727,7 @@ package body Sem_Res is
Set_Etype (Array_Subtype, Base_Type (Typ));
Set_Is_Constrained (Array_Subtype, True);
- Rewrite (N,
- Make_Unchecked_Type_Conversion (Loc,
- Subtype_Mark => New_Occurrence_Of (Array_Subtype, Loc),
- Expression => Relocate_Node (N)));
+ Rewrite (N, Unchecked_Convert_To (Array_Subtype, N));
Set_Etype (N, Array_Subtype);
end;
end if;
@@ -13570,12 +13664,24 @@ package body Sem_Res is
then
if Is_Itype (Opnd_Type) then
+ -- When applying restriction No_Dynamic_Accessibility_Check,
+ -- implicit conversions are allowed when the operand type is
+ -- not deeper than the target type.
+
+ if No_Dynamic_Accessibility_Checks_Enabled (N) then
+ if Type_Access_Level (Opnd_Type)
+ > Deepest_Type_Access_Level (Target_Type)
+ then
+ Conversion_Error_N
+ ("operand has deeper level than target", Operand);
+ end if;
+
-- Implicit conversions aren't allowed for objects of an
-- anonymous access type, since such objects have nonstatic
-- levels in Ada 2012.
- if Nkind (Associated_Node_For_Itype (Opnd_Type)) =
- N_Object_Declaration
+ elsif Nkind (Associated_Node_For_Itype (Opnd_Type))
+ = N_Object_Declaration
then
Conversion_Error_N
("implicit conversion of stand-alone anonymous "
@@ -13628,12 +13734,16 @@ package body Sem_Res is
-- 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)
+ -- Note that when the restriction No_Dynamic_Accessibility_Checks
+ -- is in effect wei also want to proceed with the conversion check
+ -- described above.
+
+ elsif Type_Access_Level (Opnd_Type, Assoc_Ent => Operand)
+ > 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
+ or else No_Dynamic_Accessibility_Checks_Enabled (N))
-- Check we are not in a return value ???
@@ -13952,7 +14062,7 @@ package body Sem_Res is
then
Conversion_Error_N ("target type must be general access type!", N);
Conversion_Error_NE -- CODEFIX
- ("add ALL to }!", N, Target_Type);
+ ("\add ALL to }!", N, Target_Type);
return False;
-- Here we have a real conversion error
diff --git a/gcc/ada/sem_res.ads b/gcc/ada/sem_res.ads
index 44a8487..1014021 100644
--- a/gcc/ada/sem_res.ads
+++ b/gcc/ada/sem_res.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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 @@ with Types; use Types;
package Sem_Res is
- -- As described in Sem_Ch4, the type resolution proceeds in two phases.
+ -- As described in Sem_Type, the type resolution proceeds in two phases.
-- The first phase is a bottom up pass that is achieved during the
-- recursive traversal performed by the Analyze procedures. This phase
-- determines unambiguous types, and collects sets of possible types
diff --git a/gcc/ada/sem_scil.adb b/gcc/ada/sem_scil.adb
index 56902b0..f56d95e 100644
--- a/gcc/ada/sem_scil.adb
+++ b/gcc/ada/sem_scil.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2009-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2009-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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,13 +23,16 @@
-- --
------------------------------------------------------------------------------
-with Einfo; use Einfo;
-with Nlists; use Nlists;
-with Rtsfind; use Rtsfind;
-with Sem_Aux; use Sem_Aux;
-with Sinfo; use Sinfo;
-with Stand; use Stand;
-with SCIL_LL; use SCIL_LL;
+with Einfo; use Einfo;
+with Einfo.Entities; use Einfo.Entities;
+with Einfo.Utils; use Einfo.Utils;
+with Nlists; use Nlists;
+with Rtsfind; use Rtsfind;
+with Sem_Aux; use Sem_Aux;
+with Sinfo; use Sinfo;
+with Sinfo.Nodes; use Sinfo.Nodes;
+with Stand; use Stand;
+with SCIL_LL; use SCIL_LL;
package body Sem_SCIL is
@@ -71,13 +74,12 @@ package body Sem_SCIL is
-- Interface types are unsupported
if Is_Interface (Ctrl_Typ)
- or else (RTE_Available (RE_Interface_Tag)
- and then Ctrl_Typ = RTE (RE_Interface_Tag))
+ or else Is_RTE (Ctrl_Typ, RE_Interface_Tag)
then
null;
else
- pragma Assert (Ctrl_Typ = RTE (RE_Tag));
+ pragma Assert (Is_RTE (Ctrl_Typ, RE_Tag));
null;
end if;
@@ -94,8 +96,7 @@ package body Sem_SCIL is
-- Interface types are unsupported.
if Is_Interface (Ctrl_Typ)
- or else (RTE_Available (RE_Interface_Tag)
- and then Ctrl_Typ = RTE (RE_Interface_Tag))
+ or else Is_RTE (Ctrl_Typ, RE_Interface_Tag)
or else (Is_Access_Type (Ctrl_Typ)
and then
Is_Interface
@@ -106,12 +107,14 @@ package body Sem_SCIL is
else
pragma Assert
- (Ctrl_Typ = RTE (RE_Tag)
+ (Is_RTE (Ctrl_Typ, RE_Tag)
or else
(Is_Access_Type (Ctrl_Typ)
- and then Available_View
- (Base_Type (Designated_Type (Ctrl_Typ)))
- = RTE (RE_Tag)));
+ and then
+ Is_RTE
+ (Available_View
+ (Base_Type (Designated_Type (Ctrl_Typ))),
+ RE_Tag)));
null;
end if;
@@ -167,7 +170,7 @@ package body Sem_SCIL is
-- tag of the tested object (i.e. Obj.Tag).
when N_Selected_Component =>
- pragma Assert (Etype (Ctrl_Tag) = RTE (RE_Tag));
+ pragma Assert (Is_RTE (Etype (Ctrl_Tag), RE_Tag));
null;
when others =>
diff --git a/gcc/ada/sem_scil.ads b/gcc/ada/sem_scil.ads
index 3916e9e..78f969b 100644
--- a/gcc/ada/sem_scil.ads
+++ b/gcc/ada/sem_scil.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2009-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2009-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute 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 38fa1fa..fff850b 100644
--- a/gcc/ada/sem_smem.adb
+++ b/gcc/ada/sem_smem.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1998-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1998-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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,13 +23,16 @@
-- --
------------------------------------------------------------------------------
-with Atree; use Atree;
-with Einfo; use Einfo;
-with Errout; use Errout;
-with Namet; use Namet;
-with Sem_Aux; use Sem_Aux;
-with Sinfo; use Sinfo;
-with Snames; use Snames;
+with Atree; use Atree;
+with Einfo; use Einfo;
+with Einfo.Entities; use Einfo.Entities;
+with Einfo.Utils; use Einfo.Utils;
+with Errout; use Errout;
+with Namet; use Namet;
+with Sem_Aux; use Sem_Aux;
+with Sinfo; use Sinfo;
+with Sinfo.Nodes; use Sinfo.Nodes;
+with Snames; use Snames;
package body Sem_Smem is
diff --git a/gcc/ada/sem_smem.ads b/gcc/ada/sem_smem.ads
index ec497da..73555a6 100644
--- a/gcc/ada/sem_smem.ads
+++ b/gcc/ada/sem_smem.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1998-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1998-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute 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 8dbfa18..396f616 100644
--- a/gcc/ada/sem_type.adb
+++ b/gcc/ada/sem_type.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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,32 +23,38 @@
-- --
------------------------------------------------------------------------------
-with Aspects; use Aspects;
-with Atree; use Atree;
+with Aspects; use Aspects;
+with Atree; use Atree;
with Alloc;
-with Debug; use Debug;
-with Einfo; use Einfo;
-with Elists; use Elists;
-with Nlists; use Nlists;
-with Errout; use Errout;
-with Lib; use Lib;
-with Namet; use Namet;
-with Opt; use Opt;
-with Output; use Output;
-with Sem; use Sem;
-with Sem_Aux; use Sem_Aux;
-with Sem_Ch6; use Sem_Ch6;
-with Sem_Ch8; use Sem_Ch8;
-with Sem_Ch12; use Sem_Ch12;
-with Sem_Disp; use Sem_Disp;
-with Sem_Dist; use Sem_Dist;
-with Sem_Util; use Sem_Util;
-with Stand; use Stand;
-with Sinfo; use Sinfo;
-with Snames; use Snames;
+with Debug; use Debug;
+with Einfo; use Einfo;
+with Einfo.Entities; use Einfo.Entities;
+with Einfo.Utils; use Einfo.Utils;
+with Elists; use Elists;
+with Nlists; use Nlists;
+with Errout; use Errout;
+with Lib; use Lib;
+with Namet; use Namet;
+with Opt; use Opt;
+with Output; use Output;
+with Sem; use Sem;
+with Sem_Aux; use Sem_Aux;
+with Sem_Ch6; use Sem_Ch6;
+with Sem_Ch8; use Sem_Ch8;
+with Sem_Ch12; use Sem_Ch12;
+with Sem_Disp; use Sem_Disp;
+with Sem_Dist; use Sem_Dist;
+with Sem_Util; use Sem_Util;
+with Stand; use Stand;
+with Sinfo; use Sinfo;
+with Sinfo.Nodes; use Sinfo.Nodes;
+with Sinfo.Utils; use Sinfo.Utils;
+with Snames; use Snames;
with Table;
-with Treepr; use Treepr;
-with Uintp; use Uintp;
+with Treepr; use Treepr;
+with Uintp; use Uintp;
+
+with GNAT.HTable; use GNAT.HTable;
package body Sem_Type is
@@ -60,21 +66,17 @@ package body Sem_Type is
-- their interpretations. An overloaded node has an entry in Interp_Map,
-- which in turn contains a pointer into the All_Interp array. The
-- interpretations of a given node are contiguous in All_Interp. Each set
- -- of interpretations is terminated with the marker No_Interp. In order to
- -- speed up the retrieval of the interpretations of an overloaded node, the
- -- Interp_Map table is accessed by means of a simple hashing scheme, and
- -- the entries in Interp_Map are chained. The heads of clash lists are
- -- stored in array Headers.
-
- -- Headers Interp_Map All_Interp
-
- -- _ +-----+ +--------+
- -- |_| |_____| --->|interp1 |
- -- |_|---------->|node | | |interp2 |
- -- |_| |index|---------| |nointerp|
- -- |_| |next | | |
- -- |-----| | |
- -- +-----+ +--------+
+ -- of interpretations is terminated with the marker No_Interp.
+
+ -- Interp_Map All_Interp
+
+ -- +-----+ +--------+
+ -- | | --->|interp1 |
+ -- |_____| | |interp2 |
+ -- |index|---------| |nointerp|
+ -- |-----| | |
+ -- | | | |
+ -- +-----+ +--------+
-- This scheme does not currently reclaim interpretations. In principle,
-- after a unit is compiled, all overloadings have been resolved, and the
@@ -89,28 +91,26 @@ package body Sem_Type is
Table_Increment => Alloc.All_Interp_Increment,
Table_Name => "All_Interp");
- type Interp_Ref is record
- Node : Node_Id;
- Index : Interp_Index;
- Next : Int;
- end record;
+ Header_Max : constant := 3079;
+ -- The number of hash buckets; an arbitrary prime number
- Header_Size : constant Int := 2 ** 12;
- No_Entry : constant Int := -1;
- Headers : array (0 .. Header_Size) of Int := (others => No_Entry);
+ subtype Header_Num is Integer range 0 .. Header_Max - 1;
- package Interp_Map is new Table.Table (
- Table_Component_Type => Interp_Ref,
- Table_Index_Type => Int,
- Table_Low_Bound => 0,
- Table_Initial => Alloc.Interp_Map_Initial,
- Table_Increment => Alloc.Interp_Map_Increment,
- Table_Name => "Interp_Map");
-
- function Hash (N : Node_Id) return Int;
+ function Hash (N : Node_Id) return Header_Num;
-- A trivial hashing function for nodes, used to insert an overloaded
-- node into the Interp_Map table.
+ package Interp_Map is new Simple_HTable
+ (Header_Num => Header_Num,
+ Element => Interp_Index,
+ No_Element => -1,
+ Key => Node_Id,
+ Hash => Hash,
+ Equal => "=");
+
+ Last_Overloaded : Node_Id := Empty;
+ -- Overloaded node after initializing a new collection of intepretation
+
-------------------------------------
-- Handling of Overload Resolution --
-------------------------------------
@@ -243,6 +243,13 @@ package body Sem_Type is
Get_First_Interp (N, I, It);
while Present (It.Nam) loop
+ -- Avoid making duplicate entries in overloads
+
+ if Name = It.Nam
+ and then Base_Type (It.Typ) = Base_Type (T)
+ then
+ return;
+
-- A user-defined subprogram hides another declared at an outer
-- level, or one that is use-visible. So return if previous
-- definition hides new one (which is either in an outer
@@ -252,7 +259,7 @@ package body Sem_Type is
-- If this is a universal operation, retain the operator in case
-- preference rule applies.
- if (((Ekind (Name) = E_Function or else Ekind (Name) = E_Procedure)
+ elsif ((Ekind (Name) in E_Function | E_Procedure
and then Ekind (Name) = Ekind (It.Nam))
or else (Ekind (Name) = E_Operator
and then Ekind (It.Nam) = E_Function))
@@ -296,13 +303,6 @@ package body Sem_Type is
return;
end if;
- -- Avoid making duplicate entries in overloads
-
- elsif Name = It.Nam
- and then Base_Type (It.Typ) = Base_Type (T)
- then
- return;
-
-- Otherwise keep going
else
@@ -479,9 +479,9 @@ package body Sem_Type is
-- node or the interpretation that is present is for a different
-- node. In both cases add a new interpretation to the table.
- elsif Interp_Map.Last < 0
+ elsif No (Last_Overloaded)
or else
- (Interp_Map.Table (Interp_Map.Last).Node /= N
+ (Last_Overloaded /= N
and then not Is_Overloaded (N))
then
New_Interps (N);
@@ -1020,10 +1020,10 @@ package body Sem_Type is
elsif T2 = Any_Composite and then Is_Aggregate_Type (T1) then
return True;
- -- In Ada_2020, an aggregate is compatible with the type that
- -- as the ccorrespoding aspect.
+ -- In Ada_2022, an aggregate is compatible with the type that
+ -- as the corresponding aspect.
- elsif Ada_Version >= Ada_2020
+ elsif Ada_Version >= Ada_2022
and then T2 = Any_Composite
and then Present (Find_Aspect (T1, Aspect_Aggregate))
then
@@ -1810,26 +1810,42 @@ package body Sem_Type is
It2 := It;
Nam2 := It.Nam;
- -- Check whether one of the entities is an Ada 2005/2012 and we are
- -- operating in an earlier mode, in which case we discard the Ada
- -- 2005/2012 entity, so that we get proper Ada 95 overload resolution.
+ -- Check whether one of the entities is an Ada 2005/2012/2022 and we
+ -- are operating in an earlier mode, in which case we discard the Ada
+ -- 2005/2012/2022 entity, so that we get proper Ada 95 overload
+ -- resolution.
if Ada_Version < Ada_2005 then
- if Is_Ada_2005_Only (Nam1) or else Is_Ada_2012_Only (Nam1) then
+ if Is_Ada_2005_Only (Nam1)
+ or else Is_Ada_2012_Only (Nam1)
+ or else Is_Ada_2022_Only (Nam1)
+ then
return It2;
- elsif Is_Ada_2005_Only (Nam2) or else Is_Ada_2012_Only (Nam1) then
+
+ elsif Is_Ada_2005_Only (Nam2)
+ or else Is_Ada_2012_Only (Nam2)
+ or else Is_Ada_2022_Only (Nam2)
+ then
return It1;
end if;
- end if;
- -- Check whether one of the entities is an Ada 2012 entity and we are
- -- operating in Ada 2005 mode, in which case we discard the Ada 2012
- -- entity, so that we get proper Ada 2005 overload resolution.
+ -- Check whether one of the entities is an Ada 2012/2022 entity and we
+ -- are operating in Ada 2005 mode, in which case we discard the Ada 2012
+ -- Ada 2022 entity, so that we get proper Ada 2005 overload resolution.
- if Ada_Version = Ada_2005 then
- if Is_Ada_2012_Only (Nam1) then
+ elsif Ada_Version = Ada_2005 then
+ if Is_Ada_2012_Only (Nam1) or else Is_Ada_2022_Only (Nam1) then
return It2;
- elsif Is_Ada_2012_Only (Nam2) then
+ elsif Is_Ada_2012_Only (Nam2) or else Is_Ada_2022_Only (Nam2) then
+ return It1;
+ end if;
+
+ -- Ditto for Ada 2012 vs Ada 2022.
+
+ elsif Ada_Version = Ada_2012 then
+ if Is_Ada_2022_Only (Nam1) then
+ return It2;
+ elsif Is_Ada_2022_Only (Nam2) then
return It1;
end if;
end if;
@@ -1857,8 +1873,7 @@ package body Sem_Type is
begin
Get_First_Interp (N, I, It);
while Present (It.Typ) loop
- if (It.Typ = Universal_Integer
- or else It.Typ = Universal_Real)
+ if Is_Universal_Numeric_Type (It.Typ)
and then (Typ = Any_Type or else Covers (Typ, It.Typ))
then
return It;
@@ -2232,16 +2247,6 @@ package body Sem_Type is
end if;
end Disambiguate;
- ---------------------
- -- End_Interp_List --
- ---------------------
-
- procedure End_Interp_List is
- begin
- All_Interp.Table (All_Interp.Last) := No_Interp;
- All_Interp.Increment_Last;
- end End_Interp_List;
-
-------------------------
-- Entity_Matches_Spec --
-------------------------
@@ -2288,7 +2293,7 @@ package body Sem_Type is
-- apply preference rule.
if TR /= Any_Type then
- if (T = Universal_Integer or else T = Universal_Real)
+ if Is_Universal_Numeric_Type (T)
and then It.Typ = T
then
TR := It.Typ;
@@ -2380,7 +2385,6 @@ package body Sem_Type is
It : out Interp)
is
Int_Ind : Interp_Index;
- Map_Ptr : Int;
O_N : Node_Id;
begin
@@ -2398,21 +2402,16 @@ package body Sem_Type is
O_N := N;
end if;
- Map_Ptr := Headers (Hash (O_N));
- while Map_Ptr /= No_Entry loop
- if Interp_Map.Table (Map_Ptr).Node = O_N then
- Int_Ind := Interp_Map.Table (Map_Ptr).Index;
- It := All_Interp.Table (Int_Ind);
- I := Int_Ind;
- return;
- else
- Map_Ptr := Interp_Map.Table (Map_Ptr).Next;
- end if;
- end loop;
+ Int_Ind := Interp_Map.Get (O_N);
-- Procedure should never be called if the node has no interpretations
- raise Program_Error;
+ if Int_Ind < 0 then
+ raise Program_Error;
+ end if;
+
+ I := Int_Ind;
+ It := All_Interp.Table (Int_Ind);
end Get_First_Interp;
---------------------
@@ -2545,12 +2544,9 @@ package body Sem_Type is
-- Hash --
----------
- function Hash (N : Node_Id) return Int is
+ function Hash (N : Node_Id) return Header_Num is
begin
- -- Nodes have a size that is power of two, so to select significant
- -- bits only we remove the low-order bits.
-
- return ((Int (N) / 2 ** 5) mod Header_Size);
+ return Header_Num (N mod Header_Max);
end Hash;
--------------
@@ -2575,8 +2571,7 @@ package body Sem_Type is
procedure Init_Interp_Tables is
begin
All_Interp.Init;
- Interp_Map.Init;
- Headers := (others => No_Entry);
+ Interp_Map.Reset;
end Init_Interp_Tables;
-----------------------------------
@@ -3094,47 +3089,12 @@ package body Sem_Type is
-----------------
procedure New_Interps (N : Node_Id) is
- Map_Ptr : Int;
-
begin
All_Interp.Append (No_Interp);
- Map_Ptr := Headers (Hash (N));
-
- if Map_Ptr = No_Entry then
-
- -- Place new node at end of table
-
- Interp_Map.Increment_Last;
- Headers (Hash (N)) := Interp_Map.Last;
-
- else
- -- Place node at end of chain, or locate its previous entry
-
- loop
- if Interp_Map.Table (Map_Ptr).Node = N then
-
- -- Node is already in the table, and is being rewritten.
- -- Start a new interp section, retain hash link.
-
- Interp_Map.Table (Map_Ptr).Node := N;
- Interp_Map.Table (Map_Ptr).Index := All_Interp.Last;
- Set_Is_Overloaded (N, True);
- return;
-
- else
- exit when Interp_Map.Table (Map_Ptr).Next = No_Entry;
- Map_Ptr := Interp_Map.Table (Map_Ptr).Next;
- end if;
- end loop;
-
- -- Chain the new node
-
- Interp_Map.Increment_Last;
- Interp_Map.Table (Map_Ptr).Next := Interp_Map.Last;
- end if;
-
- Interp_Map.Table (Interp_Map.Last) := (N, All_Interp.Last, No_Entry);
+ -- Add or rewrite the existing node
+ Last_Overloaded := N;
+ Interp_Map.Set (N, All_Interp.Last);
Set_Is_Overloaded (N, True);
end New_Interps;
@@ -3319,8 +3279,8 @@ package body Sem_Type is
------------------
procedure Save_Interps (Old_N : Node_Id; New_N : Node_Id) is
- Map_Ptr : Int;
- O_N : Node_Id := Old_N;
+ Old_Ind : Interp_Index;
+ O_N : Node_Id;
begin
if Is_Overloaded (Old_N) then
@@ -3330,18 +3290,15 @@ package body Sem_Type is
and then Is_Overloaded (Selector_Name (Old_N))
then
O_N := Selector_Name (Old_N);
+ else
+ O_N := Old_N;
end if;
- Map_Ptr := Headers (Hash (O_N));
-
- while Interp_Map.Table (Map_Ptr).Node /= O_N loop
- Map_Ptr := Interp_Map.Table (Map_Ptr).Next;
- pragma Assert (Map_Ptr /= No_Entry);
- end loop;
+ Old_Ind := Interp_Map.Get (O_N);
+ pragma Assert (Old_Ind >= 0);
New_Interps (New_N);
- Interp_Map.Table (Interp_Map.Last).Index :=
- Interp_Map.Table (Map_Ptr).Index;
+ Interp_Map.Set (New_N, Old_Ind);
end if;
end Save_Interps;
@@ -3646,21 +3603,6 @@ package body Sem_Type is
Print_Tree_Node (It.Abstract_Op);
end Write_Interp;
- ----------------------
- -- Write_Interp_Ref --
- ----------------------
-
- procedure Write_Interp_Ref (Map_Ptr : Int) is
- begin
- Write_Str (" Node: ");
- Write_Int (Int (Interp_Map.Table (Map_Ptr).Node));
- Write_Str (" Index: ");
- Write_Int (Int (Interp_Map.Table (Map_Ptr).Index));
- Write_Str (" Next: ");
- Write_Int (Interp_Map.Table (Map_Ptr).Next);
- Write_Eol;
- end Write_Interp_Ref;
-
---------------------
-- Write_Overloads --
---------------------
diff --git a/gcc/ada/sem_type.ads b/gcc/ada/sem_type.ads
index 6c6d5eb..018c283 100644
--- a/gcc/ada/sem_type.ads
+++ b/gcc/ada/sem_type.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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,7 +85,7 @@ package Sem_Type is
-- with the appropriate use clause. The global variable Candidate_Type is
-- set in Add_One_Interp whenever an interpretation might be legal for an
-- operator if the type were directly visible. This variable is used in
- -- sem_ch4 when no legal interpretation is found.
+ -- Sem_Ch4 when no legal interpretation is found.
Candidate_Type : Entity_Id;
@@ -94,7 +94,7 @@ package Sem_Type is
-----------------
procedure Init_Interp_Tables;
- -- Invoked by gnatf when processing multiple files
+ -- Initialize data structures for overload resolution
procedure Collect_Interps (N : Node_Id);
-- Invoked when the name N has more than one visible interpretation. This
@@ -130,9 +130,6 @@ package Sem_Type is
-- always Boolean, and we use Opnd_Type, which is a candidate type for one
-- of the operands of N, to check visibility.
- procedure End_Interp_List;
- -- End the list of interpretations of current node
-
procedure Get_First_Interp
(N : Node_Id;
I : out Interp_Index;
@@ -246,8 +243,7 @@ package Sem_Type is
-- in the signature of an inherited operation must carry the derived type.
function Is_Subtype_Of (T1 : Entity_Id; T2 : Entity_Id) return Boolean;
- -- Checks whether T1 is any subtype of T2 directly or indirectly. Applies
- -- only to scalar subtypes???
+ -- Checks whether T1 is any subtype of T2 directly or indirectly
function Operator_Matches_Spec (Op, New_S : Entity_Id) return Boolean;
-- Used to resolve subprograms renaming operators, and calls to user
@@ -268,10 +264,6 @@ package Sem_Type is
procedure Write_Interp (It : Interp);
-- Debugging procedure to display an Interp
- procedure Write_Interp_Ref (Map_Ptr : Int);
- -- Debugging procedure to display entry in Interp_Map. Would not be needed
- -- if it were possible to debug instantiations of Table.
-
procedure Write_Overloads (N : Node_Id);
-- Debugging procedure to output info on possibly overloaded entities for
-- specified node.
diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb
index 1cf5c69..01a4e2b 100644
--- a/gcc/ada/sem_util.adb
+++ b/gcc/ada/sem_util.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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,53 +23,56 @@
-- --
------------------------------------------------------------------------------
-with Casing; use Casing;
-with Checks; use Checks;
-with Debug; use Debug;
-with Elists; use Elists;
-with Errout; use Errout;
-with Erroutc; use Erroutc;
-with Exp_Ch3; use Exp_Ch3;
-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;
-with Nlists; use Nlists;
-with Nmake; use Nmake;
-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;
-with Sem_Attr; use Sem_Attr;
-with Sem_Cat; use Sem_Cat;
-with Sem_Ch6; use Sem_Ch6;
-with Sem_Ch8; use Sem_Ch8;
-with Sem_Ch13; use Sem_Ch13;
-with Sem_Disp; use Sem_Disp;
-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_Warn; use Sem_Warn;
-with Sem_Type; use Sem_Type;
-with Sinfo; use Sinfo;
-with Sinput; use Sinput;
-with Stand; use Stand;
+with Casing; use Casing;
+with Checks; use Checks;
+with Debug; use Debug;
+with Einfo.Utils; use Einfo.Utils;
+with Elists; use Elists;
+with Errout; use Errout;
+with Erroutc; use Erroutc;
+with Exp_Ch3; use Exp_Ch3;
+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;
+with Nlists; use Nlists;
+with Nmake; use Nmake;
+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;
+with Sem_Attr; use Sem_Attr;
+with Sem_Cat; use Sem_Cat;
+with Sem_Ch6; use Sem_Ch6;
+with Sem_Ch8; use Sem_Ch8;
+with Sem_Ch13; use Sem_Ch13;
+with Sem_Disp; use Sem_Disp;
+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_Warn; use Sem_Warn;
+with Sem_Type; use Sem_Type;
+with Sinfo; use Sinfo;
+with Sinfo.Nodes; use Sinfo.Nodes;
+with Sinfo.Utils; use Sinfo.Utils;
+with Sinput; use Sinput;
+with Stand; use Stand;
with Style;
-with Stringt; use Stringt;
-with Targparm; use Targparm;
-with Tbuild; use Tbuild;
-with Ttypes; use Ttypes;
-with Uname; use Uname;
+with Stringt; use Stringt;
+with Targparm; use Targparm;
+with Tbuild; use Tbuild;
+with Ttypes; use Ttypes;
+with Uname; use Uname;
with GNAT.Heap_Sort_G;
-with GNAT.HTable; use GNAT.HTable;
+with GNAT.HTable; use GNAT.HTable;
package body Sem_Util is
@@ -146,7 +149,7 @@ package body Sem_Util is
-- have a default.
function Is_Preelaborable_Function (Id : Entity_Id) return Boolean;
- -- Ada 2020: Determine whether the specified function is suitable as the
+ -- Ada 2022: 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
@@ -174,9 +177,9 @@ package body Sem_Util is
-- "subp:file:line:col", corresponding to the source location of the
-- body of the subprogram.
- ------------------------------
- -- Abstract_Interface_List --
- ------------------------------
+ -----------------------------
+ -- Abstract_Interface_List --
+ -----------------------------
function Abstract_Interface_List (Typ : Entity_Id) return List_Id is
Nod : Node_Id;
@@ -257,7 +260,8 @@ package body Sem_Util is
function Accessibility_Level
(Expr : Node_Id;
Level : Accessibility_Level_Kind;
- In_Return_Context : Boolean := False) return Node_Id
+ In_Return_Context : Boolean := False;
+ Allow_Alt_Model : Boolean := True) return Node_Id
is
Loc : constant Source_Ptr := Sloc (Expr);
@@ -269,25 +273,27 @@ package body Sem_Util is
-- Construct an integer literal representing an accessibility level
-- with its type set to Natural.
- function Innermost_Master_Scope_Depth
- (N : Node_Id) return Uint;
+ function Innermost_Master_Scope_Depth (N : Node_Id) return Uint;
-- Returns the scope depth of the given node's innermost
-- enclosing dynamic scope (effectively the accessibility
-- level of the innermost enclosing master).
- function Function_Call_Or_Allocator_Level
- (N : Node_Id) return Node_Id;
+ function Function_Call_Or_Allocator_Level (N : Node_Id) return Node_Id;
-- Centralized processing of subprogram calls which may appear in
-- prefix notation.
+ function Typ_Access_Level (Typ : Entity_Id) return Uint
+ is (Type_Access_Level (Typ, Allow_Alt_Model));
+ -- Renaming of Type_Access_Level with Allow_Alt_Model specified to avoid
+ -- passing the parameter specifically in every call.
+
----------------------------------
-- Innermost_Master_Scope_Depth --
----------------------------------
- function Innermost_Master_Scope_Depth
- (N : Node_Id) return Uint
- is
+ function Innermost_Master_Scope_Depth (N : Node_Id) return Uint is
Encl_Scop : Entity_Id;
+ Ent : Entity_Id;
Node_Par : Node_Id := Parent (N);
Master_Lvl_Modifier : Int := 0;
@@ -301,12 +307,10 @@ package body Sem_Util is
-- among other things. These cases are detected properly ???
while Present (Node_Par) loop
+ Ent := Defining_Entity_Or_Empty (Node_Par);
- if Present (Defining_Entity
- (Node_Par, Empty_On_Errors => True))
- then
- Encl_Scop := Nearest_Dynamic_Scope
- (Defining_Entity (Node_Par));
+ if Present (Ent) then
+ Encl_Scop := Nearest_Dynamic_Scope (Ent);
-- Ignore transient scopes made during expansion
@@ -377,7 +381,7 @@ package body Sem_Util is
(Subprogram_Access_Level (Entity (Name (N))));
else
return Make_Level_Literal
- (Type_Access_Level (Etype (Prefix (Name (N)))));
+ (Typ_Access_Level (Etype (Prefix (Name (N)))));
end if;
-- We ignore coextensions as they cannot be implemented under the
@@ -394,19 +398,40 @@ package body Sem_Util is
-- Named access types have a designated level
if Is_Named_Access_Type (Etype (N)) then
- return Make_Level_Literal (Type_Access_Level (Etype (N)));
+ return Make_Level_Literal (Typ_Access_Level (Etype (N)));
-- Otherwise, the level is dictated by RM 3.10.2 (10.7/3)
else
+ -- Check No_Dynamic_Accessibility_Checks restriction override for
+ -- alternative accessibility model.
+
+ if Allow_Alt_Model
+ and then No_Dynamic_Accessibility_Checks_Enabled (N)
+ and then Is_Anonymous_Access_Type (Etype (N))
+ then
+ -- In the alternative model the level is that of the
+ -- designated type.
+
+ if Debug_Flag_Underscore_B then
+ return Make_Level_Literal (Typ_Access_Level (Etype (N)));
+
+ -- Otherwise the level is that of the subprogram
+
+ else
+ return Make_Level_Literal
+ (Subprogram_Access_Level (Entity (Name (N))));
+ end if;
+ end if;
+
if Nkind (N) = N_Function_Call then
-- Dynamic checks are generated when we are within a return
-- value or we are in a function call within an anonymous
-- access discriminant constraint of a return object (signified
-- by In_Return_Context) on the side of the callee.
- -- So, in this case, return library accessibility level to null
- -- out the check on the side of the caller.
+ -- So, in this case, return accessibility level of the
+ -- enclosing subprogram.
if In_Return_Value (N)
or else In_Return_Context
@@ -416,6 +441,17 @@ package body Sem_Util is
end if;
end if;
+ -- When the call is being dereferenced the level is that of the
+ -- enclosing master of the dereferenced call.
+
+ if Nkind (Parent (N)) in N_Explicit_Dereference
+ | N_Indexed_Component
+ | N_Selected_Component
+ then
+ return Make_Level_Literal
+ (Innermost_Master_Scope_Depth (Expr));
+ end if;
+
-- Find any relevant enclosing parent nodes that designate an
-- object being initialized.
@@ -436,7 +472,7 @@ package body Sem_Util is
and then Is_Named_Access_Type (Etype (Par))
then
return Make_Level_Literal
- (Type_Access_Level (Etype (Par)));
+ (Typ_Access_Level (Etype (Par)));
end if;
-- Jump out when we hit an object declaration or the right-hand
@@ -553,7 +589,7 @@ package body Sem_Util is
if Is_Named_Access_Type (Etype (Pre)) then
return Make_Level_Literal
- (Type_Access_Level (Etype (Pre)));
+ (Typ_Access_Level (Etype (Pre)));
-- Anonymous access types
@@ -618,8 +654,34 @@ package body Sem_Util is
(Scope_Depth (Standard_Standard));
end if;
- return
- New_Occurrence_Of (Get_Dynamic_Accessibility (E), Loc);
+ -- No_Dynamic_Accessibility_Checks restriction override for
+ -- alternative accessibility model.
+
+ if Allow_Alt_Model
+ and then No_Dynamic_Accessibility_Checks_Enabled (E)
+ then
+ -- In the alternative model the level is that of the
+ -- designated type entity's context.
+
+ if Debug_Flag_Underscore_B then
+ return Make_Level_Literal (Typ_Access_Level (Etype (E)));
+
+ -- Otherwise the level depends on the entity's context
+
+ elsif Is_Formal (E) then
+ return Make_Level_Literal
+ (Subprogram_Access_Level
+ (Enclosing_Subprogram (E)));
+ else
+ return Make_Level_Literal
+ (Scope_Depth (Enclosing_Dynamic_Scope (E)));
+ end if;
+ end if;
+
+ -- Return the dynamic level in the normal case
+
+ return New_Occurrence_Of
+ (Get_Dynamic_Accessibility (E), Loc);
-- Initialization procedures have a special extra accessitility
-- parameter associated with the level at which the object
@@ -637,8 +699,19 @@ package body Sem_Util is
-- according to RM 3.10.2 (21).
elsif Is_Type (E) then
- return Make_Level_Literal
- (Type_Access_Level (E) + 1);
+ -- When restriction No_Dynamic_Accessibility_Checks is active
+ -- along with -gnatd_b.
+
+ if Allow_Alt_Model
+ and then No_Dynamic_Accessibility_Checks_Enabled (E)
+ and then Debug_Flag_Underscore_B
+ then
+ return Make_Level_Literal (Typ_Access_Level (E));
+ end if;
+
+ -- Normal path
+
+ return Make_Level_Literal (Typ_Access_Level (E) + 1);
-- Move up the renamed entity if it came from source since
-- expansion may have created a dummy renaming under certain
@@ -653,7 +726,7 @@ package body Sem_Util is
elsif Is_Named_Access_Type (Etype (E)) then
return Make_Level_Literal
- (Type_Access_Level (Etype (E)));
+ (Typ_Access_Level (Etype (E)));
-- When E is a component of the current instance of a
-- protected type, we assume the level to be deeper than that of
@@ -666,6 +739,15 @@ package body Sem_Util is
return Make_Level_Literal
(Scope_Depth (Enclosing_Dynamic_Scope (E)) + 1);
+ -- Check if E is an expansion-generated renaming of an iterator
+ -- by examining Related_Expression. If so, determine the
+ -- accessibility level based on the original expression.
+
+ elsif Ekind (E) in E_Constant | E_Variable
+ and then Present (Related_Expression (E))
+ then
+ return Accessibility_Level (Related_Expression (E));
+
-- Normal object - get the level of the enclosing scope
else
@@ -695,7 +777,7 @@ package body Sem_Util is
elsif Is_Named_Access_Type (Etype (Pre)) then
return Make_Level_Literal
- (Type_Access_Level (Etype (Pre)));
+ (Typ_Access_Level (Etype (Pre)));
-- The current expression is a named access type, so there is no
-- reason to look at the prefix. Instead obtain the level of E's
@@ -703,21 +785,44 @@ package body Sem_Util is
elsif Is_Named_Access_Type (Etype (E)) then
return Make_Level_Literal
- (Type_Access_Level (Etype (E)));
+ (Typ_Access_Level (Etype (E)));
- -- A non-discriminant selected component where the component
+ -- A nondiscriminant selected component where the component
-- is an anonymous access type means that its associated
-- level is that of the containing type - see RM 3.10.2 (16).
+ -- Note that when restriction No_Dynamic_Accessibility_Checks is
+ -- in effect we treat discriminant components as regular
+ -- components.
+
elsif Nkind (E) = N_Selected_Component
and then Ekind (Etype (E)) = E_Anonymous_Access_Type
and then Ekind (Etype (Pre)) /= E_Anonymous_Access_Type
- and then not (Nkind (Selector_Name (E)) in N_Has_Entity
- and then Ekind (Entity (Selector_Name (E)))
- = E_Discriminant)
+ and then (not (Nkind (Selector_Name (E)) in N_Has_Entity
+ and then Ekind (Entity (Selector_Name (E)))
+ = E_Discriminant)
+
+ -- The alternative accessibility models both treat
+ -- discriminants as regular components.
+
+ or else (No_Dynamic_Accessibility_Checks_Enabled (E)
+ and then Allow_Alt_Model))
then
+ -- When restriction No_Dynamic_Accessibility_Checks is active
+ -- and -gnatd_b set, the level is that of the designated type.
+
+ if Allow_Alt_Model
+ and then No_Dynamic_Accessibility_Checks_Enabled (E)
+ and then Debug_Flag_Underscore_B
+ then
+ return Make_Level_Literal
+ (Typ_Access_Level (Etype (E)));
+ end if;
+
+ -- Otherwise proceed normally
+
return Make_Level_Literal
- (Type_Access_Level (Etype (Prefix (E))));
+ (Typ_Access_Level (Etype (Prefix (E))));
-- Similar to the previous case - arrays featuring components of
-- anonymous access components get their corresponding level from
@@ -729,8 +834,21 @@ package body Sem_Util is
and then Ekind (Component_Type (Base_Type (Etype (Pre))))
= E_Anonymous_Access_Type
then
+ -- When restriction No_Dynamic_Accessibility_Checks is active
+ -- and -gnatd_b set, the level is that of the designated type.
+
+ if Allow_Alt_Model
+ and then No_Dynamic_Accessibility_Checks_Enabled (E)
+ and then Debug_Flag_Underscore_B
+ then
+ return Make_Level_Literal
+ (Typ_Access_Level (Etype (E)));
+ end if;
+
+ -- Otherwise proceed normally
+
return Make_Level_Literal
- (Type_Access_Level (Etype (Prefix (E))));
+ (Typ_Access_Level (Etype (Prefix (E))));
-- The accessibility calculation routine that handles function
-- calls (Function_Call_Level) assumes, in the case the
@@ -778,7 +896,7 @@ package body Sem_Util is
when N_Qualified_Expression =>
if Is_Named_Access_Type (Etype (E)) then
return Make_Level_Literal
- (Type_Access_Level (Etype (E)));
+ (Typ_Access_Level (Etype (E)));
else
return Accessibility_Level (Expression (E));
end if;
@@ -797,7 +915,7 @@ package body Sem_Util is
-- its type.
if Is_Named_Access_Type (Etype (Pre)) then
- return Make_Level_Literal (Type_Access_Level (Etype (Pre)));
+ return Make_Level_Literal (Typ_Access_Level (Etype (Pre)));
-- Otherwise, recurse deeper
@@ -824,7 +942,7 @@ package body Sem_Util is
elsif Is_Named_Access_Type (Etype (E)) then
return Make_Level_Literal
- (Type_Access_Level (Etype (E)));
+ (Typ_Access_Level (Etype (E)));
-- In section RM 3.10.2 (10/4) the accessibility rules for
-- aggregates and value conversions are outlined. Are these
@@ -840,7 +958,7 @@ package body Sem_Util is
-- expression's entity.
when others =>
- return Make_Level_Literal (Type_Access_Level (Etype (E)));
+ return Make_Level_Literal (Typ_Access_Level (Etype (E)));
end case;
end Accessibility_Level;
@@ -1000,11 +1118,7 @@ package body Sem_Util is
and then Is_Entity_Name (Name (Expr))
and then Is_RTE (Entity (Name (Expr)), RE_To_Address)
then
- Expr := First (Parameter_Associations (Expr));
-
- if Nkind (Expr) = N_Parameter_Association then
- Expr := Explicit_Actual_Parameter (Expr);
- end if;
+ Expr := First_Actual (Expr);
-- We finally have the real expression
@@ -1406,14 +1520,14 @@ package body Sem_Util is
-----------------------------------------
procedure Apply_Compile_Time_Constraint_Error
- (N : Node_Id;
- Msg : String;
- Reason : RT_Exception_Code;
- Ent : Entity_Id := Empty;
- Typ : Entity_Id := Empty;
- Loc : Source_Ptr := No_Location;
- Rep : Boolean := True;
- Warn : Boolean := False)
+ (N : Node_Id;
+ Msg : String;
+ Reason : RT_Exception_Code;
+ Ent : Entity_Id := Empty;
+ Typ : Entity_Id := Empty;
+ Loc : Source_Ptr := No_Location;
+ Warn : Boolean := False;
+ Emit_Message : Boolean := True)
is
Stat : constant Boolean := Is_Static_Expression (N);
R_Stat : constant Node_Id :=
@@ -1427,17 +1541,9 @@ package body Sem_Util is
Rtyp := Typ;
end if;
- Discard_Node
- (Compile_Time_Constraint_Error (N, Msg, Ent, Loc, Warn => Warn));
-
- -- In GNATprove mode, do not replace the node with an exception raised.
- -- In such a case, either the call to Compile_Time_Constraint_Error
- -- issues an error which stops analysis, or it issues a warning in
- -- a few cases where a suitable check flag is set for GNATprove to
- -- generate a check message.
-
- if not Rep or GNATprove_Mode then
- return;
+ if Emit_Message then
+ Discard_Node
+ (Compile_Time_Constraint_Error (N, Msg, Ent, Loc, Warn => Warn));
end if;
-- Now we replace the node by an N_Raise_Constraint_Error node
@@ -1676,6 +1782,7 @@ package body Sem_Util is
Subt : Entity_Id;
Disc_Type : Entity_Id;
Obj : Node_Id;
+ Index : Node_Id;
begin
Loc := Sloc (N);
@@ -1706,6 +1813,8 @@ package body Sem_Util is
if Is_Array_Type (T) then
Constraints := New_List;
+ Index := First_Index (T);
+
for J in 1 .. Number_Dimensions (T) loop
-- Build an array subtype declaration with the nominal subtype and
@@ -1713,13 +1822,24 @@ package body Sem_Util is
-- local declarations for the subprogram, for analysis before any
-- reference to the formal in the body.
- Lo :=
- Make_Attribute_Reference (Loc,
- Prefix =>
- Duplicate_Subexpr_No_Checks (Obj, Name_Req => True),
- Attribute_Name => Name_First,
- Expressions => New_List (
- Make_Integer_Literal (Loc, J)));
+ -- If this is for an index with a fixed lower bound, then use
+ -- the fixed lower bound as the lower bound of the actual
+ -- subtype's corresponding index.
+
+ if not Is_Constrained (T)
+ and then Is_Fixed_Lower_Bound_Index_Subtype (Etype (Index))
+ then
+ Lo := New_Copy_Tree (Type_Low_Bound (Etype (Index)));
+
+ else
+ Lo :=
+ Make_Attribute_Reference (Loc,
+ Prefix =>
+ Duplicate_Subexpr_No_Checks (Obj, Name_Req => True),
+ Attribute_Name => Name_First,
+ Expressions => New_List (
+ Make_Integer_Literal (Loc, J)));
+ end if;
Hi :=
Make_Attribute_Reference (Loc,
@@ -1730,6 +1850,8 @@ package body Sem_Util is
Make_Integer_Literal (Loc, J)));
Append (Make_Range (Loc, Lo, Hi), Constraints);
+
+ Next_Index (Index);
end loop;
-- If the type has unknown discriminants there is no constrained
@@ -2008,7 +2130,7 @@ package body Sem_Util is
-- the original constraint from its component declaration.
Sel := Entity (Selector_Name (N));
- if Nkind (Parent (Sel)) /= N_Component_Declaration then
+ if Parent_Kind (Sel) /= N_Component_Declaration then
return Empty;
end if;
end if;
@@ -2900,6 +3022,32 @@ package body Sem_Util is
-----------------------------------
function Cannot_Raise_Constraint_Error (Expr : Node_Id) return Boolean is
+
+ function List_Cannot_Raise_CE (L : List_Id) return Boolean;
+ -- Returns True if none of the list members cannot possibly raise
+ -- Constraint_Error.
+
+ --------------------------
+ -- List_Cannot_Raise_CE --
+ --------------------------
+
+ function List_Cannot_Raise_CE (L : List_Id) return Boolean is
+ N : Node_Id;
+ begin
+ N := First (L);
+ while Present (N) loop
+ if Cannot_Raise_Constraint_Error (N) then
+ Next (N);
+ else
+ return False;
+ end if;
+ end loop;
+
+ return True;
+ end List_Cannot_Raise_CE;
+
+ -- Start of processing for Cannot_Raise_Constraint_Error
+
begin
if Compile_Time_Known_Value (Expr) then
return True;
@@ -2918,8 +3066,14 @@ package body Sem_Util is
when N_Expanded_Name =>
return True;
+ when N_Indexed_Component =>
+ return not Do_Range_Check (Expr)
+ and then Cannot_Raise_Constraint_Error (Prefix (Expr))
+ and then List_Cannot_Raise_CE (Expressions (Expr));
+
when N_Selected_Component =>
- return not Do_Discriminant_Check (Expr);
+ return not Do_Discriminant_Check (Expr)
+ and then Cannot_Raise_Constraint_Error (Prefix (Expr));
when N_Attribute_Reference =>
if Do_Overflow_Check (Expr) then
@@ -2929,27 +3083,12 @@ package body Sem_Util is
return True;
else
- declare
- N : Node_Id;
-
- begin
- N := First (Expressions (Expr));
- while Present (N) loop
- if Cannot_Raise_Constraint_Error (N) then
- Next (N);
- else
- return False;
- end if;
- end loop;
-
- return True;
- end;
+ return List_Cannot_Raise_CE (Expressions (Expr));
end if;
when N_Type_Conversion =>
if Do_Overflow_Check (Expr)
or else Do_Length_Check (Expr)
- or else Do_Tag_Check (Expr)
then
return False;
else
@@ -4683,10 +4822,6 @@ package body Sem_Util is
-- and post-state. Prag is a [refined] postcondition or a contract-cases
-- pragma. Result_Seen is set when the pragma mentions attribute 'Result
- function Has_In_Out_Parameter (Subp_Id : Entity_Id) return Boolean;
- -- Determine whether subprogram Subp_Id contains at least one IN OUT
- -- formal parameter.
-
-------------------------------------------
-- Check_Result_And_Post_State_In_Pragma --
-------------------------------------------
@@ -5075,28 +5210,6 @@ package body Sem_Util is
end if;
end Check_Result_And_Post_State_In_Pragma;
- --------------------------
- -- Has_In_Out_Parameter --
- --------------------------
-
- function Has_In_Out_Parameter (Subp_Id : Entity_Id) return Boolean is
- Formal : Entity_Id;
-
- begin
- -- Traverse the formals looking for an IN OUT parameter
-
- Formal := First_Formal (Subp_Id);
- while Present (Formal) loop
- if Ekind (Formal) = E_In_Out_Parameter then
- return True;
- end if;
-
- Next_Formal (Formal);
- end loop;
-
- return False;
- end Has_In_Out_Parameter;
-
-- Local variables
Items : constant Node_Id := Contract (Subp_Id);
@@ -5176,10 +5289,10 @@ package body Sem_Util is
null;
-- Regardless of whether the function has postconditions or contract
- -- cases, or whether they mention attribute 'Result, an IN OUT formal
+ -- cases, or whether they mention attribute 'Result, an [IN] OUT formal
-- parameter is always treated as a result.
- elsif Has_In_Out_Parameter (Spec_Id) then
+ elsif Has_Out_Or_In_Out_Parameter (Spec_Id) then
null;
-- The function has both a postcondition and contract cases and they do
@@ -5596,6 +5709,13 @@ package body Sem_Util is
if Ekind (State_Id) = E_Constant then
null;
+ -- Overlays do not contribute to package state
+
+ elsif Ekind (State_Id) = E_Variable
+ and then Present (Ultimate_Overlaid_Entity (State_Id))
+ then
+ null;
+
-- Generate an error message of the form:
-- body of package ... has unused hidden states
@@ -6355,8 +6475,8 @@ package body Sem_Util is
Is_Type_In_Pkg :=
Is_Package_Or_Generic_Package (B_Scope)
and then
- Nkind (Parent (Declaration_Node (First_Subtype (T)))) /=
- N_Package_Body;
+ Parent_Kind (Declaration_Node (First_Subtype (T))) /=
+ N_Package_Body;
while Present (Id) loop
@@ -6374,8 +6494,8 @@ package body Sem_Util is
and then (Is_Type_In_Pkg
or else Is_Derived_Type (B_Type)
or else Is_Primitive (Id))
- and then Nkind (Parent (Parent (Id)))
- not in N_Formal_Subprogram_Declaration
+ and then Parent_Kind (Parent (Id))
+ not in N_Formal_Subprogram_Declaration
then
Is_Prim := False;
@@ -6446,7 +6566,7 @@ package body Sem_Util is
-- appear in the target-specific extension to System.
if No (Id)
- and then B_Scope = RTU_Entity (System)
+ and then Is_RTU (B_Scope, System)
and then Present_System_Aux
then
B_Scope := System_Aux_Id;
@@ -6484,7 +6604,6 @@ package body Sem_Util is
Remove (Op_List, Node (Second));
else
- pragma Assert (False);
raise Program_Error;
end if;
end if;
@@ -6662,6 +6781,116 @@ package body Sem_Util is
return N;
end Compile_Time_Constraint_Error;
+ ----------------------------
+ -- Compute_Returns_By_Ref --
+ ----------------------------
+
+ procedure Compute_Returns_By_Ref (Func : Entity_Id) is
+ Typ : constant Entity_Id := Etype (Func);
+ Utyp : constant Entity_Id := Underlying_Type (Typ);
+
+ begin
+ if Is_Limited_View (Typ) then
+ Set_Returns_By_Ref (Func);
+
+ elsif Present (Utyp) and then CW_Or_Has_Controlled_Part (Utyp) then
+ Set_Returns_By_Ref (Func);
+ end if;
+ end Compute_Returns_By_Ref;
+
+ --------------------------------
+ -- Collect_Types_In_Hierarchy --
+ --------------------------------
+
+ function Collect_Types_In_Hierarchy
+ (Typ : Entity_Id;
+ Examine_Components : Boolean := False) return Elist_Id
+ is
+ Results : Elist_Id;
+
+ procedure Process_Type (Typ : Entity_Id);
+ -- Collect type Typ if it satisfies function Predicate. Do so for its
+ -- parent type, base type, progenitor types, and any component types.
+
+ ------------------
+ -- Process_Type --
+ ------------------
+
+ procedure Process_Type (Typ : Entity_Id) is
+ Comp : Entity_Id;
+ Iface_Elmt : Elmt_Id;
+
+ begin
+ if not Is_Type (Typ) or else Error_Posted (Typ) then
+ return;
+ end if;
+
+ -- Collect the current type if it satisfies the predicate
+
+ if Predicate (Typ) then
+ Append_Elmt (Typ, Results);
+ end if;
+
+ -- Process component types
+
+ if Examine_Components then
+
+ -- Examine components and discriminants
+
+ if Is_Concurrent_Type (Typ)
+ or else Is_Incomplete_Or_Private_Type (Typ)
+ or else Is_Record_Type (Typ)
+ or else Has_Discriminants (Typ)
+ then
+ Comp := First_Component_Or_Discriminant (Typ);
+
+ while Present (Comp) loop
+ Process_Type (Etype (Comp));
+
+ Next_Component_Or_Discriminant (Comp);
+ end loop;
+
+ -- Examine array components
+
+ elsif Ekind (Typ) = E_Array_Type then
+ Process_Type (Component_Type (Typ));
+ end if;
+ end if;
+
+ -- Examine parent type
+
+ if Etype (Typ) /= Typ then
+ Process_Type (Etype (Typ));
+ end if;
+
+ -- Examine base type
+
+ if Base_Type (Typ) /= Typ then
+ Process_Type (Base_Type (Typ));
+ end if;
+
+ -- Examine interfaces
+
+ if Is_Record_Type (Typ)
+ and then Present (Interfaces (Typ))
+ then
+ Iface_Elmt := First_Elmt (Interfaces (Typ));
+ while Present (Iface_Elmt) loop
+ Process_Type (Node (Iface_Elmt));
+
+ Next_Elmt (Iface_Elmt);
+ end loop;
+ end if;
+ end Process_Type;
+
+ -- Start of processing for Collect_Types_In_Hierarchy
+
+ begin
+ Results := New_Elmt_List;
+ Process_Type (Typ);
+ return Results;
+ end Collect_Types_In_Hierarchy;
+
-----------------------
-- Conditional_Delay --
-----------------------
@@ -6873,19 +7102,30 @@ package body Sem_Util 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;
+ E : Entity_Id;
begin
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))
- loop
- E := Homonym (E);
- end loop;
+
+ if No (E) then
+ null;
+
+ elsif Scope_Is_Transient then
+ while Present (E) loop
+ exit when Scope (E) = CS or else Scope (E) = Scope (CS);
+
+ E := Homonym (E);
+ end loop;
+
+ else
+ while Present (E) loop
+ exit when Scope (E) = CS;
+
+ E := Homonym (E);
+ end loop;
+ end if;
return E;
end Current_Entity_In_Scope;
@@ -6959,15 +7199,36 @@ package body Sem_Util is
end Current_Subprogram;
-------------------------------
+ -- CW_Or_Has_Controlled_Part --
+ -------------------------------
+
+ function CW_Or_Has_Controlled_Part (T : Entity_Id) return Boolean is
+ begin
+ return Is_Class_Wide_Type (T) or else Needs_Finalization (T);
+ end CW_Or_Has_Controlled_Part;
+
+ -------------------------------
-- Deepest_Type_Access_Level --
-------------------------------
- function Deepest_Type_Access_Level (Typ : Entity_Id) return Uint is
+ function Deepest_Type_Access_Level
+ (Typ : Entity_Id;
+ Allow_Alt_Model : Boolean := True) return Uint
+ is
begin
if Ekind (Typ) = E_Anonymous_Access_Type
and then not Is_Local_Anonymous_Access (Typ)
and then Nkind (Associated_Node_For_Itype (Typ)) = N_Object_Declaration
then
+ -- No_Dynamic_Accessibility_Checks override for alternative
+ -- accessibility model.
+
+ if Allow_Alt_Model
+ and then No_Dynamic_Accessibility_Checks_Enabled (Typ)
+ then
+ return Type_Access_Level (Typ, Allow_Alt_Model);
+ end if;
+
-- Typ is the type of an Ada 2012 stand-alone object of an anonymous
-- access type.
@@ -6983,7 +7244,7 @@ package body Sem_Util is
return UI_From_Int (Int'Last);
else
- return Type_Access_Level (Typ);
+ return Type_Access_Level (Typ, Allow_Alt_Model);
end if;
end Deepest_Type_Access_Level;
@@ -6991,10 +7252,23 @@ package body Sem_Util is
-- Defining_Entity --
---------------------
- function Defining_Entity
- (N : Node_Id;
- Empty_On_Errors : Boolean := False) return Entity_Id
- is
+ function Defining_Entity (N : Node_Id) return Entity_Id is
+ Ent : constant Entity_Id := Defining_Entity_Or_Empty (N);
+
+ begin
+ if Present (Ent) then
+ return Ent;
+
+ else
+ raise Program_Error;
+ end if;
+ end Defining_Entity;
+
+ ------------------------------
+ -- Defining_Entity_Or_Empty --
+ ------------------------------
+
+ function Defining_Entity_Or_Empty (N : Node_Id) return Entity_Id is
begin
case Nkind (N) is
when N_Abstract_Subprogram_Declaration
@@ -7093,13 +7367,9 @@ package body Sem_Util is
return Entity (Identifier (N));
when others =>
- if Empty_On_Errors then
- return Empty;
- end if;
-
- raise Program_Error;
+ return Empty;
end case;
- end Defining_Entity;
+ end Defining_Entity_Or_Empty;
--------------------------
-- Denotes_Discriminant --
@@ -7139,8 +7409,8 @@ package body Sem_Util is
-------------------------
function Denotes_Same_Object (A1, A2 : Node_Id) return Boolean is
- function Is_Renaming (N : Node_Id) return Boolean;
- -- Return true if N names a renaming entity
+ function Is_Object_Renaming (N : Node_Id) return Boolean;
+ -- Return true if N names an object renaming entity
function Is_Valid_Renaming (N : Node_Id) return Boolean;
-- For renamings, return False if the prefix of any dereference within
@@ -7148,185 +7418,144 @@ package body Sem_Util is
-- renamed object_name contains references to variables or calls on
-- nonstatic functions; otherwise return True (RM 6.4.1(6.10/3))
- -----------------
- -- Is_Renaming --
- -----------------
+ ------------------------
+ -- Is_Object_Renaming --
+ ------------------------
- function Is_Renaming (N : Node_Id) return Boolean is
+ function Is_Object_Renaming (N : Node_Id) return Boolean is
begin
- 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;
+ return Is_Entity_Name (N)
+ and then Ekind (Entity (N)) in E_Variable | E_Constant
+ and then Present (Renamed_Object (Entity (N)));
+ end Is_Object_Renaming;
-----------------------
-- Is_Valid_Renaming --
-----------------------
function Is_Valid_Renaming (N : Node_Id) return Boolean is
- function Check_Renaming (N : Node_Id) return Boolean;
- -- Recursive function used to traverse all the prefixes of N
-
- --------------------
- -- Check_Renaming --
- --------------------
+ begin
+ if Is_Object_Renaming (N)
+ and then not Is_Valid_Renaming (Renamed_Entity (Entity (N)))
+ then
+ return False;
+ end if;
- function Check_Renaming (N : Node_Id) return Boolean is
- begin
- if Is_Renaming (N)
- and then not Check_Renaming (Renamed_Entity (Entity (N)))
- then
- return False;
- end if;
+ -- Check if any expression within the renamed object_name contains no
+ -- references to variables nor calls on nonstatic functions.
- if Nkind (N) = N_Indexed_Component then
- declare
- Indx : Node_Id;
+ if Nkind (N) = N_Indexed_Component then
+ declare
+ Indx : Node_Id;
- begin
- Indx := First (Expressions (N));
- while Present (Indx) loop
- if not Is_OK_Static_Expression (Indx) then
- return False;
- end if;
+ begin
+ Indx := First (Expressions (N));
+ while Present (Indx) loop
+ if not Is_OK_Static_Expression (Indx) then
+ return False;
+ end if;
- Next_Index (Indx);
- end loop;
- end;
- end if;
+ Next_Index (Indx);
+ end loop;
+ end;
- if Has_Prefix (N) then
- declare
- P : constant Node_Id := Prefix (N);
+ elsif Nkind (N) = N_Slice then
+ declare
+ Rng : constant Node_Id := Discrete_Range (N);
+ begin
+ -- Bounds specified as a range
- begin
- if Nkind (N) = N_Explicit_Dereference
- and then Is_Variable (P)
- then
+ if Nkind (Rng) = N_Range then
+ if not Is_OK_Static_Range (Rng) then
return False;
+ end if;
- elsif Is_Entity_Name (P)
- and then Ekind (Entity (P)) = E_Function
- then
- return False;
+ -- Bounds specified as a constrained subtype indication
- elsif Nkind (P) = N_Function_Call then
+ elsif Nkind (Rng) = N_Subtype_Indication then
+ if not Is_OK_Static_Range
+ (Range_Expression (Constraint (Rng)))
+ then
return False;
end if;
- -- Recursion to continue traversing the prefix of the
- -- renaming expression
+ -- Bounds specified as a subtype name
- return Check_Renaming (P);
- end;
- end if;
+ elsif not Is_OK_Static_Expression (Rng) then
+ return False;
+ end if;
+ end;
+ end if;
- return True;
- end Check_Renaming;
+ if Has_Prefix (N) then
+ declare
+ P : constant Node_Id := Prefix (N);
- -- Start of processing for Is_Valid_Renaming
+ begin
+ if Nkind (N) = N_Explicit_Dereference
+ and then Is_Variable (P)
+ then
+ return False;
- begin
- return Check_Renaming (N);
- end Is_Valid_Renaming;
+ elsif Is_Entity_Name (P)
+ and then Ekind (Entity (P)) = E_Function
+ then
+ return False;
- -- Local variables
+ elsif Nkind (P) = N_Function_Call then
+ return False;
+ end if;
- Obj1 : Node_Id := A1;
- Obj2 : Node_Id := A2;
+ -- Recursion to continue traversing the prefix of the
+ -- renaming expression
+
+ return Is_Valid_Renaming (P);
+ end;
+ end if;
+
+ return True;
+ end Is_Valid_Renaming;
-- Start of processing for Denotes_Same_Object
begin
- -- Both names statically denote the same stand-alone object or parameter
- -- (RM 6.4.1(6.5/3))
+ -- Both names statically denote the same stand-alone object or
+ -- parameter (RM 6.4.1(6.6/3)).
- if Is_Entity_Name (Obj1)
- and then Is_Entity_Name (Obj2)
- and then Entity (Obj1) = Entity (Obj2)
+ if Is_Entity_Name (A1)
+ and then Is_Entity_Name (A2)
+ and then Entity (A1) = Entity (A2)
then
return True;
- end if;
-
- -- For renamings, the prefix of any dereference within the renamed
- -- object_name is not a variable, and any expression within the
- -- renamed object_name contains no references to variables nor
- -- calls on nonstatic functions (RM 6.4.1(6.10/3)).
-
- if Is_Renaming (Obj1) then
- if Is_Valid_Renaming (Obj1) then
- Obj1 := Renamed_Entity (Entity (Obj1));
- else
- return False;
- end if;
- end if;
-
- if Is_Renaming (Obj2) then
- if Is_Valid_Renaming (Obj2) then
- Obj2 := Renamed_Entity (Entity (Obj2));
- else
- return False;
- end if;
- end if;
-
- -- No match if not same node kind (such cases are handled by
- -- Denotes_Same_Prefix)
-
- if Nkind (Obj1) /= Nkind (Obj2) then
- return False;
-
- -- After handling valid renamings, one of the two names statically
- -- denoted a renaming declaration whose renamed object_name is known
- -- to denote the same object as the other (RM 6.4.1(6.10/3))
-
- elsif Is_Entity_Name (Obj1) then
- if Is_Entity_Name (Obj2) then
- return Entity (Obj1) = Entity (Obj2);
- else
- return False;
- end if;
-- Both names are selected_components, their prefixes are known to
-- denote the same object, and their selector_names denote the same
- -- component (RM 6.4.1(6.6/3)).
+ -- component (RM 6.4.1(6.7/3)).
- elsif Nkind (Obj1) = N_Selected_Component then
- return Denotes_Same_Object (Prefix (Obj1), Prefix (Obj2))
+ elsif Nkind (A1) = N_Selected_Component
+ and then Nkind (A2) = N_Selected_Component
+ then
+ return Denotes_Same_Object (Prefix (A1), Prefix (A2))
and then
- Entity (Selector_Name (Obj1)) = Entity (Selector_Name (Obj2));
+ Entity (Selector_Name (A1)) = Entity (Selector_Name (A2));
-- Both names are dereferences and the dereferenced names are known to
- -- denote the same object (RM 6.4.1(6.7/3))
+ -- denote the same object (RM 6.4.1(6.8/3)).
- elsif Nkind (Obj1) = N_Explicit_Dereference then
- return Denotes_Same_Object (Prefix (Obj1), Prefix (Obj2));
+ elsif Nkind (A1) = N_Explicit_Dereference
+ and then Nkind (A2) = N_Explicit_Dereference
+ then
+ return Denotes_Same_Object (Prefix (A1), Prefix (A2));
-- Both names are indexed_components, their prefixes are known to denote
-- the same object, and each of the pairs of corresponding index values
-- are either both static expressions with the same static value or both
- -- names that are known to denote the same object (RM 6.4.1(6.8/3))
+ -- names that are known to denote the same object (RM 6.4.1(6.9/3)).
- elsif Nkind (Obj1) = N_Indexed_Component then
- if not Denotes_Same_Object (Prefix (Obj1), Prefix (Obj2)) then
+ elsif Nkind (A1) = N_Indexed_Component
+ and then Nkind (A2) = N_Indexed_Component
+ then
+ if not Denotes_Same_Object (Prefix (A1), Prefix (A2)) then
return False;
else
declare
@@ -7334,8 +7563,8 @@ package body Sem_Util is
Indx2 : Node_Id;
begin
- Indx1 := First (Expressions (Obj1));
- Indx2 := First (Expressions (Obj2));
+ Indx1 := First (Expressions (A1));
+ Indx2 := First (Expressions (A2));
while Present (Indx1) loop
-- Indexes must denote the same static value or same object
@@ -7362,33 +7591,49 @@ package body Sem_Util is
-- Both names are slices, their prefixes are known to denote the same
-- object, and the two slices have statically matching index constraints
- -- (RM 6.4.1(6.9/3))
+ -- (RM 6.4.1(6.10/3)).
- elsif Nkind (Obj1) = N_Slice
- and then Denotes_Same_Object (Prefix (Obj1), Prefix (Obj2))
+ elsif Nkind (A1) = N_Slice
+ and then Nkind (A2) = N_Slice
then
- declare
- Lo1, Lo2, Hi1, Hi2 : Node_Id;
-
- begin
- Get_Index_Bounds (Etype (Obj1), Lo1, Hi1);
- Get_Index_Bounds (Etype (Obj2), Lo2, Hi2);
+ if not Denotes_Same_Object (Prefix (A1), Prefix (A2)) then
+ return False;
+ else
+ declare
+ Lo1, Lo2, Hi1, Hi2 : Node_Id;
- -- Check whether bounds are statically identical. There is no
- -- attempt to detect partial overlap of slices.
+ begin
+ Get_Index_Bounds (Discrete_Range (A1), Lo1, Hi1);
+ Get_Index_Bounds (Discrete_Range (A2), Lo2, Hi2);
+
+ -- Check whether bounds are statically identical. There is no
+ -- attempt to detect partial overlap of slices.
+
+ return Is_OK_Static_Expression (Lo1)
+ and then Is_OK_Static_Expression (Lo2)
+ and then Is_OK_Static_Expression (Hi1)
+ and then Is_OK_Static_Expression (Hi2)
+ and then Expr_Value (Lo1) = Expr_Value (Lo2)
+ and then Expr_Value (Hi1) = Expr_Value (Hi2);
+ end;
+ end if;
- return Denotes_Same_Object (Lo1, Lo2)
- and then
- Denotes_Same_Object (Hi1, Hi2);
- end;
+ -- One of the two names statically denotes a renaming declaration whose
+ -- renamed object_name is known to denote the same object as the other;
+ -- the prefix of any dereference within the renamed object_name is not a
+ -- variable, and any expression within the renamed object_name contains
+ -- no references to variables nor calls on nonstatic functions (RM
+ -- 6.4.1(6.11/3)).
- -- In the recursion, literals appear as indexes
+ elsif Is_Object_Renaming (A1)
+ and then Is_Valid_Renaming (A1)
+ then
+ return Denotes_Same_Object (Renamed_Entity (Entity (A1)), A2);
- elsif Nkind (Obj1) = N_Integer_Literal
- and then
- Nkind (Obj2) = N_Integer_Literal
+ elsif Is_Object_Renaming (A2)
+ and then Is_Valid_Renaming (A2)
then
- return Intval (Obj1) = Intval (Obj2);
+ return Denotes_Same_Object (A1, Renamed_Entity (Entity (A2)));
else
return False;
@@ -7793,11 +8038,7 @@ package body Sem_Util is
Current_Node := Parent (Current_Node);
end loop;
- if Nkind (Current_Node) /= N_Compilation_Unit then
- return Empty;
- else
- return Current_Node;
- end if;
+ return Current_Node;
end Enclosing_Comp_Unit_Node;
--------------------------
@@ -8462,7 +8703,7 @@ package body Sem_Util is
-- will be detected. Any_Type insures that no cascaded errors will occur
else
- Set_Ekind (Def_Id, E_Void);
+ Mutate_Ekind (Def_Id, E_Void);
Set_Etype (Def_Id, Any_Type);
end if;
@@ -9280,6 +9521,10 @@ package body Sem_Util is
Ent : out Entity_Id;
Off : out Boolean)
is
+ pragma Assert
+ (Nkind (N) = N_Attribute_Definition_Clause
+ and then Chars (N) = Name_Address);
+
Expr : Node_Id;
begin
@@ -9299,61 +9544,68 @@ package body Sem_Util is
Ent := Empty;
Off := False;
- if Nkind (N) = N_Attribute_Definition_Clause
- and then Chars (N) = Name_Address
- then
- Expr := Expression (N);
+ Expr := Expression (N);
- -- This loop checks the form of the expression for Y'Address,
- -- using recursion to deal with intermediate constants.
+ -- This loop checks the form of the expression for Y'Address, using
+ -- recursion to deal with intermediate constants.
- loop
- -- Check for Y'Address
+ loop
+ -- Check for Y'Address
- if Nkind (Expr) = N_Attribute_Reference
- and then Attribute_Name (Expr) = Name_Address
- then
- Expr := Prefix (Expr);
- exit;
+ if Nkind (Expr) = N_Attribute_Reference
+ and then Attribute_Name (Expr) = Name_Address
+ then
+ 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
- then
- Expr := Constant_Value (Entity (Expr));
+ elsif Is_Entity_Name (Expr)
+ and then Ekind (Entity (Expr)) = E_Constant
+ then
+ Expr := Constant_Value (Entity (Expr));
- -- Anything else does not need checking
+ -- Anything else does not need checking
- else
- return;
- end if;
- end loop;
+ else
+ return;
+ end if;
+ end loop;
- -- This loop checks the form of the prefix for an entity, using
- -- recursion to deal with intermediate components.
+ -- This loop checks the form of the prefix for an entity, using
+ -- recursion to deal with intermediate components.
- loop
- -- Check for Y where Y is an entity
+ loop
+ -- Check for Y where Y is an entity
- if Is_Entity_Name (Expr) then
- Ent := Entity (Expr);
- return;
+ if Is_Entity_Name (Expr) then
+ Ent := Entity (Expr);
- -- Check for components
+ -- If expansion is disabled, then we might see an entity of a
+ -- protected component or of a discriminant of a concurrent unit.
+ -- Ignore such entities, because further warnings for overlays
+ -- expect this routine to only collect entities of entire objects.
- elsif Nkind (Expr) in N_Selected_Component | N_Indexed_Component
- then
- Expr := Prefix (Expr);
- Off := True;
+ if Ekind (Ent) in E_Component | E_Discriminant then
+ pragma Assert
+ (not Expander_Active
+ and then Is_Concurrent_Type (Scope (Ent)));
+ Ent := Empty;
+ end if;
+ return;
- -- Anything else does not need checking
+ -- Check for components
- else
- return;
- end if;
- end loop;
- end if;
+ elsif Nkind (Expr) in N_Selected_Component | N_Indexed_Component then
+ Expr := Prefix (Expr);
+ Off := True;
+
+ -- Anything else does not need checking
+
+ else
+ return;
+ end if;
+ end loop;
end Find_Overlaid_Entity;
-------------------------
@@ -9899,6 +10151,18 @@ package body Sem_Util is
Discrim_Value : Node_Id;
Discrim_Value_Subtype : Node_Id;
Discrim_Value_Status : Discriminant_Value_Status := Bad;
+
+ function OK_Scope_For_Discrim_Value_Error_Messages return Boolean is
+ (Scope (Original_Record_Component
+ (Entity (First (Choices (Assoc))))) = Typ);
+ -- Used to avoid generating error messages having a source position
+ -- which refers to somewhere (e.g., a discriminant value in a derived
+ -- tagged type declaration) unrelated to the offending construct. This
+ -- is required for correctness - clients of Gather_Components such as
+ -- Sem_Ch3.Create_Constrained_Components depend on this function
+ -- returning True while processing semantically correct examples;
+ -- generating an error message in this case would be wrong.
+
begin
Report_Errors := False;
@@ -10043,7 +10307,7 @@ package body Sem_Util is
then
Discrim_Value_Status := Static_Expr;
else
- if Ada_Version >= Ada_2020 then
+ if Ada_Version >= Ada_2022 then
if Original_Node (Discrim_Value) /= Discrim_Value
and then Nkind (Discrim_Value) = N_Type_Conversion
and then Etype (Original_Node (Discrim_Value))
@@ -10082,15 +10346,13 @@ package body Sem_Util is
-- components are being gathered for an aggregate, in which case
-- the caller must check Report_Errors.
--
- -- In Ada 2020 the above rules are relaxed. A nonstatic governing
+ -- In Ada 2022 the above rules are relaxed. A nonstatic governing
-- discriminant is OK as long as it has a static subtype and
-- every value of that subtype (and there must be at least one)
-- selects the same variant.
- if Scope (Original_Record_Component
- ((Entity (First (Choices (Assoc)))))) = Typ
- then
- if Ada_Version >= Ada_2020 then
+ if OK_Scope_For_Discrim_Value_Error_Messages then
+ if Ada_Version >= Ada_2022 then
Error_Msg_FE
("value for discriminant & must be static or " &
"discriminant's nominal subtype must be static " &
@@ -10208,10 +10470,12 @@ package body Sem_Util is
(Subset => Discrim_Value_Subtype_Intervals,
Of_Set => Variant_Intervals)
then
- Error_Msg_NE
- ("no single variant is associated with all values of " &
- "the subtype of discriminant value &",
- Discrim_Value, Discrim);
+ if OK_Scope_For_Discrim_Value_Error_Messages then
+ Error_Msg_NE
+ ("no single variant is associated with all values of " &
+ "the subtype of discriminant value &",
+ Discrim_Value, Discrim);
+ end if;
Report_Errors := True;
return;
end if;
@@ -10651,22 +10915,26 @@ package body Sem_Util is
when E_Class_Wide_Type =>
return Get_Fullest_View (Root_Type (E), Include_PAT);
- when E_Class_Wide_Subtype =>
+ when E_Class_Wide_Subtype =>
if Present (Equivalent_Type (E)) then
return Get_Fullest_View (Equivalent_Type (E), Include_PAT);
elsif Present (Cloned_Subtype (E)) then
return Get_Fullest_View (Cloned_Subtype (E), Include_PAT);
end if;
- when E_Protected_Type | E_Protected_Subtype
- | E_Task_Type | E_Task_Subtype =>
+ when E_Protected_Subtype
+ | E_Protected_Type
+ | E_Task_Subtype
+ | E_Task_Type
+ =>
if Present (Corresponding_Record_Type (E)) then
return Get_Fullest_View (Corresponding_Record_Type (E),
Include_PAT);
end if;
when E_Access_Protected_Subprogram_Type
- | E_Anonymous_Access_Protected_Subprogram_Type =>
+ | E_Anonymous_Access_Protected_Subprogram_Type
+ =>
if Present (Equivalent_Type (E)) then
return Get_Fullest_View (Equivalent_Type (E), Include_PAT);
end if;
@@ -10822,6 +11090,23 @@ package body Sem_Util is
end if;
end Get_Index_Bounds;
+ function Get_Index_Bounds
+ (N : Node_Id;
+ Use_Full_View : Boolean := False) return Range_Nodes is
+ Result : Range_Nodes;
+ begin
+ Get_Index_Bounds (N, Result.First, Result.Last, Use_Full_View);
+ return Result;
+ end Get_Index_Bounds;
+
+ function Get_Index_Bounds
+ (N : Node_Id;
+ Use_Full_View : Boolean := False) return Range_Values is
+ Nodes : constant Range_Nodes := Get_Index_Bounds (N, Use_Full_View);
+ begin
+ return (Expr_Value (Nodes.First), Expr_Value (Nodes.Last));
+ end Get_Index_Bounds;
+
-----------------------------
-- Get_Interfacing_Aspects --
-----------------------------
@@ -11401,12 +11686,13 @@ package body Sem_Util is
-- Has_Access_Values --
-----------------------
- function Has_Access_Values (T : Entity_Id) return Boolean is
+ function Has_Access_Values (T : Entity_Id) return Boolean
+ is
Typ : constant Entity_Id := Underlying_Type (T);
begin
-- Case of a private type which is not completed yet. This can only
- -- happen in the case of a generic format type appearing directly, or
+ -- happen in the case of a generic formal type appearing directly, or
-- as a component of the type to which this function is being applied
-- at the top level. Return False in this case, since we certainly do
-- not know that the type contains access types.
@@ -11548,7 +11834,7 @@ package body Sem_Util is
if Default = Known_Compatible
or else
(Etype (Obj) = Etype (Expr)
- and then (Unknown_Alignment (Obj)
+ and then (not Known_Alignment (Obj)
or else
Alignment (Obj) = Alignment (Etype (Obj))))
then
@@ -11651,22 +11937,23 @@ package body Sem_Util is
Set_Result (Known_Incompatible);
end if;
- -- See if Expr is an object with known alignment
+ -- See if Expr is an object with known alignment
elsif Is_Entity_Name (Expr)
and then Known_Alignment (Entity (Expr))
then
+ Offs := Uint_0;
ExpA := Alignment (Entity (Expr));
- -- Otherwise, we can use the alignment of the type of
- -- Expr given that we already checked for
- -- discombobulating rep clauses for the cases of indexed
- -- and selected components above.
+ -- Otherwise, we can use the alignment of the type of Expr
+ -- given that we already checked for discombobulating rep
+ -- clauses for the cases of indexed and selected components
+ -- above.
elsif Known_Alignment (Etype (Expr)) then
ExpA := Alignment (Etype (Expr));
- -- Otherwise the alignment is unknown
+ -- Otherwise the alignment is unknown
else
Set_Result (Default);
@@ -11678,28 +11965,28 @@ package body Sem_Util is
Set_Result (Known_Incompatible);
end if;
- -- If Expr is not a piece of a larger object, see if size
- -- is given. If so, check that it is not too small for the
- -- required alignment.
+ -- If Expr is a component or an entire object with a known
+ -- alignment, then we are fine. Otherwise, if its size is
+ -- known, it must be big enough for the required alignment.
if Offs /= No_Uint then
null;
- -- See if Expr is an object with known size
+ -- See if Expr is an object with known size
elsif Is_Entity_Name (Expr)
and then Known_Static_Esize (Entity (Expr))
then
SizA := Esize (Entity (Expr));
- -- Otherwise, we check the object size of the Expr type
+ -- Otherwise, we check the object size of the Expr type
elsif Known_Static_Esize (Etype (Expr)) then
SizA := Esize (Etype (Expr));
end if;
-- If we got a size, see if it is a multiple of the Obj
- -- alignment, if not, then the alignment cannot be
+ -- alignment; if not, then the alignment cannot be
-- acceptable, since the size is always a multiple of the
-- alignment.
@@ -11737,25 +12024,24 @@ package body Sem_Util is
-- where we do not know the alignment of Obj.
if Known_Alignment (Entity (Expr))
- and then UI_To_Int (Alignment (Entity (Expr))) <
- Ttypes.Maximum_Alignment
+ and then Alignment (Entity (Expr)) < Ttypes.Maximum_Alignment
then
Set_Result (Unknown);
- -- Now check size of Expr object. Any size that is not an
- -- even multiple of Maximum_Alignment is also worrisome
- -- since it may cause the alignment of the object to be less
- -- than the alignment of the type.
+ -- Now check size of Expr object. Any size that is not an even
+ -- multiple of Maximum_Alignment is also worrisome since it
+ -- may cause the alignment of the object to be less than the
+ -- alignment of the type.
elsif Known_Static_Esize (Entity (Expr))
and then
- (UI_To_Int (Esize (Entity (Expr))) mod
- (Ttypes.Maximum_Alignment * Ttypes.System_Storage_Unit))
+ Esize (Entity (Expr)) mod
+ (Ttypes.Maximum_Alignment * Ttypes.System_Storage_Unit)
/= 0
then
Set_Result (Unknown);
- -- Otherwise same type is decisive
+ -- Otherwise same type is decisive
else
Set_Result (Known_Compatible);
@@ -11793,7 +12079,7 @@ package body Sem_Util is
-- do it when there is an address clause since we can do more if the
-- alignment is known.
- if Unknown_Alignment (Obj) then
+ if not Known_Alignment (Obj) and then Known_Alignment (Etype (Obj)) then
Set_Alignment (Obj, Alignment (Etype (Obj)));
end if;
@@ -11827,7 +12113,6 @@ package body Sem_Util is
function Has_Defaulted_Discriminants (Typ : Entity_Id) return Boolean is
begin
return Has_Discriminants (Typ)
- and then Present (First_Discriminant (Typ))
and then Present (Discriminant_Default_Value
(First_Discriminant (Typ)));
end Has_Defaulted_Discriminants;
@@ -12444,6 +12729,84 @@ package body Sem_Util is
return False;
end Has_Fully_Default_Initializing_DIC_Pragma;
+ ---------------------------------
+ -- Has_Inferable_Discriminants --
+ ---------------------------------
+
+ function Has_Inferable_Discriminants (N : Node_Id) return Boolean is
+
+ function Prefix_Is_Formal_Parameter (N : Node_Id) return Boolean;
+ -- Determines whether the left-most prefix of a selected component is a
+ -- formal parameter in a subprogram. Assumes N is a selected component.
+
+ --------------------------------
+ -- Prefix_Is_Formal_Parameter --
+ --------------------------------
+
+ function Prefix_Is_Formal_Parameter (N : Node_Id) return Boolean is
+ Sel_Comp : Node_Id;
+
+ begin
+ -- Move to the left-most prefix by climbing up the tree
+
+ Sel_Comp := N;
+ while Present (Parent (Sel_Comp))
+ and then Nkind (Parent (Sel_Comp)) = N_Selected_Component
+ loop
+ Sel_Comp := Parent (Sel_Comp);
+ end loop;
+
+ return Is_Formal (Entity (Prefix (Sel_Comp)));
+ end Prefix_Is_Formal_Parameter;
+
+ -- Start of processing for Has_Inferable_Discriminants
+
+ begin
+ -- For selected components, the subtype of the selector must be a
+ -- constrained Unchecked_Union. If the component is subject to a
+ -- per-object constraint, then the enclosing object must have inferable
+ -- discriminants.
+
+ if Nkind (N) = N_Selected_Component then
+ if Has_Per_Object_Constraint (Entity (Selector_Name (N))) then
+
+ -- A small hack. If we have a per-object constrained selected
+ -- component of a formal parameter, return True since we do not
+ -- know the actual parameter association yet.
+
+ if Prefix_Is_Formal_Parameter (N) then
+ return True;
+
+ -- Otherwise, check the enclosing object and the selector
+
+ else
+ return Has_Inferable_Discriminants (Prefix (N))
+ and then Has_Inferable_Discriminants (Selector_Name (N));
+ end if;
+
+ -- The call to Has_Inferable_Discriminants will determine whether
+ -- the selector has a constrained Unchecked_Union nominal type.
+
+ else
+ return Has_Inferable_Discriminants (Selector_Name (N));
+ end if;
+
+ -- A qualified expression has inferable discriminants if its subtype
+ -- mark is a constrained Unchecked_Union subtype.
+
+ elsif Nkind (N) = N_Qualified_Expression then
+ return Is_Unchecked_Union (Etype (Subtype_Mark (N)))
+ and then Is_Constrained (Etype (Subtype_Mark (N)));
+
+ -- For all other names, it is sufficient to have a constrained
+ -- Unchecked_Union nominal subtype.
+
+ else
+ return Is_Unchecked_Union (Base_Type (Etype (N)))
+ and then Is_Constrained (Etype (N));
+ end if;
+ end Has_Inferable_Discriminants;
+
--------------------
-- Has_Infinities --
--------------------
@@ -12944,6 +13307,44 @@ package body Sem_Util is
and then Nkind (Node (First_Elmt (Constits))) = N_Null;
end Has_Null_Refinement;
+ ------------------------------------------
+ -- Has_Nonstatic_Class_Wide_Pre_Or_Post --
+ ------------------------------------------
+
+ function Is_Prim_Of_Abst_Type_With_Nonstatic_CW_Pre_Post
+ (Subp : Entity_Id) return Boolean
+ is
+ Disp_Type : constant Entity_Id := Find_Dispatching_Type (Subp);
+ Prag : Node_Id;
+ Pragma_Arg : Node_Id;
+
+ begin
+ if Present (Disp_Type)
+ and then Is_Abstract_Type (Disp_Type)
+ and then Present (Contract (Subp))
+ then
+ Prag := Pre_Post_Conditions (Contract (Subp));
+
+ while Present (Prag) loop
+ if Pragma_Name (Prag) in Name_Precondition | Name_Postcondition
+ and then Class_Present (Prag)
+ then
+ Pragma_Arg :=
+ Nlists.First
+ (Pragma_Argument_Associations (Prag));
+
+ if not Is_Static_Expression (Expression (Pragma_Arg)) then
+ return True;
+ end if;
+ end if;
+
+ Prag := Next_Pragma (Prag);
+ end loop;
+ end if;
+
+ return False;
+ end Is_Prim_Of_Abst_Type_With_Nonstatic_CW_Pre_Post;
+
-------------------------------
-- Has_Overriding_Initialize --
-------------------------------
@@ -13706,7 +14107,7 @@ package body Sem_Util is
elsif Is_Record_Type (Typ) then
Comp := First_Component (Typ);
while Present (Comp) loop
- if Is_Volatile_Object (Comp) then
+ if Is_Volatile_Object_Ref (Comp) then
return True;
end if;
@@ -14080,7 +14481,9 @@ package body Sem_Util is
-- In_Pre_Post_Condition --
---------------------------
- function In_Pre_Post_Condition (N : Node_Id) return Boolean is
+ function In_Pre_Post_Condition
+ (N : Node_Id; Class_Wide_Only : Boolean := False) return Boolean
+ is
Par : Node_Id;
Prag : Node_Id := Empty;
Prag_Id : Pragma_Id;
@@ -14106,13 +14509,24 @@ package body Sem_Util is
if Present (Prag) then
Prag_Id := Get_Pragma_Id (Prag);
- return
- Prag_Id = Pragma_Post
- or else Prag_Id = Pragma_Post_Class
- or else Prag_Id = Pragma_Postcondition
- or else Prag_Id = Pragma_Pre
- or else Prag_Id = Pragma_Pre_Class
- or else Prag_Id = Pragma_Precondition;
+ if Class_Wide_Only then
+ return
+ Prag_Id = Pragma_Post_Class
+ or else Prag_Id = Pragma_Pre_Class
+ or else (Class_Present (Prag)
+ and then (Prag_Id = Pragma_Post
+ or else Prag_Id = Pragma_Postcondition
+ or else Prag_Id = Pragma_Pre
+ or else Prag_Id = Pragma_Precondition));
+ else
+ return
+ Prag_Id = Pragma_Post
+ or else Prag_Id = Pragma_Post_Class
+ or else Prag_Id = Pragma_Postcondition
+ or else Prag_Id = Pragma_Pre
+ or else Prag_Id = Pragma_Pre_Class
+ or else Prag_Id = Pragma_Precondition;
+ end if;
-- Otherwise the node is not enclosed by a pre/postcondition pragma
@@ -14337,6 +14751,17 @@ package body Sem_Util is
when N_Function_Call =>
if not In_Function_Call then
In_Function_Call := True;
+
+ -- When the function return type has implicit dereference
+ -- specified we know it cannot directly contribute to the
+ -- return value.
+
+ if Present (Etype (Par))
+ and then Has_Implicit_Dereference
+ (Get_Full_View (Etype (Par)))
+ then
+ return False;
+ end if;
else
return False;
end if;
@@ -14424,6 +14849,8 @@ package body Sem_Util is
--------------------------------
function Incomplete_Or_Partial_View (Id : Entity_Id) return Entity_Id is
+ S : constant Entity_Id := Scope (Id);
+
function Inspect_Decls
(Decls : List_Id;
Taft : Boolean := False) return Entity_Id;
@@ -14492,7 +14919,13 @@ package body Sem_Util is
begin
-- Deferred constant or incomplete type case
- Prev := Current_Entity_In_Scope (Id);
+ Prev := Current_Entity (Id);
+
+ while Present (Prev) loop
+ exit when Scope (Prev) = S;
+
+ Prev := Homonym (Prev);
+ end loop;
if Present (Prev)
and then (Is_Incomplete_Type (Prev) or else Ekind (Prev) = E_Constant)
@@ -14504,18 +14937,11 @@ package body Sem_Util is
-- Private or Taft amendment type case
- declare
- Pkg : constant Entity_Id := Scope (Id);
- Pkg_Decl : Node_Id := Pkg;
-
- begin
- if Present (Pkg)
- and then Is_Package_Or_Generic_Package (Pkg)
- then
- while Nkind (Pkg_Decl) /= N_Package_Specification loop
- Pkg_Decl := Parent (Pkg_Decl);
- end loop;
+ if Present (S) and then Is_Package_Or_Generic_Package (S) then
+ declare
+ Pkg_Decl : constant Node_Id := Package_Specification (S);
+ begin
-- It is knows that Typ has a private view, look for it in the
-- visible declarations of the enclosing scope. A special case
-- of this is when the two views have been exchanged - the full
@@ -14536,11 +14962,11 @@ package body Sem_Util is
-- Taft amendment type. The incomplete view should be located in
-- the private declarations of the enclosing scope.
- elsif In_Package_Body (Pkg) then
+ elsif In_Package_Body (S) then
return Inspect_Decls (Private_Declarations (Pkg_Decl), True);
end if;
- end if;
- end;
+ end;
+ end if;
-- The type has no incomplete or private view
@@ -14616,6 +15042,12 @@ package body Sem_Util is
return No_Uint;
end if;
+ -- Do not attempt to compute offsets within multi-dimensional arrays
+
+ if Present (Next_Index (Ind)) then
+ return No_Uint;
+ end if;
+
if Nkind (Ind) = N_Subtype_Indication then
Ind := Constraint (Ind);
@@ -14632,7 +15064,7 @@ package body Sem_Util is
-- Return the scaled offset
- return Off * (Expr_Value (Exp) - Expr_Value (Low_Bound ((Ind))));
+ return Off * (Expr_Value (Exp) - Expr_Value (Low_Bound (Ind)));
end Indexed_Component_Bit_Offset;
-----------------------------
@@ -14867,8 +15299,6 @@ package body Sem_Util is
Get_Next_Interp (I, It);
end loop;
- End_Interp_List;
-
else
-- Prefix is unambiguous: mark the original prefix (which might
-- Come_From_Source) as a reference, since the new (relocated) one
@@ -15198,8 +15628,9 @@ package body Sem_Util is
function Is_Access_Variable (E : Entity_Id) return Boolean is
begin
- return Is_Access_Object_Type (E)
- and then not Is_Access_Constant (E);
+ return Is_Access_Type (E)
+ and then not Is_Access_Constant (E)
+ and then Ekind (Directly_Designated_Type (E)) /= E_Subprogram_Type;
end Is_Access_Variable;
-----------------------------
@@ -15251,7 +15682,9 @@ package body Sem_Util is
when N_Parameter_Association =>
return N = Explicit_Actual_Parameter (Parent (N));
- when N_Subprogram_Call =>
+ when N_Entry_Call_Statement
+ | N_Subprogram_Call
+ =>
return Is_List_Member (N)
and then
List_Containing (N) = Parameter_Associations (Parent (N));
@@ -15312,6 +15745,15 @@ package body Sem_Util is
-- statement is aliased if its type is immutably limited.
or else (Is_Return_Object (E)
+ and then Is_Limited_View (Etype (E)))
+
+ -- The current instance of a limited type is aliased, so
+ -- we want to allow uses of T'Access in the init proc for
+ -- a limited type T. However, we don't want to mark the formal
+ -- parameter as being aliased since that could impact callers.
+
+ or else (Is_Formal (E)
+ and then Chars (E) = Name_uInit
and then Is_Limited_View (Etype (E)));
elsif Nkind (Obj) = N_Selected_Component then
@@ -15328,7 +15770,7 @@ package body Sem_Util is
return Is_Tagged_Type (Etype (Obj))
and then Is_Aliased_View (Expression (Obj));
- -- Ada 202x AI12-0228
+ -- Ada 2022 AI12-0228
elsif Nkind (Obj) = N_Qualified_Expression
and then Ada_Version >= Ada_2012
@@ -15698,18 +16140,32 @@ package body Sem_Util is
Aspect_Spec_1, Aspect_Spec_2 : Node_Id)
return Boolean is
function Names_Match (Nm1, Nm2 : Node_Id) return Boolean;
+
+ -----------------
+ -- Names_Match --
+ -----------------
+
function Names_Match (Nm1, Nm2 : Node_Id) return Boolean is
begin
if Nkind (Nm1) /= Nkind (Nm2) then
return False;
+ -- This may be too restrictive given that visibility
+ -- may allow an identifier in one case and an expanded
+ -- name in the other.
end if;
case Nkind (Nm1) is
when N_Identifier =>
return Name_Equals (Chars (Nm1), Chars (Nm2));
+
when N_Expanded_Name =>
- return Names_Match (Prefix (Nm1), Prefix (Nm2))
- and then Names_Match (Selector_Name (Nm1),
- Selector_Name (Nm2));
+ -- An inherited operation has the same name as its
+ -- ancestor, but they may have different scopes.
+ -- This may be too permissive for Iterator_Element, which
+ -- is intended to be identical in parent and derived type.
+
+ return Names_Match (Selector_Name (Nm1),
+ Selector_Name (Nm2));
+
when N_Empty =>
return True; -- needed for Aggregate aspect checking
@@ -15737,8 +16193,7 @@ package body Sem_Util is
when Aspect_Default_Iterator
| Aspect_Iterator_Element
| Aspect_Constant_Indexing
- | Aspect_Variable_Indexing
- | Aspect_Implicit_Dereference =>
+ | Aspect_Variable_Indexing =>
declare
Item_1 : constant Node_Id := Aspect_Rep_Item (Aspect_Spec_1);
Item_2 : constant Node_Id := Aspect_Rep_Item (Aspect_Spec_2);
@@ -15754,6 +16209,13 @@ package body Sem_Util is
Expression (Item_2));
end;
+ -- A confirming aspect for Implicit_Derenfence on a derived type
+ -- has already been checked in Analyze_Aspect_Implicit_Dereference,
+ -- including the presence of renamed discriminants.
+
+ when Aspect_Implicit_Dereference =>
+ return True;
+
-- one of a kind
when Aspect_Aggregate =>
declare
@@ -15810,11 +16272,9 @@ package body Sem_Util is
function Is_Concurrent_Interface (T : Entity_Id) return Boolean is
begin
- return Is_Interface (T)
- and then
- (Is_Protected_Interface (T)
- or else Is_Synchronized_Interface (T)
- or else Is_Task_Interface (T));
+ return Is_Protected_Interface (T)
+ or else Is_Synchronized_Interface (T)
+ or else Is_Task_Interface (T);
end Is_Concurrent_Interface;
-----------------------
@@ -16894,8 +17354,8 @@ package body Sem_Util is
Nkind (E) = N_Function_Call
and then not Configurable_Run_Time_Mode
and then Nkind (Original_Node (E)) = N_Attribute_Reference
- and then (Entity (Name (E)) = RTE (RE_Get_Ceiling)
- or else Entity (Name (E)) = RTE (RO_PE_Get_Ceiling));
+ and then (Is_RTE (Entity (Name (E)), RE_Get_Ceiling)
+ or else Is_RTE (Entity (Name (E)), RO_PE_Get_Ceiling));
end Is_Expanded_Priority_Attribute;
----------------------------
@@ -17050,7 +17510,8 @@ package body Sem_Util is
function Is_Full_Access_Object (N : Node_Id) return Boolean is
begin
- return Is_Atomic_Object (N) or else Is_Volatile_Full_Access_Object (N);
+ return Is_Atomic_Object (N)
+ or else Is_Volatile_Full_Access_Object_Ref (N);
end Is_Full_Access_Object;
-------------------------------
@@ -17139,9 +17600,7 @@ package body Sem_Util is
-- Record types
elsif Is_Record_Type (Typ) then
- if Has_Discriminants (Typ)
- and then
- Present (Discriminant_Default_Value (First_Discriminant (Typ)))
+ if Has_Defaulted_Discriminants (Typ)
and then Is_Fully_Initialized_Variant (Typ)
then
return True;
@@ -17685,7 +18144,9 @@ package body Sem_Util is
Ent : constant Entity_Id := Entity (Expr);
Sub : constant Entity_Id := Enclosing_Subprogram (Ent);
begin
- if Ekind (Ent) not in E_Variable | E_In_Out_Parameter then
+ if Ekind (Ent)
+ not in E_Variable | E_In_Out_Parameter | E_Out_Parameter
+ then
return False;
else
return Present (Sub) and then Sub = Current_Subprogram;
@@ -18174,10 +18635,10 @@ package body Sem_Util is
when N_Function_Call =>
- -- Ada 2020 (AI12-0175): Calls to certain functions that are
+ -- Ada 2022 (AI12-0175): Calls to certain functions that are
-- essentially unchecked conversions are preelaborable.
- if Ada_Version >= Ada_2020
+ if Ada_Version >= Ada_2022
and then Nkind (Expr) = N_Function_Call
and then Is_Entity_Name (Name (Expr))
and then Is_Preelaborable_Function (Entity (Name (Expr)))
@@ -18292,18 +18753,143 @@ package body Sem_Util is
return False;
end Is_Nontrivial_DIC_Procedure;
+ -----------------------
+ -- Is_Null_Extension --
+ -----------------------
+
+ function Is_Null_Extension
+ (T : Entity_Id; Ignore_Privacy : Boolean := False) return Boolean
+ is
+ Type_Decl : Node_Id;
+ Type_Def : Node_Id;
+ begin
+ if Ignore_Privacy then
+ Type_Decl := Parent (Underlying_Type (Base_Type (T)));
+ else
+ Type_Decl := Parent (Base_Type (T));
+ if Nkind (Type_Decl) /= N_Full_Type_Declaration then
+ return False;
+ end if;
+ end if;
+ pragma Assert (Nkind (Type_Decl) = N_Full_Type_Declaration);
+ Type_Def := Type_Definition (Type_Decl);
+ if Present (Discriminant_Specifications (Type_Decl))
+ or else Nkind (Type_Def) /= N_Derived_Type_Definition
+ or else not Is_Tagged_Type (T)
+ or else No (Record_Extension_Part (Type_Def))
+ then
+ return False;
+ end if;
+
+ return Is_Null_Record_Definition (Record_Extension_Part (Type_Def));
+ end Is_Null_Extension;
+
+ --------------------------
+ -- Is_Null_Extension_Of --
+ --------------------------
+
+ function Is_Null_Extension_Of
+ (Descendant, Ancestor : Entity_Id) return Boolean
+ is
+ Ancestor_Type : constant Entity_Id
+ := Underlying_Type (Base_Type (Ancestor));
+ Descendant_Type : Entity_Id := Underlying_Type (Base_Type (Descendant));
+ begin
+ pragma Assert (Descendant_Type /= Ancestor_Type);
+ while Descendant_Type /= Ancestor_Type loop
+ if not Is_Null_Extension
+ (Descendant_Type, Ignore_Privacy => True)
+ then
+ return False;
+ end if;
+ Descendant_Type := Etype (Subtype_Indication
+ (Type_Definition (Parent (Descendant_Type))));
+ Descendant_Type := Underlying_Type (Base_Type (Descendant_Type));
+ end loop;
+ return True;
+ end Is_Null_Extension_Of;
+
+ -------------------------------
+ -- Is_Null_Record_Definition --
+ -------------------------------
+
+ function Is_Null_Record_Definition (Record_Def : Node_Id) return Boolean is
+ Item : Node_Id;
+ begin
+ -- Testing Null_Present is just an optimization, not required.
+
+ if Null_Present (Record_Def) then
+ return True;
+ elsif Present (Variant_Part (Component_List (Record_Def))) then
+ return False;
+ elsif not Present (Component_List (Record_Def)) then
+ return True;
+ end if;
+
+ Item := First (Component_Items (Component_List (Record_Def)));
+
+ while Present (Item) loop
+ if Nkind (Item) = N_Component_Declaration
+ and then Is_Internal_Name (Chars (Defining_Identifier (Item)))
+ then
+ null;
+ elsif Nkind (Item) = N_Pragma then
+ null;
+ else
+ return False;
+ end if;
+ Item := Next (Item);
+ end loop;
+
+ return True;
+ end Is_Null_Record_Definition;
+
-------------------------
-- Is_Null_Record_Type --
-------------------------
- function Is_Null_Record_Type (T : Entity_Id) return Boolean is
- Decl : constant Node_Id := Parent (T);
+ function Is_Null_Record_Type
+ (T : Entity_Id; Ignore_Privacy : Boolean := False) return Boolean
+ is
+ Decl : Node_Id;
+ Type_Def : Node_Id;
begin
- return Nkind (Decl) = N_Full_Type_Declaration
- and then Nkind (Type_Definition (Decl)) = N_Record_Definition
- and then
- (No (Component_List (Type_Definition (Decl)))
- or else Null_Present (Component_List (Type_Definition (Decl))));
+ if not Is_Record_Type (T) then
+ return False;
+ end if;
+
+ if Ignore_Privacy then
+ Decl := Parent (Underlying_Type (Base_Type (T)));
+ else
+ Decl := Parent (Base_Type (T));
+ if Nkind (Decl) /= N_Full_Type_Declaration then
+ return False;
+ end if;
+ end if;
+ pragma Assert (Nkind (Decl) = N_Full_Type_Declaration);
+ Type_Def := Type_Definition (Decl);
+
+ if Has_Discriminants (Defining_Identifier (Decl)) then
+ return False;
+ end if;
+
+ case Nkind (Type_Def) is
+ when N_Record_Definition =>
+ return Is_Null_Record_Definition (Type_Def);
+ when N_Derived_Type_Definition =>
+ if not Is_Null_Record_Type
+ (Etype (Subtype_Indication (Type_Def)),
+ Ignore_Privacy => Ignore_Privacy)
+ then
+ return False;
+ elsif not Is_Tagged_Type (T) then
+ return True;
+ else
+ return Is_Null_Extension (T, Ignore_Privacy => Ignore_Privacy);
+ end if;
+ when others =>
+ return False;
+ end case;
end Is_Null_Record_Type;
---------------------
@@ -18317,7 +18903,9 @@ package body Sem_Util is
-- This is because the parser always checks that prefixes of attributes
-- are named.
- return not (Is_Entity_Name (Prefix) and then Is_Type (Entity (Prefix)));
+ return not (Is_Entity_Name (Prefix)
+ and then Is_Type (Entity (Prefix))
+ and then not Is_Current_Instance (Prefix));
end Is_Object_Image;
-------------------------
@@ -18409,7 +18997,7 @@ package body Sem_Util is
and then Is_Object_Reference (Expression (N));
else
- -- AI12-0226: In Ada 202x a value conversion of an object is
+ -- AI12-0226: In Ada 2022 a value conversion of an object is
-- an object.
return Is_Object_Reference (Expression (N));
@@ -18557,8 +19145,9 @@ package body Sem_Util is
----------------------------
function Is_OK_Volatile_Context
- (Context : Node_Id;
- Obj_Ref : Node_Id) return Boolean
+ (Context : Node_Id;
+ Obj_Ref : Node_Id;
+ Check_Actuals : Boolean) return Boolean
is
function Is_Protected_Operation_Call (Nod : Node_Id) return Boolean;
-- Determine whether an arbitrary node denotes a call to a protected
@@ -18633,21 +19222,14 @@ package body Sem_Util is
------------------------------
function Within_Volatile_Function (Id : Entity_Id) return Boolean is
- Func_Id : Entity_Id;
+ pragma Assert (Ekind (Id) = E_Return_Statement);
- begin
- -- Traverse the scope stack looking for a [generic] function
+ Func_Id : constant Entity_Id := Return_Applies_To (Id);
- Func_Id := Id;
- while Present (Func_Id) and then Func_Id /= Standard_Standard loop
- if Ekind (Func_Id) in E_Function | E_Generic_Function then
- return Is_Volatile_Function (Func_Id);
- end if;
-
- Func_Id := Scope (Func_Id);
- end loop;
+ begin
+ pragma Assert (Ekind (Func_Id) in E_Function | E_Generic_Function);
- return False;
+ return Is_Volatile_Function (Func_Id);
end Within_Volatile_Function;
-- Local variables
@@ -18657,9 +19239,26 @@ package body Sem_Util is
-- Start of processing for Is_OK_Volatile_Context
begin
+ -- Ignore context restriction when doing preanalysis, e.g. on a copy of
+ -- an expression function, because this copy is not fully decorated and
+ -- it is not possible to reliably decide the legality of the context.
+ -- Any violations will be reported anyway when doing the full analysis.
+
+ if not Full_Analysis then
+ return True;
+ end if;
+
+ -- For actual parameters within explicit parameter associations switch
+ -- the context to the corresponding subprogram call.
+
+ if Nkind (Context) = N_Parameter_Association then
+ return Is_OK_Volatile_Context (Context => Parent (Context),
+ Obj_Ref => Obj_Ref,
+ Check_Actuals => Check_Actuals);
+
-- The volatile object appears on either side of an assignment
- if Nkind (Context) = N_Assignment_Statement then
+ elsif Nkind (Context) = N_Assignment_Statement then
return True;
-- The volatile object is part of the initialization expression of
@@ -18677,7 +19276,7 @@ package body Sem_Util is
-- function is volatile.
if Is_Return_Object (Obj_Id) then
- return Within_Volatile_Function (Obj_Id);
+ return Within_Volatile_Function (Scope (Obj_Id));
-- Otherwise this is a normal object initialization
@@ -18728,8 +19327,9 @@ package body Sem_Util is
N_Slice
and then Prefix (Context) = Obj_Ref
and then Is_OK_Volatile_Context
- (Context => Parent (Context),
- Obj_Ref => Context)
+ (Context => Parent (Context),
+ Obj_Ref => Context,
+ Check_Actuals => Check_Actuals)
then
return True;
@@ -18761,8 +19361,9 @@ package body Sem_Util is
| N_Unchecked_Type_Conversion
and then Expression (Context) = Obj_Ref
and then Is_OK_Volatile_Context
- (Context => Parent (Context),
- Obj_Ref => Context)
+ (Context => Parent (Context),
+ Obj_Ref => Context,
+ Check_Actuals => Check_Actuals)
then
return True;
@@ -18777,17 +19378,43 @@ package body Sem_Util is
elsif Within_Check (Context) then
return True;
- -- Assume that references to effectively volatile objects that appear
- -- as actual parameters in a subprogram call are always legal. A full
- -- legality check is done when the actuals are resolved (see routine
- -- Resolve_Actuals).
+ -- References to effectively volatile objects that appear as actual
+ -- parameters in subprogram calls can be examined only after call itself
+ -- has been resolved. Before that, assume such references to be legal.
- elsif Within_Subprogram_Call (Context) then
- return True;
+ elsif Nkind (Context) in N_Subprogram_Call | N_Entry_Call_Statement then
+ if Check_Actuals then
+ declare
+ Call : Node_Id;
+ Formal : Entity_Id;
+ Subp : constant Entity_Id := Get_Called_Entity (Context);
+ begin
+ Find_Actual (Obj_Ref, Formal, Call);
+ pragma Assert (Call = Context);
+
+ -- 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(10)).
+
+ if not Is_Scalar_Type (Etype (Formal))
+ and then Is_Effectively_Volatile_For_Reading (Etype (Formal))
+ then
+ return True;
- -- Otherwise the context is not suitable for an effectively volatile
- -- object.
+ -- An effectively volatile object may act as an actual in a
+ -- call to an instance of Unchecked_Conversion. (SPARK RM
+ -- 7.1.3(10)).
+ elsif Is_Unchecked_Conversion_Instance (Subp) then
+ return True;
+
+ else
+ return False;
+ end if;
+ end;
+ else
+ return True;
+ end if;
else
return False;
end if;
@@ -18860,7 +19487,7 @@ package body Sem_Util is
elsif Is_Tagged_Type (Typ) then
return True;
- -- Case of non-discriminated record
+ -- Case of nondiscriminated record
else
declare
@@ -19103,8 +19730,8 @@ package body Sem_Util is
and then Aggregate_Type /= Any_Composite
then
if Is_Array_Type (Aggregate_Type) then
- if Ada_Version >= Ada_2020 then
- -- For Ada_2020, this predicate returns True for
+ if Ada_Version >= Ada_2022 then
+ -- For Ada 2022, this predicate returns True for
-- any "repeatedly evaluated" expression.
return True;
end if;
@@ -19517,10 +20144,10 @@ package body Sem_Util is
elsif Nkind (N) = N_Null then
return True;
- -- Ada 2020 (AI12-0175): Calls to certain functions that are essentially
+ -- Ada 2022 (AI12-0175): Calls to certain functions that are essentially
-- unchecked conversions are preelaborable.
- elsif Ada_Version >= Ada_2020
+ elsif Ada_Version >= Ada_2022
and then Nkind (N) = N_Function_Call
and then Is_Entity_Name (Name (N))
and then Is_Preelaborable_Function (Entity (Name (N)))
@@ -19749,7 +20376,8 @@ package body Sem_Util is
function Is_Renamed_Entry (Proc_Nam : Entity_Id) return Boolean is
Orig_Node : Node_Id := Empty;
- Subp_Decl : Node_Id := Parent (Parent (Proc_Nam));
+ Subp_Decl : Node_Id :=
+ (if No (Parent (Proc_Nam)) then Empty else Parent (Parent (Proc_Nam)));
function Is_Entry (Nam : Node_Id) return Boolean;
-- Determine whether Nam is an entry. Traverse selectors if there are
@@ -20022,11 +20650,11 @@ package body Sem_Util is
function Is_Static_Function (Subp : Entity_Id) return Boolean is
begin
- -- Always return False for pre Ada 2020 to e.g. ignore the Static
- -- aspect in package Interfaces for Ada_Version < 2020 and also
+ -- Always return False for pre Ada 2022 to e.g. ignore the Static
+ -- aspect in package Interfaces for Ada_Version < 2022 and also
-- for efficiency.
- return Ada_Version >= Ada_2020
+ return Ada_Version >= Ada_2022
and then Has_Aspect (Subp, Aspect_Static)
and then
(No (Find_Value_Of_Aspect (Subp, Aspect_Static))
@@ -20782,11 +21410,11 @@ package body Sem_Util is
and then Scope (Scope (Scope (Root))) = Standard_Standard;
end Is_Visibly_Controlled;
- --------------------------------------
- -- Is_Volatile_Full_Access_Object --
- --------------------------------------
+ ----------------------------------------
+ -- Is_Volatile_Full_Access_Object_Ref --
+ ----------------------------------------
- function Is_Volatile_Full_Access_Object (N : Node_Id) return Boolean is
+ function Is_Volatile_Full_Access_Object_Ref (N : Node_Id) return Boolean is
function Is_VFA_Object_Entity (Id : Entity_Id) return Boolean;
-- Determine whether arbitrary entity Id denotes an object that is
-- Volatile_Full_Access.
@@ -20804,7 +21432,7 @@ package body Sem_Util is
Is_Volatile_Full_Access (Etype (Id)));
end Is_VFA_Object_Entity;
- -- Start of processing for Is_Volatile_Full_Access_Object
+ -- Start of processing for Is_Volatile_Full_Access_Object_Ref
begin
if Is_Entity_Name (N) then
@@ -20819,7 +21447,7 @@ package body Sem_Util is
else
return False;
end if;
- end Is_Volatile_Full_Access_Object;
+ end Is_Volatile_Full_Access_Object_Ref;
--------------------------
-- Is_Volatile_Function --
@@ -20829,9 +21457,11 @@ package body Sem_Util is
begin
pragma Assert (Ekind (Func_Id) in E_Function | E_Generic_Function);
- -- A function declared within a protected type is volatile
+ -- A protected function is volatile
- if Is_Protected_Type (Scope (Func_Id)) then
+ if Nkind (Parent (Unit_Declaration_Node (Func_Id))) =
+ N_Protected_Definition
+ then
return True;
-- An instance of Ada.Unchecked_Conversion is a volatile function if
@@ -20851,11 +21481,11 @@ package body Sem_Util is
end if;
end Is_Volatile_Function;
- ------------------------
- -- Is_Volatile_Object --
- ------------------------
+ ----------------------------
+ -- Is_Volatile_Object_Ref --
+ ----------------------------
- function Is_Volatile_Object (N : Node_Id) return Boolean is
+ function Is_Volatile_Object_Ref (N : Node_Id) return Boolean is
function Is_Volatile_Object_Entity (Id : Entity_Id) return Boolean;
-- Determine whether arbitrary entity Id denotes an object that is
-- Volatile.
@@ -20901,7 +21531,7 @@ package body Sem_Util is
then
return True;
- elsif Is_Volatile_Object (P) then
+ elsif Is_Volatile_Object_Ref (P) then
return True;
else
@@ -20909,7 +21539,7 @@ package body Sem_Util is
end if;
end Prefix_Has_Volatile_Components;
- -- Start of processing for Is_Volatile_Object
+ -- Start of processing for Is_Volatile_Object_Ref
begin
if Is_Entity_Name (N) then
@@ -20928,7 +21558,7 @@ package body Sem_Util is
else
return False;
end if;
- end Is_Volatile_Object;
+ end Is_Volatile_Object_Ref;
-----------------------------
-- Iterate_Call_Parameters --
@@ -22727,9 +23357,6 @@ package body Sem_Util is
-- This routine performs low-level tree manipulations and needs access
-- to the internals of the tree.
- use Atree.Unchecked_Access;
- use Atree_Private_Part;
-
EWA_Level : Nat := 0;
-- This counter keeps track of how many N_Expression_With_Actions nodes
-- are encountered during a depth-first traversal of the subtree. These
@@ -23271,6 +23898,25 @@ package body Sem_Util is
function Copy_Node_With_Replacement (N : Node_Id) return Node_Id is
Result : Node_Id;
+ function Transform (U : Union_Id) return Union_Id;
+ -- Copies one field, replacing N with Result
+
+ ---------------
+ -- Transform --
+ ---------------
+
+ function Transform (U : Union_Id) return Union_Id is
+ begin
+ return Copy_Field_With_Replacement
+ (Field => U,
+ Old_Par => N,
+ New_Par => Result);
+ end Transform;
+
+ procedure Walk is new Walk_Sinfo_Fields_Pairwise (Transform);
+
+ -- Start of processing for Copy_Node_With_Replacement
+
begin
-- Assume that the node must be returned unchanged
@@ -23281,35 +23927,7 @@ package body Sem_Util is
Result := New_Copy (N);
- Set_Field1 (Result,
- Copy_Field_With_Replacement
- (Field => Field1 (Result),
- Old_Par => N,
- New_Par => Result));
-
- Set_Field2 (Result,
- Copy_Field_With_Replacement
- (Field => Field2 (Result),
- Old_Par => N,
- New_Par => Result));
-
- Set_Field3 (Result,
- Copy_Field_With_Replacement
- (Field => Field3 (Result),
- Old_Par => N,
- New_Par => Result));
-
- Set_Field4 (Result,
- Copy_Field_With_Replacement
- (Field => Field4 (Result),
- Old_Par => N,
- New_Par => Result));
-
- Set_Field5 (Result,
- Copy_Field_With_Replacement
- (Field => Field5 (Result),
- Old_Par => N,
- New_Par => Result));
+ Walk (Result, Result);
-- Update the Comes_From_Source and Sloc attributes of the node
-- in case the caller has supplied new values.
@@ -23449,7 +24067,7 @@ package body Sem_Util is
-- A new source location defaults the Comes_From_Source attribute
if New_Sloc /= No_Location then
- Set_Comes_From_Source (N, Default_Node.Comes_From_Source);
+ Set_Comes_From_Source (N, Get_Comes_From_Source_Default);
Set_Sloc (N, New_Sloc);
end if;
end Update_CFS_Sloc;
@@ -24056,25 +24674,37 @@ package body Sem_Util is
EWA_Inner_Scope_Level := EWA_Inner_Scope_Level + 1;
end if;
- Visit_Field
- (Field => Field1 (N),
- Par_Nod => N);
+ -- If the node is a block, we need to process all declarations
+ -- in the block and make new entities for each.
- Visit_Field
- (Field => Field2 (N),
- Par_Nod => N);
+ if Nkind (N) = N_Block_Statement and then Present (Declarations (N))
+ then
+ declare
+ Decl : Node_Id := First (Declarations (N));
- Visit_Field
- (Field => Field3 (N),
- Par_Nod => N);
+ begin
+ while Present (Decl) loop
+ if Nkind (Decl) = N_Object_Declaration then
+ Add_New_Entity (Defining_Identifier (Decl),
+ New_Copy (Defining_Identifier (Decl)));
+ end if;
- Visit_Field
- (Field => Field4 (N),
- Par_Nod => N);
+ Next (Decl);
+ end loop;
+ end;
+ end if;
- Visit_Field
- (Field => Field5 (N),
- Par_Nod => N);
+ declare
+ procedure Action (U : Union_Id);
+ procedure Action (U : Union_Id) is
+ begin
+ Visit_Field (Field => U, Par_Nod => N);
+ end Action;
+
+ procedure Walk is new Walk_Sinfo_Fields (Action);
+ begin
+ Walk (N);
+ end;
if EWA_Level > 0
and then Nkind (N) in N_Block_Statement
@@ -24284,10 +24914,10 @@ package body Sem_Util is
(Chars (Related_Id), Suffix, Suffix_Index, Prefix));
begin
- Set_Ekind (N, Kind);
- Set_Is_Internal (N, True);
- Append_Entity (N, Scope_Id);
- Set_Public_Status (N);
+ Mutate_Ekind (N, Kind);
+ Set_Is_Internal (N, True);
+ Append_Entity (N, Scope_Id);
+ Set_Public_Status (N);
if Kind in Type_Kind then
Init_Size_Align (N);
@@ -24309,7 +24939,7 @@ package body Sem_Util is
N : constant Entity_Id := Make_Temporary (Sloc_Value, Id_Char);
begin
- Set_Ekind (N, Kind);
+ Mutate_Ekind (N, Kind);
Set_Is_Internal (N, True);
Append_Entity (N, Scope_Id);
@@ -24941,7 +25571,7 @@ package body Sem_Util is
Domain : constant Node_Id := Name (Parent (Ent));
begin
- -- TBD : in the full version of the construct, the
+ -- ??? In the full version of the construct, the
-- domain of iteration can be given by an expression.
if Is_Entity_Name (Domain) then
@@ -26008,14 +26638,16 @@ package body Sem_Util is
Partial_DIC_Proc := Partial_DIC_Procedure (From_Typ);
-- The setting of the attributes is intentionally conservative. This
- -- prevents accidental clobbering of enabled attributes.
+ -- prevents accidental clobbering of enabled attributes. We need to
+ -- call Base_Type twice, because it is sometimes not set to an actual
+ -- base type.
if Has_Inherited_DIC (From_Typ) then
- Set_Has_Inherited_DIC (Typ);
+ Set_Has_Inherited_DIC (Base_Type (Base_Type (Typ)));
end if;
if Has_Own_DIC (From_Typ) then
- Set_Has_Own_DIC (Typ);
+ Set_Has_Own_DIC (Base_Type (Base_Type (Typ)));
end if;
if Present (DIC_Proc) and then No (DIC_Procedure (Typ)) then
@@ -26056,7 +26688,9 @@ package body Sem_Util is
Part_IP := Partial_Invariant_Procedure (From_Typ);
-- The setting of the attributes is intentionally conservative. This
- -- prevents accidental clobbering of enabled attributes.
+ -- prevents accidental clobbering of enabled attributes. We need to
+ -- call Base_Type twice, because it is sometimes not set to an actual
+ -- base type.
if Has_Inheritable_Invariants (From_Typ) then
Set_Has_Inheritable_Invariants (Typ);
@@ -26067,7 +26701,7 @@ package body Sem_Util is
end if;
if Has_Own_Invariants (From_Typ) then
- Set_Has_Own_Invariants (Base_Type (Typ));
+ Set_Has_Own_Invariants (Base_Type (Base_Type (Typ)));
end if;
if Present (Full_IP) and then No (Invariant_Procedure (Typ)) then
@@ -26371,6 +27005,8 @@ package body Sem_Util is
-- generated before the next instruction.
function Requires_Transient_Scope (Id : Entity_Id) return Boolean is
+ pragma Assert (if Present (Id) then Ekind (Id) in E_Void | Type_Kind);
+
function Caller_Known_Size_Record (Typ : Entity_Id) return Boolean;
-- This is called for untagged records and protected types, with
-- nondefaulted discriminants. Returns True if the size of function
@@ -26451,8 +27087,8 @@ package body Sem_Util is
-- 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)
+ if not Is_Frozen (Typ)
+ and then Is_Base_Type (Typ)
and then (Is_Record_Type (Typ)
or else Is_Concurrent_Type (Typ)
or else Is_Incomplete_Or_Private_Type (Typ))
@@ -26568,19 +27204,20 @@ package body Sem_Util is
-- Start of processing for Requires_Transient_Scope
begin
- Ensure_Minimum_Decoration (Id);
-
-- This is a private type which is not completed yet. This can only
-- happen in a default expression (of a formal parameter or of a
-- record component). Do not expand transient scope in this case.
if No (Typ) then
return False;
+ end if;
+
+ Ensure_Minimum_Decoration (Id);
-- Do not expand transient scope for non-existent procedure return or
-- string literal types.
- elsif Typ = Standard_Void_Type
+ if Typ = Standard_Void_Type
or else Ekind (Typ) = E_String_Literal_Subtype
then
return False;
@@ -26721,7 +27358,7 @@ package body Sem_Util is
is
begin
-- The only entities for which we track constant values are variables
- -- which are not renamings, constants and formal parameters, so check
+ -- that 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
@@ -26792,7 +27429,7 @@ package body Sem_Util is
-- or an exception handler). We skip this if Cond is True, since the
-- capturing of values from conditional tests handles this ok.
- if Cond then
+ if Cond or else No (N) then
return True;
end if;
@@ -27163,66 +27800,6 @@ package body Sem_Util is
return False;
end Scope_Within_Or_Same;
- --------------------
- -- Set_Convention --
- --------------------
-
- procedure Set_Convention (E : Entity_Id; Val : Snames.Convention_Id) is
- begin
- Basic_Set_Convention (E, Val);
-
- if Is_Type (E)
- and then Is_Access_Subprogram_Type (Base_Type (E))
- and then Has_Foreign_Convention (E)
- then
- Set_Can_Use_Internal_Rep (E, False);
- end if;
-
- -- If E is an object, including a component, and the type of E is an
- -- anonymous access type with no convention set, then also set the
- -- convention of the anonymous access type. We do not do this for
- -- anonymous protected types, since protected types always have the
- -- default convention.
-
- if Present (Etype (E))
- and then (Is_Object (E)
-
- -- Allow E_Void (happens for pragma Convention appearing
- -- in the middle of a record applying to a component)
-
- or else Ekind (E) = E_Void)
- then
- declare
- Typ : constant Entity_Id := Etype (E);
-
- begin
- 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);
- Set_Has_Convention_Pragma (Typ);
-
- -- And for the access subprogram type, deal similarly with the
- -- designated E_Subprogram_Type, which is always internal.
-
- if Ekind (Typ) = E_Anonymous_Access_Subprogram_Type then
- declare
- Dtype : constant Entity_Id := Designated_Type (Typ);
- begin
- if Ekind (Dtype) = E_Subprogram_Type
- and then not Has_Convention_Pragma (Dtype)
- then
- Basic_Set_Convention (Dtype, Val);
- Set_Has_Convention_Pragma (Dtype);
- end if;
- end;
- end if;
- end if;
- end;
- end if;
- end Set_Convention;
-
------------------------
-- Set_Current_Entity --
------------------------
@@ -27789,7 +28366,7 @@ package body Sem_Util is
Set_Is_Unsigned_Type (T1, Is_Unsigned_Type (T2));
end if;
- Set_Alignment (T1, Alignment (T2));
+ Copy_Alignment (To => T1, From => T2);
end Set_Size_Info;
------------------------------
@@ -28587,12 +29164,15 @@ package body Sem_Util is
-- Type_Access_Level --
-----------------------
- function Type_Access_Level (Typ : Entity_Id) return Uint is
- Btyp : Entity_Id;
+ function Type_Access_Level
+ (Typ : Entity_Id;
+ Allow_Alt_Model : Boolean := True;
+ Assoc_Ent : Entity_Id := Empty) return Uint
+ is
+ Btyp : Entity_Id := Base_Type (Typ);
+ Def_Ent : Entity_Id;
begin
- Btyp := Base_Type (Typ);
-
-- Ada 2005 (AI-230): For most cases of anonymous access types, we
-- simply use the level where the type is declared. This is true for
-- stand-alone object declarations, and for anonymous access types
@@ -28603,13 +29183,62 @@ package body Sem_Util is
if Is_Access_Type (Btyp) then
if Ekind (Btyp) = E_Anonymous_Access_Type then
+ -- No_Dynamic_Accessibility_Checks restriction override for
+ -- alternative accessibility model.
+
+ if Allow_Alt_Model
+ and then No_Dynamic_Accessibility_Checks_Enabled (Btyp)
+ then
+ -- In the -gnatd_b model, the level of an anonymous access
+ -- type is always that of the designated type.
+
+ if Debug_Flag_Underscore_B then
+ return Type_Access_Level
+ (Designated_Type (Btyp), Allow_Alt_Model);
+ end if;
+
+ -- When an anonymous access type's Assoc_Ent is specifiedi,
+ -- calculate the result based on the general accessibility
+ -- level routine.
+
+ -- We would like to use Associated_Node_For_Itype here instead,
+ -- but in some cases it is not fine grained enough ???
+
+ if Present (Assoc_Ent) then
+ return Static_Accessibility_Level
+ (Assoc_Ent, Object_Decl_Level);
+ end if;
+
+ -- Otherwise take the context of the anonymous access type into
+ -- account.
+
+ -- Obtain the defining entity for the internally generated
+ -- anonymous access type.
+
+ Def_Ent := Defining_Entity_Or_Empty
+ (Associated_Node_For_Itype (Typ));
+
+ if Present (Def_Ent) then
+ -- When the type comes from an anonymous access parameter,
+ -- the level is that of the subprogram declaration.
+
+ if Ekind (Def_Ent) in Subprogram_Kind then
+ return Scope_Depth (Def_Ent);
+
+ -- When the type is an access discriminant, the level is
+ -- that of the type.
+
+ elsif Ekind (Def_Ent) = E_Discriminant then
+ return Scope_Depth (Scope (Def_Ent));
+ end if;
+ end if;
-- If the type is a nonlocal anonymous access type (such as for
-- an access parameter) we treat it as being declared at the
-- library level to ensure that names such as X.all'access don't
-- fail static accessibility checks.
- if not Is_Local_Anonymous_Access (Typ) then
+ elsif not Is_Local_Anonymous_Access (Typ) then
return Scope_Depth (Standard_Standard);
-- If this is a return object, the accessibility level is that of
@@ -28643,7 +29272,7 @@ package body Sem_Util is
-- Treat the return object's type as having the level of the
-- function's result subtype (as per RM05-6.5(5.3/2)).
- return Type_Access_Level (Etype (Scop));
+ return Type_Access_Level (Etype (Scop), Allow_Alt_Model);
end;
end if;
end if;
@@ -28754,6 +29383,39 @@ package body Sem_Util is
end if;
end Type_Without_Stream_Operation;
+ ------------------------------
+ -- Ultimate_Overlaid_Entity --
+ ------------------------------
+
+ function Ultimate_Overlaid_Entity (E : Entity_Id) return Entity_Id is
+ Address : Node_Id;
+ Alias : Entity_Id := E;
+ Offset : Boolean;
+
+ begin
+ -- Currently this routine is only called for stand-alone objects that
+ -- have been analysed, since the analysis of the Address aspect is often
+ -- delayed.
+
+ pragma Assert (Ekind (E) in E_Constant | E_Variable);
+
+ loop
+ Address := Address_Clause (Alias);
+ if Present (Address) then
+ Find_Overlaid_Entity (Address, Alias, Offset);
+ if Present (Alias) then
+ null;
+ else
+ return Empty;
+ end if;
+ elsif Alias = E then
+ return Empty;
+ else
+ return Alias;
+ end if;
+ end loop;
+ end Ultimate_Overlaid_Entity;
+
---------------------
-- Ultimate_Prefix --
---------------------
@@ -29186,9 +29848,7 @@ package body Sem_Util is
if Nkind (Opnd) = N_Defining_Identifier
or else not Is_Overloaded (Opnd)
then
- if Etype (Opnd) = Universal_Integer
- or else Etype (Opnd) = Universal_Real
- then
+ if Is_Universal_Numeric_Type (Etype (Opnd)) then
return Etype (Opnd);
else
return Empty;
@@ -29197,9 +29857,7 @@ package body Sem_Util is
else
Get_First_Interp (Opnd, Index, It);
while Present (It.Typ) loop
- if It.Typ = Universal_Integer
- or else It.Typ = Universal_Real
- then
+ if Is_Universal_Numeric_Type (It.Typ) then
return It.Typ;
end if;
@@ -29255,42 +29913,55 @@ package body Sem_Util is
--------------------
function Validated_View (Typ : Entity_Id) return Entity_Id is
- Continue : Boolean;
- Val_Typ : Entity_Id;
-
begin
- Continue := True;
- Val_Typ := Base_Type (Typ);
+ -- Scalar types can be always validated. In fast, switiching to the base
+ -- type would drop the range constraints and force validation to use a
+ -- larger type than necessary.
+
+ if Is_Scalar_Type (Typ) then
+ return Typ;
+
+ -- Array types can be validated even when they are derived, because
+ -- validation only requires their bounds and component types to be
+ -- accessible. In fact, switching to the parent type would pollute
+ -- expansion of attribute Valid_Scalars with unnecessary conversion
+ -- that might not be eliminated by the frontend.
+
+ elsif Is_Array_Type (Typ) then
+ return Typ;
+
+ -- For other types, in particular for record subtypes, we switch to the
+ -- base type.
+
+ elsif not Is_Base_Type (Typ) then
+ return Validated_View (Base_Type (Typ));
-- Obtain the full view of the input type by stripping away concurrency,
-- derivations, and privacy.
- while Continue loop
- Continue := False;
-
- if Is_Concurrent_Type (Val_Typ) then
- if Present (Corresponding_Record_Type (Val_Typ)) then
- Continue := True;
- Val_Typ := Corresponding_Record_Type (Val_Typ);
- end if;
+ elsif Is_Concurrent_Type (Typ) then
+ if Present (Corresponding_Record_Type (Typ)) then
+ return Corresponding_Record_Type (Typ);
+ else
+ return Typ;
+ end if;
- elsif Is_Derived_Type (Val_Typ) then
- Continue := True;
- Val_Typ := Etype (Val_Typ);
+ elsif Is_Derived_Type (Typ) then
+ return Validated_View (Etype (Typ));
- elsif Is_Private_Type (Val_Typ) then
- if Present (Underlying_Full_View (Val_Typ)) then
- Continue := True;
- Val_Typ := Underlying_Full_View (Val_Typ);
+ elsif Is_Private_Type (Typ) then
+ if Present (Underlying_Full_View (Typ)) then
+ return Validated_View (Underlying_Full_View (Typ));
- elsif Present (Full_View (Val_Typ)) then
- Continue := True;
- Val_Typ := Full_View (Val_Typ);
- end if;
+ elsif Present (Full_View (Typ)) then
+ return Validated_View (Full_View (Typ));
+ else
+ return Typ;
end if;
- end loop;
- return Val_Typ;
+ else
+ return Typ;
+ end if;
end Validated_View;
-----------------------
@@ -29381,36 +30052,6 @@ package body Sem_Util is
return Scope_Within_Or_Same (Scope (E), S);
end Within_Scope;
- ----------------------------
- -- Within_Subprogram_Call --
- ----------------------------
-
- function Within_Subprogram_Call (N : Node_Id) return Boolean is
- Par : Node_Id;
-
- begin
- -- Climb the parent chain looking for a function or procedure call
-
- Par := N;
- while Present (Par) loop
- if Nkind (Par) in N_Entry_Call_Statement
- | N_Function_Call
- | N_Procedure_Call_Statement
- then
- return True;
-
- -- Prevent the search from going too far
-
- elsif Is_Body_Or_Package_Declaration (Par) then
- exit;
- end if;
-
- Par := Parent (Par);
- end loop;
-
- return False;
- end Within_Subprogram_Call;
-
----------------
-- Wrong_Type --
----------------
@@ -29939,7 +30580,7 @@ package body Sem_Util is
procedure Normalize_Interval_List
(List : in out Discrete_Interval_List; Last : out Nat);
- -- Perform sorting and merging as required by Check_Consistency.
+ -- Perform sorting and merging as required by Check_Consistency
-------------------------
-- Aggregate_Intervals --
@@ -29954,6 +30595,10 @@ package body Sem_Util is
-- Count the number of intervals given in the aggregate N; the others
-- choice (if present) is not taken into account.
+ ------------------------------
+ -- Unmerged_Intervals_Count --
+ ------------------------------
+
function Unmerged_Intervals_Count return Nat is
Count : Nat := 0;
Choice : Node_Id;
@@ -30054,7 +30699,7 @@ package body Sem_Util is
(Discrete_Choices : List_Id) return Discrete_Interval_List
is
function Unmerged_Choice_Count return Nat;
- -- The number of intervals before adjacent intervals are merged.
+ -- The number of intervals before adjacent intervals are merged
---------------------------
-- Unmerged_Choice_Count --
@@ -30732,7 +31377,7 @@ package body Sem_Util is
-- type case correctly, so we avoid that problem by
-- returning True here.
return True;
- elsif Ada_Version < Ada_2020 then
+ elsif Ada_Version < Ada_2022 then
return False;
elsif not Is_Conditionally_Evaluated (Expr) then
return False;
@@ -31143,9 +31788,9 @@ package body Sem_Util is
(Loc, Access_Type_Id,
Type_Definition => Access_Type_Def);
begin
- Set_Ekind (Temp_Id, E_Variable);
+ Mutate_Ekind (Temp_Id, E_Variable);
Set_Etype (Temp_Id, Access_Type_Id);
- Set_Ekind (Access_Type_Id, E_Access_Type);
+ Mutate_Ekind (Access_Type_Id, E_Access_Type);
if Append_Decls_In_Reverse_Order then
Append_Item (Temp_Decl, Is_Eval_Stmt => False);
diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads
index 6560180..b0d6a2a 100644
--- a/gcc/ada/sem_util.ads
+++ b/gcc/ada/sem_util.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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,16 +25,17 @@
-- Package containing utility procedures used throughout the semantics
-with Aspects; use Aspects;
-with Atree; use Atree;
-with Einfo; use Einfo;
-with Exp_Tss; use Exp_Tss;
-with Namet; use Namet;
-with Opt; use Opt;
-with Snames; use Snames;
-with Types; use Types;
-with Uintp; use Uintp;
-with Urealp; use Urealp;
+with Aspects; use Aspects;
+with Atree; use Atree;
+with Einfo; use Einfo;
+with Einfo.Entities; use Einfo.Entities;
+with Exp_Tss; use Exp_Tss;
+with Namet; use Namet;
+with Opt; use Opt;
+with Snames; use Snames;
+with Types; use Types;
+with Uintp; use Uintp;
+with Urealp; use Urealp;
package Sem_Util is
@@ -64,15 +65,19 @@ package Sem_Util is
function Accessibility_Level
(Expr : Node_Id;
Level : Accessibility_Level_Kind;
- In_Return_Context : Boolean := False) return Node_Id;
+ In_Return_Context : Boolean := False;
+ Allow_Alt_Model : Boolean := True) return Node_Id;
-- Centralized accessibility level calculation routine for finding the
-- accessibility level of a given expression Expr.
- -- In_Return_Context forcing the Accessibility_Level calculations to be
+ -- In_Return_Context forces the Accessibility_Level calculations to be
-- carried out "as if" Expr existed in a return value. This is useful for
-- calculating the accessibility levels for discriminant associations
-- and return aggregates.
+ -- The Allow_Alt_Model parameter allows the alternative level calculation
+ -- under the restriction No_Dynamic_Accessibility_Checks to be performed.
+
function Acquire_Warning_Match_String (Str_Lit : Node_Id) return String;
-- Used by pragma Warnings (Off, string), and Warn_As_Error (string) to get
-- the given string argument, adding leading and trailing asterisks if they
@@ -156,14 +161,14 @@ package Sem_Util is
-- part of the current package.
procedure Apply_Compile_Time_Constraint_Error
- (N : Node_Id;
- Msg : String;
- Reason : RT_Exception_Code;
- Ent : Entity_Id := Empty;
- Typ : Entity_Id := Empty;
- Loc : Source_Ptr := No_Location;
- Rep : Boolean := True;
- Warn : Boolean := False);
+ (N : Node_Id;
+ Msg : String;
+ Reason : RT_Exception_Code;
+ Ent : Entity_Id := Empty;
+ Typ : Entity_Id := Empty;
+ Loc : Source_Ptr := No_Location;
+ Warn : Boolean := False;
+ Emit_Message : Boolean := True);
-- N is a subexpression that will raise Constraint_Error when evaluated
-- at run time. Msg is a message that explains the reason for raising the
-- exception. The last character is ? if the message is always a warning,
@@ -171,21 +176,21 @@ package Sem_Util is
-- (because of violation of static expression rules) in Ada 95 (but not
-- in Ada 83). Typically this routine posts all messages at the Sloc of
-- node N. However, if Loc /= No_Location, Loc is the Sloc used to output
- -- the message. After posting the appropriate message, and if the flag
- -- Rep is set, this routine replaces the expression with an appropriate
- -- N_Raise_Constraint_Error node using the given Reason code. This node
- -- is then marked as being static if the original node is static, but
- -- sets the flag Raises_Constraint_Error, preventing further evaluation.
- -- The error message may contain a } or & insertion character. This
- -- normally references Etype (N), unless the Ent argument is given
- -- explicitly, in which case it is used instead. The type of the raise
- -- node that is built is normally Etype (N), but if the Typ parameter
- -- is present, this is used instead. Warn is normally False. If it is
- -- True then the message is treated as a warning even though it does
- -- not end with a ? (this is used when the caller wants to parameterize
- -- whether an error or warning is given), or when the message should be
- -- treated as a warning even when SPARK_Mode is On (which otherwise would
- -- force an error).
+ -- the message. After posting the appropriate message, this routine
+ -- replaces the expression with an appropriate N_Raise_Constraint_Error
+ -- node using the given Reason code. This node is then marked as being
+ -- static if the original node is static, but sets the flag
+ -- Raises_Constraint_Error, preventing further evaluation. The error
+ -- message may contain a } or & insertion character. This normally
+ -- references Etype (N), unless the Ent argument is given explicitly, in
+ -- which case it is used instead. The type of the raise node that is built
+ -- is normally Etype (N), but if the Typ parameter is present, this is used
+ -- instead. Warn is normally False. If it is True then the message is
+ -- treated as a warning even though it does not end with a ? (this is used
+ -- when the caller wants to parameterize whether an error or warning is
+ -- given), or when the message should be treated as a warning even when
+ -- SPARK_Mode is On (which otherwise would force an error).
+ -- If Emit_Message is False, then do not emit any message.
function Async_Readers_Enabled (Id : Entity_Id) return Boolean;
-- Id should be the entity of a state abstraction, an object, or a type.
@@ -381,7 +386,7 @@ package Sem_Util is
-- means that for sure CE cannot be raised.
procedure Check_Ambiguous_Aggregate (Call : Node_Id);
- -- Additional information on an ambiguous call in Ada_2020 when a
+ -- Additional information on an ambiguous call in Ada_2022 when a
-- subprogram call has an actual that is an aggregate, and the
-- presence of container aggregates (or types with the correwponding
-- aspect) provides an additional interpretation. Message indicates
@@ -583,6 +588,21 @@ package Sem_Util is
-- emitted immediately after the main message (and before output of any
-- message indicating that Constraint_Error will be raised).
+ procedure Compute_Returns_By_Ref (Func : Entity_Id);
+ -- Set the Returns_By_Ref flag on Func if appropriate
+
+ generic
+ with function Predicate (Typ : Entity_Id) return Boolean;
+ function Collect_Types_In_Hierarchy
+ (Typ : Entity_Id;
+ Examine_Components : Boolean := False) return Elist_Id;
+ -- Inspect the ancestor and progenitor types of Typ and Typ itself -
+ -- collecting those for which function Predicate is True. The resulting
+ -- list is ordered in a type-to-ultimate-ancestor fashion.
+
+ -- When Examine_Components is True, components types in the hierarchy also
+ -- get collected.
+
procedure Conditional_Delay (New_Ent, Old_Ent : Entity_Id);
-- Sets the Has_Delayed_Freeze flag of New_Ent if the Delayed_Freeze flag
-- of Old_Ent is set and Old_Ent has not yet been Frozen (i.e. Is_Frozen is
@@ -642,7 +662,16 @@ package Sem_Util is
-- Current_Scope is returned. The returned value is Empty if this is called
-- from a library package which is not within any subprogram.
- function Deepest_Type_Access_Level (Typ : Entity_Id) return Uint;
+ function CW_Or_Has_Controlled_Part (T : Entity_Id) return Boolean;
+ -- True if T is a class-wide type, or if it has controlled parts ("part"
+ -- means T or any of its subcomponents). Same as Needs_Finalization, except
+ -- when pragma Restrictions (No_Finalization) applies, in which case we
+ -- know that class-wide objects do not contain controlled parts.
+
+ function Deepest_Type_Access_Level
+ (Typ : Entity_Id;
+ Allow_Alt_Model : Boolean := True) return Uint;
+
-- Same as Type_Access_Level, except that if the type is the type of an Ada
-- 2012 stand-alone object of an anonymous access type, then return the
-- static accessibility level of the object. In that case, the dynamic
@@ -652,9 +681,10 @@ package Sem_Util is
-- in the case of a descendant of a generic formal type (returns Int'Last
-- instead of 0).
- function Defining_Entity
- (N : Node_Id;
- Empty_On_Errors : Boolean := False) return Entity_Id;
+ -- The Allow_Alt_Model parameter allows the alternative level calculation
+ -- under the restriction No_Dynamic_Accessibility_Checks to be performed.
+
+ function Defining_Entity (N : Node_Id) return Entity_Id;
-- Given a declaration N, returns the associated defining entity. If the
-- declaration has a specification, the entity is obtained from the
-- specification. If the declaration has a defining unit name, then the
@@ -665,19 +695,13 @@ package Sem_Util is
-- local entities declared during loop expansion. These entities need
-- debugging information, generated through Qualify_Entity_Names, and
-- the loop declaration must be placed in the table Name_Qualify_Units.
- --
- -- Set flag Empty_On_Errors to change the behavior of this routine as
- -- follows:
- --
- -- * True - A declaration that lacks a defining entity returns Empty.
- -- A node that does not allow for a defining entity returns Empty.
- --
- -- * False - A declaration that lacks a defining entity is given a new
- -- internally generated entity which is subsequently returned. A node
- -- that does not allow for a defining entity raises Program_Error
-- WARNING: There is a matching C declaration of this subprogram in fe.h
+ function Defining_Entity_Or_Empty (N : Node_Id) return Entity_Id;
+ -- This is equivalent to Defining_Entity but it returns Empty for nodes
+ -- without an entity instead of raising Program_Error.
+
function Denotes_Discriminant
(N : Node_Id;
Check_Concurrent : Boolean := False) return Boolean;
@@ -897,12 +921,11 @@ package Sem_Util is
(N : Node_Id;
Ent : out Entity_Id;
Off : out Boolean);
- -- The node N should be an address representation clause. Determines if
- -- the target expression is the address of an entity with an optional
- -- offset. If so, set Ent to the entity and, if there is an offset, set
- -- Off to True, otherwise to False. If N is not an address representation
- -- clause, or if it is not possible to determine that the address is of
- -- this form, then set Ent to Empty.
+ -- The node N should be an address representation clause. Determines if the
+ -- target expression is the address of an entity with an optional offset.
+ -- If so, set Ent to the entity and, if there is an offset, set Off to
+ -- True, otherwise to False. If it is not possible to determine that the
+ -- address is of this form, then set Ent to Empty.
function Find_Parameter_Type (Param : Node_Id) return Entity_Id;
-- Return the type of formal parameter Param as determined by its
@@ -1076,7 +1099,8 @@ package Sem_Util is
-- to its tail.
--
-- Report_Errors is set to True if the values of the discriminants are
- -- non-static.
+ -- insufficiently static (see body for details of what that means).
+
--
-- Allow_Compile_Time if set to True, allows compile time known values in
-- Governed_By expressions in addition to static expressions.
@@ -1164,6 +1188,26 @@ package Sem_Util is
-- the index type turns out to be a partial view; this case should not
-- arise during normal compilation of semantically correct programs.
+ type Range_Nodes is record
+ First, Last : Node_Id; -- First and Last nodes of a discrete_range
+ end record;
+
+ type Range_Values is record
+ First, Last : Uint; -- First and Last values of a discrete_range
+ end record;
+
+ function Get_Index_Bounds
+ (N : Node_Id;
+ Use_Full_View : Boolean := False) return Range_Nodes;
+ -- Same as the above procedure, but returns the result as a record.
+ -- ???This should probably replace the procedure.
+
+ function Get_Index_Bounds
+ (N : Node_Id;
+ Use_Full_View : Boolean := False) return Range_Values;
+ -- Same as the above function, but returns the values, which must be known
+ -- at compile time.
+
procedure Get_Interfacing_Aspects
(Iface_Asp : Node_Id;
Conv_Asp : out Node_Id;
@@ -1305,18 +1349,18 @@ package Sem_Util is
function Get_Fullest_View
(E : Entity_Id; Include_PAT : Boolean := True) return Entity_Id;
- -- Get the fullest possible view of E, looking through private,
- -- limited, packed array and other implementation types. If Include_PAT
- -- is False, don't look inside packed array types.
+ -- Get the fullest possible view of E, looking through private, limited,
+ -- packed array and other implementation types. If Include_PAT is False,
+ -- don't look inside packed array types.
function Has_Access_Values (T : Entity_Id) return Boolean;
- -- Returns true if type or subtype T is an access type, or has a component
- -- (at any recursive level) that is an access type. This is a conservative
- -- predicate, if it is not known whether or not T contains access values
- -- (happens for generic formals in some cases), then False is returned.
- -- Note that tagged types return False. Even though the tag is implemented
- -- as an access type internally, this function tests only for access types
- -- known to the programmer. See also Has_Tagged_Component.
+ -- Returns true if the underlying type of T is an access type, or has a
+ -- component (at any recursive level) that is an access type. This is a
+ -- conservative predicate, if it is not known whether or not T contains
+ -- access values (happens for generic formals in some cases), then False is
+ -- returned. Note that tagged types return False. Even though the tag is
+ -- implemented as an access type internally, this function tests only for
+ -- access types known to the programmer. See also Has_Tagged_Component.
function Has_Anonymous_Access_Discriminant (Typ : Entity_Id) return Boolean;
-- Returns True if Typ has one or more anonymous access discriminants
@@ -1390,6 +1434,17 @@ package Sem_Util is
-- Determine whether type Typ has a suitable Default_Initial_Condition
-- pragma which provides the full default initialization of the type.
+ function Has_Inferable_Discriminants (N : Node_Id) return Boolean;
+ -- Ada 2005 (AI-216): A view of an Unchecked_Union object has inferable
+ -- discriminants if it has a constrained nominal type, unless the object
+ -- is a component of an enclosing Unchecked_Union object that is subject
+ -- to a per-object constraint and the enclosing object lacks inferable
+ -- discriminants.
+ --
+ -- An expression of an Unchecked_Union type has inferable discriminants
+ -- if it is either a name of an object with inferable discriminants or a
+ -- qualified expression whose subtype mark denotes a constrained subtype.
+
function Has_Infinities (E : Entity_Id) return Boolean;
-- Determines if the range of the floating-point type E includes
-- infinities. Returns False if E is not a floating-point type.
@@ -1463,6 +1518,12 @@ package Sem_Util is
-- integer for use in compile-time checking. Note: Level is restricted to
-- be non-dynamic.
+ function Is_Prim_Of_Abst_Type_With_Nonstatic_CW_Pre_Post
+ (Subp : Entity_Id) return Boolean;
+ -- Return True if Subp is a primitive of an abstract type, where the
+ -- primitive has a class-wide pre- or postcondition whose expression
+ -- is nonstatic.
+
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
@@ -1581,9 +1642,11 @@ package Sem_Util is
function In_Pragma_Expression (N : Node_Id; Nam : Name_Id) return Boolean;
-- Returns true if the expression N occurs within a pragma with name Nam
- function In_Pre_Post_Condition (N : Node_Id) return Boolean;
+ function In_Pre_Post_Condition
+ (N : Node_Id; Class_Wide_Only : Boolean := False) return Boolean;
-- Returns True if node N appears within a pre/postcondition pragma. Note
- -- the pragma Check equivalents are NOT considered.
+ -- the pragma Check equivalents are NOT considered. If Class_Wide_Only is
+ -- True, then tests for N appearing within a class-wide pre/postcondition.
function In_Quantified_Expression (N : Node_Id) return Boolean;
-- Returns true if the expression N occurs within a quantified expression
@@ -1712,7 +1775,7 @@ package Sem_Util is
-- subprogram call.
function Is_Actual_Parameter (N : Node_Id) return Boolean;
- -- Determines if N is an actual parameter in a subprogram call
+ -- Determines if N is an actual parameter in a subprogram or entry call
function Is_Actual_Tagged_Parameter (N : Node_Id) return Boolean;
-- Determines if N is an actual parameter of a formal of tagged type in a
@@ -1987,7 +2050,7 @@ package Sem_Util is
function Is_Full_Access_Object (N : Node_Id) return Boolean;
-- Determine whether arbitrary node N denotes a reference to a full access
- -- object as per Ada 2020 RM C.6(8.2).
+ -- object as per Ada 2022 RM C.6(8.2).
function Is_Fully_Initialized_Type (Typ : Entity_Id) return Boolean;
-- Typ is a type entity. This function returns true if this type is fully
@@ -2060,9 +2123,8 @@ package Sem_Util is
-- limited view must be treated in the same way.
function Is_Local_Variable_Reference (Expr : Node_Id) return Boolean;
- -- Determines whether Expr is a reference to a variable or IN OUT mode
- -- parameter of the current enclosing subprogram.
- -- Why are OUT parameters not considered here ???
+ -- Determines whether Expr is a reference to a variable or formal parameter
+ -- of mode OUT or IN OUT of the current enclosing subprogram.
function Is_Master (N : Node_Id) return Boolean;
-- Determine if the given node N constitutes a finalization master
@@ -2083,9 +2145,28 @@ package Sem_Util is
-- assertion expression of pragma Default_Initial_Condition and if it does,
-- the encapsulated expression is nontrivial.
- function Is_Null_Record_Type (T : Entity_Id) return Boolean;
- -- Determine whether T is declared with a null record definition or a
- -- null component list.
+ function Is_Null_Extension
+ (T : Entity_Id; Ignore_Privacy : Boolean := False) return Boolean;
+ -- Given a tagged type, returns True if argument is a type extension
+ -- that introduces no new components (discriminant or nondiscriminant).
+ -- Ignore_Privacy should be True for use in implementing dynamic semantics.
+
+ function Is_Null_Extension_Of
+ (Descendant, Ancestor : Entity_Id) return Boolean;
+ -- Given two tagged types, the first a descendant of the second,
+ -- returns True if every component of Descendant is inherited
+ -- (directly or indirectly) from Ancestor. Privacy is ignored.
+
+ function Is_Null_Record_Definition (Record_Def : Node_Id) return Boolean;
+ -- Returns True for an N_Record_Definition node that has no user-defined
+ -- components (and no variant part).
+
+ function Is_Null_Record_Type
+ (T : Entity_Id; Ignore_Privacy : Boolean := False) return Boolean;
+ -- Determine whether T is declared with a null record definition, a
+ -- null component list, or as a type derived from a null record type
+ -- (with a null extension if tagged). Returns True for interface types,
+ -- False for discriminated types.
function Is_Object_Image (Prefix : Node_Id) return Boolean;
-- Returns True if an 'Img, 'Image, 'Wide_Image, or 'Wide_Wide_Image
@@ -2103,11 +2184,16 @@ package Sem_Util is
-- conversions and hence variables.
function Is_OK_Volatile_Context
- (Context : Node_Id;
- Obj_Ref : Node_Id) return Boolean;
+ (Context : Node_Id;
+ Obj_Ref : Node_Id;
+ Check_Actuals : Boolean) return Boolean;
-- Determine whether node Context denotes a "non-interfering context" (as
-- defined in SPARK RM 7.1.3(10)) where volatile reference Obj_Ref can
- -- safely reside.
+ -- safely reside. When examining references that might be located within
+ -- actual parameters of a subprogram call that has not been resolved yet,
+ -- Check_Actuals should be False; such references will be assumed to be
+ -- legal. They will need to be checked again after subprogram call has
+ -- been resolved.
function Is_Package_Contract_Annotation (Item : Node_Id) return Boolean;
-- Determine whether aspect specification or pragma Item is one of the
@@ -2375,7 +2461,7 @@ package Sem_Util is
-- Initialize/Adjust/Finalize subprogram does not override the inherited
-- one.
- function Is_Volatile_Full_Access_Object (N : Node_Id) return Boolean;
+ function Is_Volatile_Full_Access_Object_Ref (N : Node_Id) return Boolean;
-- Determine whether arbitrary node N denotes a reference to an object
-- which is Volatile_Full_Access.
@@ -2384,7 +2470,7 @@ package Sem_Util is
-- pragma Volatile_Function. Protected functions are treated as volatile
-- (SPARK RM 7.1.2).
- function Is_Volatile_Object (N : Node_Id) return Boolean;
+ function Is_Volatile_Object_Ref (N : Node_Id) return Boolean;
-- Determine whether arbitrary node N denotes a reference to a volatile
-- object as per RM C.6(8). Note that the test here is for something that
-- is actually declared as volatile, not for an object that gets treated
@@ -2517,8 +2603,7 @@ package Sem_Util is
-- entity E. If no such instance exits, return Empty.
function Needs_Finalization (Typ : Entity_Id) return Boolean;
- -- Determine whether type Typ is controlled and thus requires finalization
- -- actions.
+ -- True if Typ requires finalization actions
function Needs_One_Actual (E : Entity_Id) return Boolean;
-- Returns True if a function has defaults for all but its first formal,
@@ -2826,9 +2911,9 @@ package Sem_Util is
procedure Propagate_Concurrent_Flags
(Typ : Entity_Id;
Comp_Typ : Entity_Id);
- -- Set Has_Task, Has_Protected and Has_Timing_Event on Typ when the flags
- -- are set on Comp_Typ. This follows the definition of these flags which
- -- are set (recursively) on any composite type which has a component marked
+ -- Set Has_Task, Has_Protected, and Has_Timing_Event on Typ when the flags
+ -- are set on Comp_Typ. This follows the definition of these flags, which
+ -- are set (recursively) on any composite type that has a component marked
-- by one of these flags. This procedure can only set flags for Typ, and
-- never clear them. Comp_Typ is the type of a component or a parent.
@@ -2841,14 +2926,14 @@ package Sem_Util is
procedure Propagate_Invariant_Attributes
(Typ : Entity_Id;
From_Typ : Entity_Id);
- -- Inherit all invariant-related attributes form type From_Typ. Typ is the
+ -- Inherit all invariant-related attributes from 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???
+ -- Inherit predicate functions and Has_Predicates flag from type From_Typ.
+ -- Typ is the destination type.
procedure Record_Possible_Part_Of_Reference
(Var_Id : Entity_Id;
@@ -2941,9 +3026,9 @@ package Sem_Util is
-- 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).
+ -- indication is correct. The node N is the construct that 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
@@ -3005,13 +3090,6 @@ package Sem_Util is
-- the same scope. Note that scopes are partially ordered, so Scope_Within
-- (A, B) and Scope_Within (B, A) may both return False.
- procedure Set_Convention (E : Entity_Id; Val : Convention_Id);
- -- Same as Basic_Set_Convention, but with an extra check for access types.
- -- In particular, if E is an access-to-subprogram type, and Val is a
- -- foreign convention, then we set Can_Use_Internal_Rep to False on E.
- -- Also, if the Etype of E is set and is an anonymous access type with
- -- no convention set, this anonymous type inherits the convention of E.
-
procedure Set_Current_Entity (E : Entity_Id);
pragma Inline (Set_Current_Entity);
-- Establish the entity E as the currently visible definition of its
@@ -3187,9 +3265,19 @@ package Sem_Util is
-- returned, i.e. Traverse_More_Func is called and the result is simply
-- discarded.
- function Type_Access_Level (Typ : Entity_Id) return Uint;
+ function Type_Access_Level
+ (Typ : Entity_Id;
+ Allow_Alt_Model : Boolean := True;
+ Assoc_Ent : Entity_Id := Empty) return Uint;
-- Return the accessibility level of Typ
+ -- The Allow_Alt_Model parameter allows the alternative level calculation
+ -- under the restriction No_Dynamic_Accessibility_Checks to be performed.
+
+ -- Assoc_Ent allows for the optional specification of the entity associated
+ -- with Typ. This gets utilized mostly for anonymous access type
+ -- processing, where context matters in interpreting Typ's level.
+
function Type_Without_Stream_Operation
(T : Entity_Id;
Op : TSS_Name_Type := TSS_Null) return Entity_Id;
@@ -3201,6 +3289,15 @@ package Sem_Util is
-- prevents the construction of a composite stream operation. If Op is
-- specified we check only for the given stream operation.
+ function Ultimate_Overlaid_Entity (E : Entity_Id) return Entity_Id;
+ -- If entity E is overlaying some other entity via an Address clause (which
+ -- possibly overlays yet another entity via its own Address clause), then
+ -- return the ultimate overlaid entity. If entity E is not overlaying any
+ -- other entity (or the overlaid entity cannot be determined statically),
+ -- then return Empty.
+ --
+ -- Subsidiary to the analysis of object overlays in SPARK.
+
function Ultimate_Prefix (N : Node_Id) return Node_Id;
-- Obtain the "outermost" prefix of arbitrary node N. Return N if no such
-- prefix exists.
@@ -3258,7 +3355,7 @@ package Sem_Util is
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_Scalars. This view is the type itself
+ -- verification by attribute 'Valid_Scalars. This view is the type itself
-- or its full view while stripping away concurrency, derivations, and
-- privacy.
@@ -3278,10 +3375,6 @@ package Sem_Util is
function Within_Scope (E : Entity_Id; S : Entity_Id) return Boolean;
-- Returns True if entity E is declared within scope S
- function Within_Subprogram_Call (N : Node_Id) return Boolean;
- -- Determine whether arbitrary node N appears in an entry, function, or
- -- procedure call.
-
procedure Wrong_Type (Expr : Node_Id; Expected_Type : Entity_Id);
-- Output error message for incorrectly typed expression. Expr is the node
-- for the incorrectly typed construct (Etype (Expr) is the type found),
@@ -3341,7 +3434,7 @@ package Sem_Util is
-- Returns True iff every value belonging to some interval of
-- Subset also belongs to some interval of Of_Set.
- -- TBD: When we get around to implementing "is statically compatible"
+ -- When we get around to implementing "is statically compatible"
-- correctly for real types with static predicates, we may need
-- an analogous Real_Interval_List type. Most of the language
-- rules that reference "is statically compatible" pertain to
@@ -3366,7 +3459,7 @@ package Sem_Util is
-- (typically a 'Old attribute reference), returns True if
-- - the expression is conditionally evaluated; and
-- - its determining expressions are all known on entry; and
- -- - Ada_Version >= Ada_2020.
+ -- - Ada_Version >= Ada_2022.
-- See RM 6.1.1 for definitions of these terms.
--
-- Also returns True if Expr is of an anonymous access type;
diff --git a/gcc/ada/sem_warn.adb b/gcc/ada/sem_warn.adb
index b5275a8..9e337f9 100644
--- a/gcc/ada/sem_warn.adb
+++ b/gcc/ada/sem_warn.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1999-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1999-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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,31 +23,35 @@
-- --
------------------------------------------------------------------------------
-with Atree; use Atree;
-with Debug; use Debug;
-with Einfo; use Einfo;
-with Errout; use Errout;
-with Exp_Code; use Exp_Code;
-with Lib; use Lib;
-with Lib.Xref; use Lib.Xref;
-with Namet; use Namet;
-with Nlists; use Nlists;
-with Opt; use Opt;
-with Par_SCO; use Par_SCO;
-with Rtsfind; use Rtsfind;
-with Sem; use Sem;
-with Sem_Ch8; use Sem_Ch8;
-with Sem_Aux; use Sem_Aux;
-with Sem_Eval; use Sem_Eval;
-with Sem_Prag; use Sem_Prag;
-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;
-with Tbuild; use Tbuild;
-with Uintp; use Uintp;
+with Atree; use Atree;
+with Debug; use Debug;
+with Einfo; use Einfo;
+with Einfo.Entities; use Einfo.Entities;
+with Einfo.Utils; use Einfo.Utils;
+with Errout; use Errout;
+with Exp_Code; use Exp_Code;
+with Lib; use Lib;
+with Lib.Xref; use Lib.Xref;
+with Namet; use Namet;
+with Nlists; use Nlists;
+with Opt; use Opt;
+with Par_SCO; use Par_SCO;
+with Rtsfind; use Rtsfind;
+with Sem; use Sem;
+with Sem_Ch8; use Sem_Ch8;
+with Sem_Aux; use Sem_Aux;
+with Sem_Eval; use Sem_Eval;
+with Sem_Prag; use Sem_Prag;
+with Sem_Util; use Sem_Util;
+with Sinfo; use Sinfo;
+with Sinfo.Nodes; use Sinfo.Nodes;
+with Sinfo.Utils; use Sinfo.Utils;
+with Sinput; use Sinput;
+with Snames; use Snames;
+with Stand; use Stand;
+with Stringt; use Stringt;
+with Tbuild; use Tbuild;
+with Uintp; use Uintp;
package body Sem_Warn is
@@ -1176,7 +1180,8 @@ package body Sem_Warn is
-- Case of an unassigned variable
-- First gather any Unset_Reference indication for E1. In the
- -- case of a parameter, it is the Spec_Entity that is relevant.
+ -- case of an 'out' parameter, it is the Spec_Entity that is
+ -- relevant.
if Ekind (E1) = E_Out_Parameter
and then Present (Spec_Entity (E1))
@@ -1215,8 +1220,8 @@ package body Sem_Warn is
-- the wanted effect is included in Never_Set_In_Source.
elsif Warn_On_Constant
- and then (Ekind (E1) = E_Variable
- and then Has_Initial_Value (E1))
+ and then Ekind (E1) = E_Variable
+ and then Has_Initial_Value (E1)
and then Never_Set_In_Source_Check_Spec (E1)
and then not Generic_Package_Spec_Entity (E1)
then
@@ -1294,9 +1299,9 @@ package body Sem_Warn is
-- never referenced, since again it seems odd to rely on
-- default initialization to set an out parameter value.
- and then (Is_Access_Type (E1T)
- or else Ekind (E1) = E_Out_Parameter
- or else not Is_Fully_Initialized_Type (E1T))
+ and then (Is_Access_Type (E1T)
+ or else Ekind (E1) = E_Out_Parameter
+ or else not Is_Fully_Initialized_Type (E1T))
then
-- Do not output complaint about never being assigned a
-- value if a pragma Unmodified applies to the variable
@@ -1350,9 +1355,11 @@ package body Sem_Warn is
-- Suppress warning if composite type contains any access
-- component, since the logical effect of modifying a
-- parameter may be achieved by modifying a referenced
- -- object.
+ -- object. This rationale does not apply to private
+ -- types, so we warn in that case.
elsif Is_Composite_Type (E1T)
+ and then not Is_Private_Type (E1T)
and then Has_Access_Values (E1T)
then
null;
@@ -1523,6 +1530,17 @@ package body Sem_Warn is
-- uninitialized component to get a better message.
elsif Nkind (Parent (UR)) = N_Selected_Component then
+ -- Suppress possibly superfluous warning if component
+ -- is known to exist and is partially initialized.
+
+ if not Has_Discriminants (Etype (E1))
+ and then
+ Is_Partially_Initialized_Type
+ (Etype (Parent (UR)), False)
+ then
+ goto Continue;
+ end if;
+
Error_Msg_Node_2 := Selector_Name (Parent (UR));
if not Comes_From_Source (Parent (UR)) then
@@ -2297,7 +2315,7 @@ package body Sem_Warn is
procedure Check_Inner_Package (Pack : Entity_Id) is
E : Entity_Id;
- Un : constant Node_Id := Sinfo.Unit (Cnode);
+ Un : constant Node_Id := Sinfo.Nodes.Unit (Cnode);
function Check_Use_Clause (N : Node_Id) return Traverse_Result;
-- If N is a use_clause for Pack, emit warning
@@ -3015,7 +3033,7 @@ package body Sem_Warn is
-- if we have seen the address of the subprogram being taken, or if the
-- subprogram is used as a generic actual (in the latter cases the
-- context may force use of IN OUT, even if the parameter is not
- -- modifies for this particular case.
+ -- modified for this particular case.
-----------------------
-- No_Warn_On_In_Out --
@@ -3075,7 +3093,7 @@ package body Sem_Warn is
-- Here we generate the warning
else
- -- If -gnatwk is set then output message that we could be IN
+ -- If -gnatwk is set then output message that it could be IN
if not Is_Trivial_Subprogram (Scope (E1)) then
if Warn_On_Constant then
@@ -3651,6 +3669,9 @@ package body Sem_Warn is
---------------------------------
procedure Warn_On_Overlapping_Actuals (Subp : Entity_Id; N : Node_Id) is
+ function Explicitly_By_Reference (Formal_Id : Entity_Id) return Boolean;
+ -- Returns True iff the type of Formal_Id is explicitly by-reference
+
function Refer_Same_Object
(Act1 : Node_Id;
Act2 : Node_Id) return Boolean;
@@ -3662,6 +3683,24 @@ package body Sem_Warn is
-- object_name is known to refer to the same object as the other name
-- (RM 6.4.1(6.11/3))
+ -----------------------------
+ -- Explicitly_By_Reference --
+ -----------------------------
+
+ function Explicitly_By_Reference
+ (Formal_Id : Entity_Id)
+ return Boolean
+ is
+ Typ : constant Entity_Id := Underlying_Type (Etype (Formal_Id));
+ begin
+ if Present (Typ) then
+ return Is_By_Reference_Type (Typ)
+ or else Convention (Typ) = Convention_Ada_Pass_By_Reference;
+ else
+ return False;
+ end if;
+ end Explicitly_By_Reference;
+
-----------------------
-- Refer_Same_Object --
-----------------------
@@ -3678,24 +3717,22 @@ package body Sem_Warn is
-- Local variables
- Act1 : Node_Id;
- Act2 : Node_Id;
- Form1 : Entity_Id;
- Form2 : Entity_Id;
+ Act1 : Node_Id;
+ Act2 : Node_Id;
+ Form1 : Entity_Id;
+ Form2 : Entity_Id;
-- Start of processing for Warn_On_Overlapping_Actuals
begin
+ -- Exclude calls rewritten as enumeration literals
- if Ada_Version < Ada_2012 and then not Warn_On_Overlap then
+ if Nkind (N) not in N_Subprogram_Call | N_Entry_Call_Statement then
return;
- end if;
- -- Exclude calls rewritten as enumeration literals
+ -- Guard against previous errors
- if Nkind (N) not in N_Subprogram_Call
- and then Nkind (N) /= N_Entry_Call_Statement
- then
+ elsif Error_Posted (N) then
return;
end if;
@@ -3726,175 +3763,115 @@ package body Sem_Warn is
Form1 := First_Formal (Subp);
Act1 := First_Actual (N);
while Present (Form1) and then Present (Act1) loop
- 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 Refer_Same_Object (Act1, Act2) then
- if Is_Generic_Type (Etype (Act2)) then
- return;
- end if;
- -- First case : two writable elementary parameters
- -- that overlap.
+ Form2 := Next_Formal (Form1);
+ Act2 := Next_Actual (Act1);
+ while Present (Form2) and then Present (Act2) 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)
+ -- Ignore formals of generic types; they will be examined when
+ -- instantiated.
- -- Second case : two composite parameters that overlap,
- -- one of which is writable.
+ if Is_Generic_Type (Etype (Form1))
+ or else Is_Generic_Type (Etype (Form2))
+ then
+ null;
- 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 Refer_Same_Object (Act1, Act2) then
- -- Third case : an elementary writable parameter that
- -- overlaps a composite one.
+ -- Case 1: two writable elementary parameters that overlap
- or else (Is_Elementary_Type (Etype (Form1))
- and then Ekind (Form1) /= E_In_Parameter
- and then Is_Composite_Type (Etype (Form2)))
+ 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)
- or else (Is_Elementary_Type (Etype (Form2))
- and then Ekind (Form2) /= E_In_Parameter
- and then Is_Composite_Type (Etype (Form1)))
- then
+ -- Case 2: two composite parameters that overlap, one of
+ -- which is writable.
- -- Guard against previous errors
+ 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))
- if Error_Posted (N)
- or else No (Etype (Act1))
- or else No (Etype (Act2))
- then
- null;
+ -- Case 3: an elementary writable parameter that overlaps
+ -- a composite one.
- -- If the actual is a function call in prefix notation,
- -- there is no real overlap.
+ or else (Is_Elementary_Type (Etype (Form1))
+ and then Ekind (Form1) /= E_In_Parameter
+ and then Is_Composite_Type (Etype (Form2)))
- elsif Nkind (Act2) = N_Function_Call then
- null;
-
- -- 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;
-
- -- Under Ada 2012 we only report warnings on overlapping
- -- arrays and record types if switch is set.
-
- elsif Ada_Version >= Ada_2012
- and then not Is_Elementary_Type (Etype (Form1))
- and then not Warn_On_Overlap
- then
- null;
+ or else (Is_Elementary_Type (Etype (Form2))
+ and then Ekind (Form2) /= E_In_Parameter
+ and then Is_Composite_Type (Etype (Form1)))
+ then
- -- Here we may need to issue overlap message
+ -- Guard against previous errors
- else
- Error_Msg_Warn :=
+ if 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 type is explicitly by-reference, then it is not
+ -- covered by the legality rule, which only applies to
+ -- elementary types. Actually, the aliasing is most
+ -- likely intended, so don't emit a warning either.
- Ada_Version < Ada_2012
+ elsif Explicitly_By_Reference (Form1)
+ or else Explicitly_By_Reference (Form2)
+ 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 versions.
- -- This is clarified by AI12-0216.
+ -- We only report warnings on overlapping arrays and record
+ -- types if switch is set.
- or else not
- (Is_Elementary_Type (Etype (Form1))
- and then Is_Elementary_Type (Etype (Form2)))
+ elsif not Warn_On_Overlap
+ and then not (Is_Elementary_Type (Etype (Form1))
+ and then
+ Is_Elementary_Type (Etype (Form2)))
+ then
+ null;
- -- debug flag -gnatd.E changes the error to a
- -- warning even in Ada 2012 mode.
+ -- Here we may need to issue overlap message
- or else Error_To_Warning;
+ else
+ Error_Msg_Warn :=
- if Is_Elementary_Type (Etype (Act1))
- and then Ekind (Form2) = E_In_Parameter
- then
- null; -- No real aliasing
+ -- Overlap checking is an error only in Ada 2012. For
+ -- earlier versions of Ada, this is a warning.
- elsif Is_Elementary_Type (Etype (Act2))
- and then Ekind (Form2) = E_In_Parameter
- then
- null; -- Ditto
+ Ada_Version < Ada_2012
- -- If the call was written in prefix notation, and
- -- thus its prefix before rewriting was a selected
- -- component, count only visible actuals in call.
+ -- Overlap is only illegal since Ada 2012 and only for
+ -- elementary types (passed by copy). For other types
+ -- we always have a warning in all versions. This is
+ -- clarified by AI12-0216.
- 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
- and then
- Is_Entity_Name (Prefix (Name (Original_Node (N))))
- and then
- Entity (Prefix (Name (Original_Node (N)))) =
- Entity (First_Actual (N))
- then
- if Act1 = First_Actual (N) then
- Error_Msg_FE
- ("<I<`IN OUT` prefix overlaps with "
- & "actual for&", Act1, Form2);
+ or else not
+ (Is_Elementary_Type (Etype (Form1))
+ and then Is_Elementary_Type (Etype (Form2)))
- else
- -- For greater clarity, give name of formal
+ -- debug flag -gnatd.E changes the error to a warning
+ -- even in Ada 2012 mode.
- Error_Msg_Node_2 := Form2;
- Error_Msg_FE
- ("<I<writable actual for & overlaps with "
- & "actual for&", Act1, Form2);
- end if;
+ or else Error_To_Warning;
- else
- -- For greater clarity, give name of formal
+ -- For greater clarity, give name of formal
- Error_Msg_Node_2 := Form2;
+ Error_Msg_Node_2 := Form2;
- -- This is one of the messages
+ -- This is one of the messages
- Error_Msg_FE
- ("<I<writable actual for & overlaps with "
- & "actual for&", Act1, Form1);
- end if;
- end if;
+ Error_Msg_FE
+ ("<I<writable actual for & overlaps with actual for &",
+ Act1, Form1);
end if;
-
- return;
end if;
+ end if;
- Next_Formal (Form2);
- Next_Actual (Act2);
- end loop;
- end if;
+ Next_Formal (Form2);
+ Next_Actual (Act2);
+ end loop;
Next_Formal (Form1);
Next_Actual (Act1);
diff --git a/gcc/ada/sem_warn.ads b/gcc/ada/sem_warn.ads
index 5649a16..50a4df2 100644
--- a/gcc/ada/sem_warn.ads
+++ b/gcc/ada/sem_warn.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1999-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1999-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute 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 b8578f5..5af7f1a 100644
--- a/gcc/ada/set_targ.adb
+++ b/gcc/ada/set_targ.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2013-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2013-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -309,7 +309,6 @@ package body Set_Targ is
Write_Str ("pragma Float_Representation (");
case Float_Rep is
- when AAMP => Write_Str ("AAMP");
when IEEE_Binary => Write_Str ("IEEE");
end case;
@@ -532,7 +531,6 @@ package body Set_Targ is
AddC (' ');
case E.FLOAT_REP is
- when AAMP => AddC ('A');
when IEEE_Binary => AddC ('I');
end case;
@@ -795,9 +793,6 @@ package body Set_Targ is
when 'I' =>
E.FLOAT_REP := IEEE_Binary;
- when 'A' =>
- E.FLOAT_REP := AAMP;
-
when others =>
FailN ("bad float rep field for");
end case;
@@ -880,7 +875,7 @@ begin
argv := save_argv;
argc := save_argc;
else
- -- Case of a non gcc compiler, e.g. gnat2why or gnat2scil
+ -- Case of a non-GCC compiler, e.g. gnat2why or gnat2scil
argv := gnat_argv;
argc := gnat_argc;
end if;
diff --git a/gcc/ada/set_targ.ads b/gcc/ada/set_targ.ads
index e25f351..4afd7b0 100644
--- a/gcc/ada/set_targ.ads
+++ b/gcc/ada/set_targ.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2013-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2013-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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 @@
-- of Wide_Character_Type uses twice the size of a C char, instead of the
-- size of wchar_t, since this corresponds to expected Ada usage.
-with Einfo; use Einfo;
with Stand; use Stand;
with Types; use Types;
@@ -144,12 +143,14 @@ package Set_Targ is
--
-- name digs float_rep precision alignment
--
- -- where name is the string name of the type (which can have single
- -- spaces embedded in the name (e.g. long double). The name is followed
- -- by at least two blanks. The following fields are as described above
- -- for a Mode_Entry (where float_rep is I/V/A for IEEE-754-Binary,
- -- Vax_Native, AAMP), fields are separated by at least one blank, and
- -- a LF character immediately follows the alignment field.
+ -- where name is the string name of the type (which can have
+ -- single spaces embedded in the name (e.g. long double). The
+ -- name is followed by at least two blanks. The following fields
+ -- are as described above for a Mode_Entry (where float_rep is
+ -- I for IEEE-754-Binary, which is the only Float_Rep_Kind
+ -- currently supported), fields are separated by at least one
+ -- blank, and a LF character immediately follows the alignment
+ -- field.
--
-- ??? We do not write the size for backward compatibility reasons,
-- which means that target.atp will not be a complete description for
diff --git a/gcc/ada/sfn_scan.adb b/gcc/ada/sfn_scan.adb
index 660d64f..61e8971 100644
--- a/gcc/ada/sfn_scan.adb
+++ b/gcc/ada/sfn_scan.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2000-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2000-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute 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 824033f..b430c49 100644
--- a/gcc/ada/sfn_scan.ads
+++ b/gcc/ada/sfn_scan.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2000-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2000-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute 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 9113a6c..6caff8c 100644
--- a/gcc/ada/sigtramp-armdroid.c
+++ b/gcc/ada/sigtramp-armdroid.c
@@ -6,7 +6,7 @@
* *
* Asm Implementation File *
* *
- * Copyright (C) 2015-2020, Free Software Foundation, Inc. *
+ * Copyright (C) 2015-2021, Free Software Foundation, Inc. *
* *
* GNAT is free software; you can redistribute 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 7715ddb..6e2913d 100644
--- a/gcc/ada/sigtramp-ios.c
+++ b/gcc/ada/sigtramp-ios.c
@@ -6,7 +6,7 @@
* *
* Asm Implementation File *
* *
- * Copyright (C) 2015-2020, Free Software Foundation, Inc. *
+ * Copyright (C) 2015-2021, Free Software Foundation, Inc. *
* *
* GNAT is free software; you can redistribute 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 d26099f..e638beb 100644
--- a/gcc/ada/sigtramp-qnx.c
+++ b/gcc/ada/sigtramp-qnx.c
@@ -6,7 +6,7 @@
* *
* Asm Implementation File *
* *
- * Copyright (C) 2017-2020, Free Software Foundation, Inc. *
+ * Copyright (C) 2017-2021, Free Software Foundation, Inc. *
* *
* GNAT is free software; you can redistribute 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-target.inc b/gcc/ada/sigtramp-vxworks-target.h
index f42c872..8c43451 100644
--- a/gcc/ada/sigtramp-vxworks-target.inc
+++ b/gcc/ada/sigtramp-vxworks-target.h
@@ -6,7 +6,7 @@
* *
* Asm Implementation Include File *
* *
- * Copyright (C) 2011-2018, Free Software Foundation, Inc. *
+ * Copyright (C) 2011-2021, Free Software Foundation, Inc. *
* *
* GNAT is 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,7 +100,7 @@
#define FUNCTION "%function"
#ifdef __aarch64__
-#define REGNO_PC_OFFSET 80 /* aka V16, a scratch register */
+#define REGNO_PC_OFFSET 96 /* DWARF_ALT_FRAME_RETURN_COLUMN */
#else
#define REGNO_PC_OFFSET 15 /* PC_REGNUM */
#endif
@@ -319,9 +319,9 @@ TCR("blr")
#else
#define SIGTRAMP_BODY \
CR("") \
-TCR("0:") \
-TCR("addis 2,12,.TOC.-0@ha") \
-TCR("addi 2,2,.TOC.-0@l") \
+TCR(".LOC_SIGTMP_COM_0:") \
+TCR("addis 2,12,.TOC.-.LOC_SIGTMP_COM_0@ha") \
+TCR("addi 2,2,.TOC.-.LOC_SIGTMP_COM_0@l") \
TCR(".localentry __gnat_sigtramp_common,.-__gnat_sigtramp_common") \
TCR("# Allocate frame and save the non-volatile") \
TCR("# registers we're going to modify") \
@@ -375,7 +375,7 @@ TCR(COMMON_CFI(G_REG_OFFSET(14))) \
TCR(COMMON_CFI(G_REG_OFFSET(15))) \
TCR(COMMON_CFI(G_REG_OFFSET(16))) \
TCR(COMMON_CFI(G_REG_OFFSET(17))) \
-TCR(COMMON_CFI(G_REG_OFFSET(18))) \
+CR("# Leave alone R18, VxWorks reserved\n") \
TCR(COMMON_CFI(G_REG_OFFSET(19))) \
TCR(COMMON_CFI(G_REG_OFFSET(20))) \
TCR(COMMON_CFI(G_REG_OFFSET(21))) \
diff --git a/gcc/ada/sigtramp-vxworks.c b/gcc/ada/sigtramp-vxworks.c
index e0b4503..2455f6e 100644
--- a/gcc/ada/sigtramp-vxworks.c
+++ b/gcc/ada/sigtramp-vxworks.c
@@ -6,7 +6,7 @@
* *
* Asm Implementation File *
* *
- * Copyright (C) 2011-2020, Free Software Foundation, Inc. *
+ * Copyright (C) 2011-2021, Free Software Foundation, Inc. *
* *
* GNAT is free software; you can redistribute it and/or modify it under *
* terms of the GNU General Public License as published by the Free Soft- *
@@ -180,7 +180,7 @@ void __gnat_sigtramp (int signo, void *si, void *sc,
}
/* Include the target specific bits. */
-#include "sigtramp-vxworks-target.inc"
+#include "sigtramp-vxworks-target.h"
/* sigtramp stub for common registers. */
diff --git a/gcc/ada/sigtramp.h b/gcc/ada/sigtramp.h
index 719f9b4..6527e5e 100644
--- a/gcc/ada/sigtramp.h
+++ b/gcc/ada/sigtramp.h
@@ -6,7 +6,7 @@
* *
* C Header File *
* *
- * Copyright (C) 2011-2020, Free Software Foundation, Inc. *
+ * Copyright (C) 2011-2021, Free Software Foundation, Inc. *
* *
* GNAT is free software; you can redistribute 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 f2f9b58..c676d47 100644
--- a/gcc/ada/sinfo-cn.adb
+++ b/gcc/ada/sinfo-cn.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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,27 +30,23 @@
-- general manner, but in some specific cases, the fields of related nodes
-- have been deliberately layed out in a manner that permits such alteration.
-with Atree; use Atree;
-with Snames; use Snames;
+with Atree; use Atree;
+with Snames; use Snames;
+with Sinfo.Nodes; use Sinfo.Nodes;
+with Sinfo.Utils; use Sinfo.Utils;
package body Sinfo.CN is
- use Atree.Unchecked_Access;
- -- This package is one of the few packages which is allowed to make direct
- -- references to tree nodes (since it is in the business of providing a
- -- higher level of tree access which other clients are expected to use and
- -- which implements checks).
-
------------------------------------------------------------
-- Change_Character_Literal_To_Defining_Character_Literal --
------------------------------------------------------------
procedure Change_Character_Literal_To_Defining_Character_Literal
- (N : in out Node_Id)
+ (N : Node_Id)
is
begin
- Set_Nkind (N, N_Defining_Character_Literal);
- N := Extend_Node (N);
+ Reinit_Field_To_Zero (N, F_Char_Literal_Value);
+ Extend_Node (N);
end Change_Character_Literal_To_Defining_Character_Literal;
------------------------------------
@@ -60,19 +56,17 @@ package body Sinfo.CN is
procedure Change_Conversion_To_Unchecked (N : Node_Id) is
begin
Set_Do_Overflow_Check (N, False);
- Set_Do_Tag_Check (N, False);
Set_Do_Length_Check (N, False);
- Set_Nkind (N, N_Unchecked_Type_Conversion);
+ Mutate_Nkind (N, N_Unchecked_Type_Conversion);
end Change_Conversion_To_Unchecked;
----------------------------------------------
-- Change_Identifier_To_Defining_Identifier --
----------------------------------------------
- procedure Change_Identifier_To_Defining_Identifier (N : in out Node_Id) is
+ procedure Change_Identifier_To_Defining_Identifier (N : Node_Id) is
begin
- Set_Nkind (N, N_Defining_Identifier);
- N := Extend_Node (N);
+ Extend_Node (N);
end Change_Identifier_To_Defining_Identifier;
---------------------------------------------
@@ -132,12 +126,11 @@ package body Sinfo.CN is
--------------------------------------------------------
procedure Change_Operator_Symbol_To_Defining_Operator_Symbol
- (N : in out Node_Id)
+ (N : Node_Id)
is
begin
- Set_Nkind (N, N_Defining_Operator_Symbol);
- Set_Node2 (N, Empty); -- Clear unused Str2 field
- N := Extend_Node (N);
+ Reinit_Field_To_Zero (N, F_Strval);
+ Extend_Node (N);
end Change_Operator_Symbol_To_Defining_Operator_Symbol;
----------------------------------------------
@@ -146,8 +139,9 @@ package body Sinfo.CN is
procedure Change_Operator_Symbol_To_String_Literal (N : Node_Id) is
begin
- Set_Nkind (N, N_String_Literal);
- Set_Node1 (N, Empty); -- clear Name1 field
+ Reinit_Field_To_Zero (N, F_Chars);
+ Set_Entity (N, Empty);
+ Mutate_Nkind (N, N_String_Literal);
end Change_Operator_Symbol_To_String_Literal;
------------------------------------------------
@@ -156,7 +150,7 @@ package body Sinfo.CN is
procedure Change_Selected_Component_To_Expanded_Name (N : Node_Id) is
begin
- Set_Nkind (N, N_Expanded_Name);
+ Mutate_Nkind (N, N_Expanded_Name);
Set_Chars (N, Chars (Selector_Name (N)));
end Change_Selected_Component_To_Expanded_Name;
diff --git a/gcc/ada/sinfo-cn.ads b/gcc/ada/sinfo-cn.ads
index 837a753..bf3231b 100644
--- a/gcc/ada/sinfo-cn.ads
+++ b/gcc/ada/sinfo-cn.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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,20 +32,19 @@
package Sinfo.CN is
- procedure Change_Identifier_To_Defining_Identifier (N : in out Node_Id);
+ procedure Change_Identifier_To_Defining_Identifier (N : Node_Id);
-- N must refer to a node of type N_Identifier. This node is modified to
-- be of type N_Defining_Identifier. The scanner always returns identifiers
-- as N_Identifier. The parser then uses this routine to change the node
-- to be a defining identifier where the context demands it. This routine
- -- also allocates the necessary extension node. Note that this procedure
- -- may (but is not required to) change the Id of the node in question.
+ -- also allocates the necessary extension node.
procedure Change_Character_Literal_To_Defining_Character_Literal
- (N : in out Node_Id);
+ (N : Node_Id);
-- Similar processing for a character literal
procedure Change_Operator_Symbol_To_Defining_Operator_Symbol
- (N : in out Node_Id);
+ (N : Node_Id);
-- Similar processing for an operator symbol
procedure Change_Conversion_To_Unchecked (N : Node_Id);
diff --git a/gcc/ada/sinfo-utils.adb b/gcc/ada/sinfo-utils.adb
new file mode 100644
index 0000000..7f9bb89
--- /dev/null
+++ b/gcc/ada/sinfo-utils.adb
@@ -0,0 +1,349 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S I N F O . U T I L S --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 2020-2021, Free Software Foundation, Inc. --
+-- --
+-- GNAT is 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;
+with Debug; use Debug;
+with Output; use Output;
+with Seinfo;
+with Sinput; use Sinput;
+
+package body Sinfo.Utils is
+
+ ---------------
+ -- Debugging --
+ ---------------
+
+ -- Suppose you find that node 12345 is messed up. You might want to find
+ -- the code that created that node. There are two ways to do this:
+
+ -- One way is to set a conditional breakpoint on New_Node_Debugging_Output
+ -- (nickname "nnd"):
+ -- break nnd if n = 12345
+ -- and run gnat1 again from the beginning.
+
+ -- The other way is to set a breakpoint near the beginning (e.g. on
+ -- gnat1drv), and run. Then set Watch_Node (nickname "ww") to 12345 in gdb:
+ -- ww := 12345
+ -- and set a breakpoint on New_Node_Breakpoint (nickname "nn"). Continue.
+
+ -- Either way, gnat1 will stop when node 12345 is created, or certain other
+ -- interesting operations are performed, such as Rewrite. To see exactly
+ -- which operations, search for "pragma Debug" below.
+
+ -- The second method is much faster if the amount of Ada code being
+ -- compiled is large.
+
+ ww : Node_Id'Base := Node_Id'First - 1;
+ pragma Export (Ada, ww);
+ Watch_Node : Node_Id'Base renames ww;
+ -- Node to "watch"; that is, whenever a node is created, we check if it
+ -- is equal to Watch_Node, and if so, call New_Node_Breakpoint. You have
+ -- presumably set a breakpoint on New_Node_Breakpoint. Note that the
+ -- initial value of Node_Id'First - 1 ensures that by default, no node
+ -- will be equal to Watch_Node.
+
+ procedure nn;
+ pragma Export (Ada, nn);
+ procedure New_Node_Breakpoint renames nn;
+ -- This doesn't do anything interesting; it's just for setting breakpoint
+ -- on as explained above.
+
+ procedure nnd (N : Node_Id);
+ pragma Export (Ada, nnd);
+ -- For debugging. If debugging is turned on, New_Node and New_Entity call
+ -- this. If debug flag N is turned on, this prints out the new node.
+ --
+ -- If Node = Watch_Node, this prints out the new node and calls
+ -- New_Node_Breakpoint. Otherwise, does nothing.
+
+ procedure Node_Debug_Output (Op : String; N : Node_Id);
+ -- Called by nnd; writes Op followed by information about N
+
+ -------------------------
+ -- New_Node_Breakpoint --
+ -------------------------
+
+ procedure nn is
+ begin
+ Write_Str ("Watched node ");
+ Write_Int (Int (Watch_Node));
+ Write_Eol;
+ end nn;
+
+ -------------------------------
+ -- New_Node_Debugging_Output --
+ -------------------------------
+
+ procedure nnd (N : Node_Id) is
+ Node_Is_Watched : constant Boolean := N = Watch_Node;
+
+ begin
+ if Debug_Flag_N or else Node_Is_Watched then
+ Node_Debug_Output ("Node", N);
+
+ if Node_Is_Watched then
+ New_Node_Breakpoint;
+ end if;
+ end if;
+ end nnd;
+
+ procedure New_Node_Debugging_Output (N : Node_Id) is
+ begin
+ pragma Debug (nnd (N));
+ end New_Node_Debugging_Output;
+
+ -----------------------
+ -- Node_Debug_Output --
+ -----------------------
+
+ procedure Node_Debug_Output (Op : String; N : Node_Id) is
+ begin
+ Write_Str (Op);
+
+ if Nkind (N) in N_Entity then
+ Write_Str (" entity");
+ else
+ Write_Str (" node");
+ end if;
+
+ Write_Str (" Id = ");
+ Write_Int (Int (N));
+ Write_Str (" ");
+ Write_Location (Sloc (N));
+ Write_Str (" ");
+ Write_Str (Node_Kind'Image (Nkind (N)));
+ Write_Eol;
+ end Node_Debug_Output;
+
+ -------------------------------
+ -- Parent-related operations --
+ -------------------------------
+
+ procedure Copy_Parent (To, From : Node_Or_Entity_Id) is
+ begin
+ if Atree.Present (To) and Atree.Present (From) then
+ Atree.Set_Parent (To, Atree.Parent (From));
+ else
+ pragma Assert
+ (if Atree.Present (To) then Atree.No (Atree.Parent (To)));
+ end if;
+ end Copy_Parent;
+
+ function Parent_Kind (N : Node_Id) return Node_Kind is
+ begin
+ if Atree.No (N) then
+ return N_Empty;
+ else
+ return Nkind (Atree.Parent (N));
+ end if;
+ end Parent_Kind;
+
+ -------------------------
+ -- Iterator Procedures --
+ -------------------------
+
+ procedure Next_Entity (N : in out Node_Id) is
+ begin
+ N := Next_Entity (N);
+ end Next_Entity;
+
+ procedure Next_Named_Actual (N : in out Node_Id) is
+ begin
+ N := Next_Named_Actual (N);
+ end Next_Named_Actual;
+
+ procedure Next_Rep_Item (N : in out Node_Id) is
+ begin
+ N := Next_Rep_Item (N);
+ end Next_Rep_Item;
+
+ procedure Next_Use_Clause (N : in out Node_Id) is
+ begin
+ N := Next_Use_Clause (N);
+ end Next_Use_Clause;
+
+ ------------------
+ -- End_Location --
+ ------------------
+
+ function End_Location (N : Node_Id) return Source_Ptr is
+ L : constant Uint := End_Span (N);
+ begin
+ if L = No_Uint then
+ return No_Location;
+ else
+ return Source_Ptr (Int (Sloc (N)) + UI_To_Int (L));
+ end if;
+ end End_Location;
+
+ --------------------
+ -- Get_Pragma_Arg --
+ --------------------
+
+ function Get_Pragma_Arg (Arg : Node_Id) return Node_Id is
+ begin
+ if Nkind (Arg) = N_Pragma_Argument_Association then
+ return Expression (Arg);
+ else
+ return Arg;
+ end if;
+ end Get_Pragma_Arg;
+
+ ----------------------
+ -- Set_End_Location --
+ ----------------------
+
+ procedure Set_End_Location (N : Node_Id; S : Source_Ptr) is
+ begin
+ Set_End_Span (N,
+ UI_From_Int (Int (S) - Int (Sloc (N))));
+ end Set_End_Location;
+
+ --------------------------
+ -- Pragma_Name_Unmapped --
+ --------------------------
+
+ function Pragma_Name_Unmapped (N : Node_Id) return Name_Id is
+ begin
+ return Chars (Pragma_Identifier (N));
+ end Pragma_Name_Unmapped;
+
+ ------------------------------------
+ -- Helpers for Walk_Sinfo_Fields* --
+ ------------------------------------
+
+ function Get_Node_Field_Union is new
+ Atree.Atree_Private_Part.Get_32_Bit_Field (Union_Id) with Inline;
+ procedure Set_Node_Field_Union is new
+ Atree.Atree_Private_Part.Set_32_Bit_Field (Union_Id) with Inline;
+
+ use Seinfo;
+
+ function Is_In_Union_Id (F_Kind : Field_Kind) return Boolean is
+ (F_Kind in Node_Id_Field
+ | List_Id_Field
+ | Elist_Id_Field
+ | Name_Id_Field
+ | String_Id_Field
+ | Uint_Field
+ | Ureal_Field
+ | Union_Id_Field);
+ -- True if the field type is one that can be converted to Types.Union_Id
+
+ -----------------------
+ -- Walk_Sinfo_Fields --
+ -----------------------
+
+ procedure Walk_Sinfo_Fields (N : Node_Id) is
+ Fields : Node_Field_Array renames
+ Node_Field_Table (Nkind (N)).all;
+
+ begin
+ for J in Fields'Range loop
+ if Fields (J) /= F_Link then -- Don't walk Parent!
+ declare
+ Desc : Field_Descriptor renames
+ Node_Field_Descriptors (Fields (J));
+ begin
+ if Is_In_Union_Id (Desc.Kind) then
+ Action (Get_Node_Field_Union (N, Desc.Offset));
+ end if;
+ end;
+ end if;
+ end loop;
+ end Walk_Sinfo_Fields;
+
+ --------------------------------
+ -- Walk_Sinfo_Fields_Pairwise --
+ --------------------------------
+
+ procedure Walk_Sinfo_Fields_Pairwise (N1, N2 : Node_Id) is
+ pragma Assert (Nkind (N1) = Nkind (N2));
+
+ Fields : Node_Field_Array renames
+ Node_Field_Table (Nkind (N1)).all;
+
+ begin
+ for J in Fields'Range loop
+ if Fields (J) /= F_Link then -- Don't walk Parent!
+ declare
+ Desc : Field_Descriptor renames
+ Node_Field_Descriptors (Fields (J));
+ begin
+ if Is_In_Union_Id (Desc.Kind) then
+ Set_Node_Field_Union
+ (N1, Desc.Offset,
+ Transform (Get_Node_Field_Union (N2, Desc.Offset)));
+ end if;
+ end;
+ end if;
+ end loop;
+ end Walk_Sinfo_Fields_Pairwise;
+
+ ---------------------
+ -- Map_Pragma_Name --
+ ---------------------
+
+ -- We don't want to introduce a dependence on some hash table package or
+ -- similar, so we use a simple array of Key => Value pairs, and do a linear
+ -- search. Linear search is plenty efficient, given that we don't expect
+ -- more than a couple of entries in the mapping.
+
+ type Name_Pair is record
+ Key : Name_Id;
+ Value : Name_Id;
+ end record;
+
+ type Pragma_Map_Index is range 1 .. 100;
+ Pragma_Map : array (Pragma_Map_Index) of Name_Pair;
+ Last_Pair : Pragma_Map_Index'Base range 0 .. Pragma_Map_Index'Last := 0;
+
+ procedure Map_Pragma_Name (From, To : Name_Id) is
+ begin
+ if Last_Pair = Pragma_Map'Last then
+ raise Too_Many_Pragma_Mappings;
+ end if;
+
+ Last_Pair := Last_Pair + 1;
+ Pragma_Map (Last_Pair) := (Key => From, Value => To);
+ end Map_Pragma_Name;
+
+ -----------------
+ -- Pragma_Name --
+ -----------------
+
+ function Pragma_Name (N : Node_Id) return Name_Id is
+ Result : constant Name_Id := Pragma_Name_Unmapped (N);
+ begin
+ for J in Pragma_Map'First .. Last_Pair loop
+ if Result = Pragma_Map (J).Key then
+ return Pragma_Map (J).Value;
+ end if;
+ end loop;
+
+ return Result;
+ end Pragma_Name;
+
+end Sinfo.Utils;
diff --git a/gcc/ada/sinfo-utils.ads b/gcc/ada/sinfo-utils.ads
new file mode 100644
index 0000000..2023e67
--- /dev/null
+++ b/gcc/ada/sinfo-utils.ads
@@ -0,0 +1,162 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S I N F O . U T I L S --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 2020-2021, Free Software Foundation, Inc. --
+-- --
+-- GNAT is 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 Sinfo.Nodes; use Sinfo.Nodes;
+
+package Sinfo.Utils is
+
+ -------------------------------
+ -- Parent-related operations --
+ -------------------------------
+
+ procedure Copy_Parent (To, From : Node_Or_Entity_Id);
+ -- Does Set_Parent (To, Parent (From)), except that if To or From are
+ -- empty, does nothing. If From is empty but To is not, then Parent (To)
+ -- should already be Empty.
+
+ function Parent_Kind (N : Node_Id) return Node_Kind;
+ -- Same as Nkind (Parent (N)), except if N is Empty, return N_Empty
+
+ -------------------------
+ -- Iterator Procedures --
+ -------------------------
+
+ -- The call to Next_xxx (N) is equivalent to N := Next_xxx (N)
+
+ procedure Next_Entity (N : in out Node_Id);
+ procedure Next_Named_Actual (N : in out Node_Id);
+ procedure Next_Rep_Item (N : in out Node_Id);
+ procedure Next_Use_Clause (N : in out Node_Id);
+
+ -------------------------------------------
+ -- Miscellaneous Tree Access Subprograms --
+ -------------------------------------------
+
+ function End_Location (N : Node_Id) return Source_Ptr;
+ -- N is an N_If_Statement or N_Case_Statement node, and this function
+ -- returns the location of the IF token in the END IF sequence by
+ -- translating the value of the End_Span field.
+
+ -- WARNING: There is a matching C declaration of this subprogram in fe.h
+
+ procedure Set_End_Location (N : Node_Id; S : Source_Ptr);
+ -- N is an N_If_Statement or N_Case_Statement node. This procedure sets
+ -- the End_Span field to correspond to the given value S. In other words,
+ -- End_Span is set to the difference between S and Sloc (N), the starting
+ -- location.
+
+ function Get_Pragma_Arg (Arg : Node_Id) return Node_Id;
+ -- Given an argument to a pragma Arg, this function returns the expression
+ -- for the argument. This is Arg itself, or, in the case where Arg is a
+ -- pragma argument association node, the expression from this node.
+
+ -----------------------
+ -- Utility Functions --
+ -----------------------
+
+ procedure Map_Pragma_Name (From, To : Name_Id);
+ -- Used in the implementation of pragma Rename_Pragma. Maps pragma name
+ -- From to pragma name To, so From can be used as a synonym for To.
+
+ Too_Many_Pragma_Mappings : exception;
+ -- Raised if Map_Pragma_Name is called too many times. We expect that few
+ -- programs will use it at all, and those that do will use it approximately
+ -- once or twice.
+
+ function Pragma_Name (N : Node_Id) return Name_Id;
+ -- Obtain the name of pragma N from the Chars field of its identifier. If
+ -- the pragma has been renamed using Rename_Pragma, this routine returns
+ -- the name of the renaming.
+
+ function Pragma_Name_Unmapped (N : Node_Id) return Name_Id;
+ -- Obtain the name of pragma N from the Chars field of its identifier. This
+ -- form of name extraction does not take into account renamings performed
+ -- by Rename_Pragma.
+
+ generic
+ with procedure Action (U : Union_Id);
+ procedure Walk_Sinfo_Fields (N : Node_Id);
+ -- Walk the Sinfo fields of N, for all field types that Union_Id includes,
+ -- and call Action on each one. However, skip the Link field, which is the
+ -- Parent, and would cause us to wander off into the weeds.
+
+ generic
+ with function Transform (U : Union_Id) return Union_Id;
+ procedure Walk_Sinfo_Fields_Pairwise (N1, N2 : Node_Id);
+ -- Walks the Sinfo fields of N1 and N2 pairwise, calls Tranform on each N2
+ -- field, copying the resut into the corresponding field of N1. The Nkinds
+ -- must match. Link is skipped.
+
+ -------------------------------------------
+ -- Aliases for Entity_Or_Associated_Node --
+ -------------------------------------------
+
+ -- Historically, the Entity, Associated_Node, and Entity_Or_Associated_Node
+ -- fields shared the same slot. A further complication is that there is an
+ -- N_Has_Entity that does not include all node types that have the Entity
+ -- field. N_Inclusive_Has_Entity are the node types that have the Entity
+ -- field.
+
+ subtype N_Inclusive_Has_Entity is Node_Id with Predicate =>
+ N_Inclusive_Has_Entity in
+ N_Has_Entity_Id
+ | N_Attribute_Definition_Clause_Id
+ | N_Aspect_Specification_Id
+ | N_Freeze_Entity_Id
+ | N_Freeze_Generic_Entity_Id;
+
+ subtype N_Has_Associated_Node is Node_Id with Predicate =>
+ N_Has_Associated_Node in
+ N_Has_Entity_Id
+ | N_Aggregate_Id
+ | N_Extension_Aggregate_Id
+ | N_Selected_Component_Id
+ | N_Use_Package_Clause_Id;
+
+ function Associated_Node
+ (N : N_Has_Associated_Node) return Node_Id
+ renames Entity_Or_Associated_Node;
+
+ function Entity
+ (N : N_Inclusive_Has_Entity) return Node_Id
+ renames Entity_Or_Associated_Node;
+
+ procedure Set_Associated_Node
+ (N : N_Has_Associated_Node; Val : Node_Id)
+ renames Set_Entity_Or_Associated_Node;
+
+ procedure Set_Entity
+ (N : N_Inclusive_Has_Entity; Val : Node_Id)
+ renames Set_Entity_Or_Associated_Node;
+
+ ---------------
+ -- Debugging --
+ ---------------
+
+ procedure New_Node_Debugging_Output (N : Node_Id);
+ pragma Inline (New_Node_Debugging_Output);
+ -- See package body for documentation
+
+end Sinfo.Utils;
diff --git a/gcc/ada/sinfo.adb b/gcc/ada/sinfo.adb
index 2d0a957..8c5c32a 100644
--- a/gcc/ada/sinfo.adb
+++ b/gcc/ada/sinfo.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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,7166 +23,4 @@
-- --
------------------------------------------------------------------------------
-with Atree; use Atree;
-
-package body Sinfo is
-
- use Atree.Unchecked_Access;
- -- This package is one of the few packages which is allowed to make direct
- -- references to tree nodes (since it is in the business of providing a
- -- higher level of tree access which other clients are expected to use and
- -- which implements checks).
-
- use Atree_Private_Part;
- -- The only reason that we ask for direct access to the private part of
- -- the tree package is so that we can directly reference the Nkind field
- -- of nodes table entries. We do this since it helps the efficiency of
- -- the Sinfo debugging checks considerably (note that when we are checking
- -- Nkind values, we don't need to check for a valid node reference, because
- -- we will check that anyway when we reference the field).
-
- NT : Nodes.Table_Ptr renames Nodes.Table;
- -- A short hand abbreviation, useful for the debugging checks
-
- ----------------------------
- -- Field Access Functions --
- ----------------------------
-
- -- Note: The use of Assert (False or else ...) is just a device to allow
- -- uniform format of the conditions following this. Note that csinfo
- -- expects this uniform format.
-
- function Abort_Present
- (N : Node_Id) return Boolean is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Requeue_Statement);
- return Flag15 (N);
- end Abort_Present;
-
- function Abortable_Part
- (N : Node_Id) return Node_Id is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Asynchronous_Select);
- return Node2 (N);
- end Abortable_Part;
-
- function Abstract_Present
- (N : Node_Id) return Boolean is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Derived_Type_Definition
- or else NT (N).Nkind = N_Formal_Derived_Type_Definition
- or else NT (N).Nkind = N_Formal_Private_Type_Definition
- or else NT (N).Nkind = N_Private_Extension_Declaration
- or else NT (N).Nkind = N_Private_Type_Declaration
- or else NT (N).Nkind = N_Record_Definition);
- return Flag4 (N);
- end Abstract_Present;
-
- function Accept_Handler_Records
- (N : Node_Id) return List_Id is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Accept_Alternative);
- return List5 (N);
- end Accept_Handler_Records;
-
- function Accept_Statement
- (N : Node_Id) return Node_Id is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Accept_Alternative);
- return Node2 (N);
- end Accept_Statement;
-
- function Access_Definition
- (N : Node_Id) return Node_Id is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Component_Definition
- or else NT (N).Nkind = N_Formal_Object_Declaration
- or else NT (N).Nkind = N_Object_Renaming_Declaration);
- return Node3 (N);
- end Access_Definition;
-
- function Access_To_Subprogram_Definition
- (N : Node_Id) return Node_Id is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Access_Definition);
- return Node3 (N);
- end Access_To_Subprogram_Definition;
-
- function Access_Types_To_Process
- (N : Node_Id) return Elist_Id is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Freeze_Entity);
- return Elist2 (N);
- end Access_Types_To_Process;
-
- function Actions
- (N : Node_Id) return List_Id is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_And_Then
- or else NT (N).Nkind = N_Case_Expression_Alternative
- or else NT (N).Nkind = N_Compilation_Unit_Aux
- or else NT (N).Nkind = N_Compound_Statement
- or else NT (N).Nkind = N_Expression_With_Actions
- or else NT (N).Nkind = N_Freeze_Entity
- or else NT (N).Nkind = N_Or_Else);
- return List1 (N);
- end Actions;
-
- function Activation_Chain_Entity
- (N : Node_Id) return Node_Id is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Block_Statement
- or else NT (N).Nkind = N_Entry_Body
- or else NT (N).Nkind = N_Generic_Package_Declaration
- or else NT (N).Nkind = N_Package_Declaration
- or else NT (N).Nkind = N_Subprogram_Body
- or else NT (N).Nkind = N_Task_Body);
- return Node3 (N);
- end Activation_Chain_Entity;
-
- function Acts_As_Spec
- (N : Node_Id) return Boolean is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Compilation_Unit
- or else NT (N).Nkind = N_Subprogram_Body);
- return Flag4 (N);
- end Acts_As_Spec;
-
- function Actual_Designated_Subtype
- (N : Node_Id) return Node_Id is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Explicit_Dereference
- or else NT (N).Nkind = N_Free_Statement);
- return Node4 (N);
- end Actual_Designated_Subtype;
-
- function Address_Warning_Posted
- (N : Node_Id) return Boolean is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Attribute_Definition_Clause);
- return Flag18 (N);
- end Address_Warning_Posted;
-
- function Aggregate_Bounds
- (N : Node_Id) return Node_Id is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Aggregate);
- return Node3 (N);
- end Aggregate_Bounds;
-
- function Aliased_Present
- (N : Node_Id) return Boolean is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Component_Definition
- or else NT (N).Nkind = N_Object_Declaration
- or else NT (N).Nkind = N_Parameter_Specification);
- return Flag4 (N);
- end Aliased_Present;
-
- function Alloc_For_BIP_Return
- (N : Node_Id) return Boolean is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Allocator);
- return Flag1 (N);
- end Alloc_For_BIP_Return;
-
- function All_Others
- (N : Node_Id) return Boolean is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Others_Choice);
- return Flag11 (N);
- end All_Others;
-
- function All_Present
- (N : Node_Id) return Boolean is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Access_Definition
- or else NT (N).Nkind = N_Access_To_Object_Definition
- or else NT (N).Nkind = N_Quantified_Expression
- or else NT (N).Nkind = N_Use_Type_Clause);
- return Flag15 (N);
- end All_Present;
-
- function Alternatives
- (N : Node_Id) return List_Id is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Case_Expression
- or else NT (N).Nkind = N_Case_Statement
- or else NT (N).Nkind = N_In
- or else NT (N).Nkind = N_Not_In);
- return List4 (N);
- end Alternatives;
-
- function Ancestor_Part
- (N : Node_Id) return Node_Id is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Extension_Aggregate);
- return Node3 (N);
- end Ancestor_Part;
-
- function Atomic_Sync_Required
- (N : Node_Id) return Boolean is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Expanded_Name
- or else NT (N).Nkind = N_Explicit_Dereference
- or else NT (N).Nkind = N_Identifier
- or else NT (N).Nkind = N_Indexed_Component
- or else NT (N).Nkind = N_Selected_Component);
- return Flag14 (N);
- end Atomic_Sync_Required;
-
- function Array_Aggregate
- (N : Node_Id) return Node_Id is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Enumeration_Representation_Clause);
- return Node3 (N);
- end Array_Aggregate;
-
- function Aspect_On_Partial_View
- (N : Node_Id) return Boolean is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Aspect_Specification);
- return Flag18 (N);
- end Aspect_On_Partial_View;
-
- function Aspect_Rep_Item
- (N : Node_Id) return Node_Id is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Aspect_Specification);
- return Node2 (N);
- end Aspect_Rep_Item;
-
- function Assignment_OK
- (N : Node_Id) return Boolean is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Object_Declaration
- or else NT (N).Nkind in N_Subexpr);
- return Flag15 (N);
- end Assignment_OK;
-
- function Associated_Node
- (N : Node_Id) return Node_Id is
- begin
- pragma Assert (False
- or else NT (N).Nkind in N_Has_Entity
- or else NT (N).Nkind = N_Aggregate
- or else NT (N).Nkind = N_Extension_Aggregate
- or else NT (N).Nkind = N_Selected_Component
- or else NT (N).Nkind = N_Use_Package_Clause);
- return Node4 (N);
- end Associated_Node;
-
- function At_End_Proc
- (N : Node_Id) return Node_Id is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Handled_Sequence_Of_Statements);
- return Node1 (N);
- end At_End_Proc;
-
- function Attribute_Name
- (N : Node_Id) return Name_Id is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Attribute_Reference);
- return Name2 (N);
- end Attribute_Name;
-
- function Aux_Decls_Node
- (N : Node_Id) return Node_Id is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Compilation_Unit);
- return Node5 (N);
- end Aux_Decls_Node;
-
- function Backwards_OK
- (N : Node_Id) return Boolean is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Assignment_Statement);
- return Flag6 (N);
- end Backwards_OK;
-
- function Bad_Is_Detected
- (N : Node_Id) return Boolean is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Subprogram_Body);
- return Flag15 (N);
- end Bad_Is_Detected;
-
- function Body_Required
- (N : Node_Id) return Boolean is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Compilation_Unit);
- return Flag13 (N);
- end Body_Required;
-
- function Body_To_Inline
- (N : Node_Id) return Node_Id is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Subprogram_Declaration);
- return Node3 (N);
- end Body_To_Inline;
-
- function Box_Present
- (N : Node_Id) return Boolean is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Component_Association
- or else NT (N).Nkind = N_Formal_Abstract_Subprogram_Declaration
- or else NT (N).Nkind = N_Formal_Concrete_Subprogram_Declaration
- or else NT (N).Nkind = N_Formal_Package_Declaration
- or else NT (N).Nkind = N_Generic_Association
- or else NT (N).Nkind = N_Iterated_Component_Association
- or else NT (N).Nkind = N_Iterated_Element_Association);
- return Flag15 (N);
- end Box_Present;
-
- function By_Ref
- (N : Node_Id) return Boolean is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Extended_Return_Statement
- or else NT (N).Nkind = N_Simple_Return_Statement);
- return Flag5 (N);
- end By_Ref;
-
- function Char_Literal_Value
- (N : Node_Id) return Uint is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Character_Literal);
- return Uint2 (N);
- end Char_Literal_Value;
-
- function Chars
- (N : Node_Id) return Name_Id is
- begin
- pragma Assert (False
- or else NT (N).Nkind in N_Has_Chars);
- return Name1 (N);
- end Chars;
-
- function Check_Address_Alignment
- (N : Node_Id) return Boolean is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Attribute_Definition_Clause);
- return Flag11 (N);
- end Check_Address_Alignment;
-
- function Choice_Parameter
- (N : Node_Id) return Node_Id is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Exception_Handler);
- return Node2 (N);
- end Choice_Parameter;
-
- function Choices
- (N : Node_Id) return List_Id is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Component_Association);
- return List1 (N);
- end Choices;
-
- function Class_Present
- (N : Node_Id) return Boolean is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Aspect_Specification
- or else NT (N).Nkind = N_Pragma);
- return Flag6 (N);
- end Class_Present;
-
- function Classifications
- (N : Node_Id) return Node_Id is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Contract);
- return Node3 (N);
- end Classifications;
-
- function Cleanup_Actions
- (N : Node_Id) return List_Id is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Block_Statement);
- return List5 (N);
- end Cleanup_Actions;
-
- function Comes_From_Extended_Return_Statement
- (N : Node_Id) return Boolean is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Simple_Return_Statement);
- return Flag18 (N);
- end Comes_From_Extended_Return_Statement;
-
- function Compile_Time_Known_Aggregate
- (N : Node_Id) return Boolean is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Aggregate);
- return Flag18 (N);
- end Compile_Time_Known_Aggregate;
-
- function Component_Associations
- (N : Node_Id) return List_Id is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Aggregate
- or else NT (N).Nkind = N_Delta_Aggregate
- or else NT (N).Nkind = N_Extension_Aggregate);
- return List2 (N);
- end Component_Associations;
-
- function Component_Clauses
- (N : Node_Id) return List_Id is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Record_Representation_Clause);
- return List3 (N);
- end Component_Clauses;
-
- function Component_Definition
- (N : Node_Id) return Node_Id is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Component_Declaration
- or else NT (N).Nkind = N_Constrained_Array_Definition
- or else NT (N).Nkind = N_Unconstrained_Array_Definition);
- return Node4 (N);
- end Component_Definition;
-
- function Component_Items
- (N : Node_Id) return List_Id is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Component_List);
- return List3 (N);
- end Component_Items;
-
- function Component_List
- (N : Node_Id) return Node_Id is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Record_Definition
- or else NT (N).Nkind = N_Variant);
- return Node1 (N);
- end Component_List;
-
- function Component_Name
- (N : Node_Id) return Node_Id is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Component_Clause);
- return Node1 (N);
- end Component_Name;
-
- function Componentwise_Assignment
- (N : Node_Id) return Boolean is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Assignment_Statement);
- return Flag14 (N);
- end Componentwise_Assignment;
-
- function Condition
- (N : Node_Id) return Node_Id is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Accept_Alternative
- or else NT (N).Nkind = N_Delay_Alternative
- or else NT (N).Nkind = N_Elsif_Part
- or else NT (N).Nkind = N_Entry_Body_Formal_Part
- or else NT (N).Nkind = N_Exit_Statement
- or else NT (N).Nkind = N_If_Statement
- or else NT (N).Nkind = N_Iteration_Scheme
- or else NT (N).Nkind = N_Quantified_Expression
- or else NT (N).Nkind = N_Raise_Constraint_Error
- or else NT (N).Nkind = N_Raise_Program_Error
- or else NT (N).Nkind = N_Raise_Storage_Error
- or else NT (N).Nkind = N_Terminate_Alternative);
- return Node1 (N);
- end Condition;
-
- function Condition_Actions
- (N : Node_Id) return List_Id is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Elsif_Part
- or else NT (N).Nkind = N_Iteration_Scheme);
- return List3 (N);
- end Condition_Actions;
-
- function Config_Pragmas
- (N : Node_Id) return List_Id is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Compilation_Unit_Aux);
- return List4 (N);
- end Config_Pragmas;
-
- function Constant_Present
- (N : Node_Id) return Boolean is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Access_Definition
- or else NT (N).Nkind = N_Access_To_Object_Definition
- or else NT (N).Nkind = N_Object_Declaration);
- return Flag17 (N);
- end Constant_Present;
-
- function Constraint
- (N : Node_Id) return Node_Id is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Subtype_Indication);
- return Node3 (N);
- end Constraint;
-
- function Constraints
- (N : Node_Id) return List_Id is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Index_Or_Discriminant_Constraint);
- return List1 (N);
- end Constraints;
-
- function Context_Installed
- (N : Node_Id) return Boolean is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_With_Clause);
- return Flag13 (N);
- end Context_Installed;
-
- function Context_Items
- (N : Node_Id) return List_Id is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Compilation_Unit);
- return List1 (N);
- end Context_Items;
-
- function Context_Pending
- (N : Node_Id) return Boolean is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Compilation_Unit);
- return Flag16 (N);
- end Context_Pending;
-
- function Contract_Test_Cases
- (N : Node_Id) return Node_Id is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Contract);
- return Node2 (N);
- end Contract_Test_Cases;
-
- function Controlling_Argument
- (N : Node_Id) return Node_Id is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Function_Call
- or else NT (N).Nkind = N_Procedure_Call_Statement);
- return Node1 (N);
- end Controlling_Argument;
-
- function Conversion_OK
- (N : Node_Id) return Boolean is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Type_Conversion);
- return Flag14 (N);
- end Conversion_OK;
-
- function Convert_To_Return_False
- (N : Node_Id) return Boolean is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Raise_Expression);
- return Flag13 (N);
- end Convert_To_Return_False;
-
- function Corresponding_Aspect
- (N : Node_Id) return Node_Id is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Pragma);
- return Node3 (N);
- end Corresponding_Aspect;
-
- function Corresponding_Body
- (N : Node_Id) return Node_Id is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Entry_Declaration
- or else NT (N).Nkind = N_Generic_Package_Declaration
- or else NT (N).Nkind = N_Generic_Subprogram_Declaration
- or else NT (N).Nkind = N_Package_Body_Stub
- or else NT (N).Nkind = N_Package_Declaration
- or else NT (N).Nkind = N_Protected_Body_Stub
- or else NT (N).Nkind = N_Protected_Type_Declaration
- or else NT (N).Nkind = N_Subprogram_Body_Stub
- or else NT (N).Nkind = N_Subprogram_Declaration
- or else NT (N).Nkind = N_Task_Body_Stub
- or else NT (N).Nkind = N_Task_Type_Declaration);
- return Node5 (N);
- end Corresponding_Body;
-
- function Corresponding_Formal_Spec
- (N : Node_Id) return Node_Id is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Subprogram_Renaming_Declaration);
- return Node3 (N);
- end Corresponding_Formal_Spec;
-
- function Corresponding_Generic_Association
- (N : Node_Id) return Node_Id is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Object_Declaration
- or else NT (N).Nkind = N_Object_Renaming_Declaration);
- return Node5 (N);
- end Corresponding_Generic_Association;
-
- function Corresponding_Integer_Value
- (N : Node_Id) return Uint is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Real_Literal);
- return Uint4 (N);
- end Corresponding_Integer_Value;
-
- function Corresponding_Spec
- (N : Node_Id) return Entity_Id is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Expression_Function
- or else NT (N).Nkind = N_Package_Body
- or else NT (N).Nkind = N_Protected_Body
- or else NT (N).Nkind = N_Subprogram_Body
- or else NT (N).Nkind = N_Subprogram_Renaming_Declaration
- or else NT (N).Nkind = N_Task_Body
- or else NT (N).Nkind = N_With_Clause);
- return Node5 (N);
- end Corresponding_Spec;
-
- function Corresponding_Spec_Of_Stub
- (N : Node_Id) return Entity_Id is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Package_Body_Stub
- or else NT (N).Nkind = N_Protected_Body_Stub
- or else NT (N).Nkind = N_Subprogram_Body_Stub
- or else NT (N).Nkind = N_Task_Body_Stub);
- return Node2 (N);
- end Corresponding_Spec_Of_Stub;
-
- function Corresponding_Stub
- (N : Node_Id) return Node_Id is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Subunit);
- return Node3 (N);
- end Corresponding_Stub;
-
- function Dcheck_Function
- (N : Node_Id) return Entity_Id is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Variant);
- return Node5 (N);
- end Dcheck_Function;
-
- function Declarations
- (N : Node_Id) return List_Id is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Accept_Statement
- or else NT (N).Nkind = N_Block_Statement
- or else NT (N).Nkind = N_Compilation_Unit_Aux
- or else NT (N).Nkind = N_Entry_Body
- or else NT (N).Nkind = N_Package_Body
- or else NT (N).Nkind = N_Protected_Body
- or else NT (N).Nkind = N_Subprogram_Body
- or else NT (N).Nkind = N_Task_Body);
- return List2 (N);
- end Declarations;
-
- function Default_Expression
- (N : Node_Id) return Node_Id is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Formal_Object_Declaration
- or else NT (N).Nkind = N_Parameter_Specification);
- return Node5 (N);
- end Default_Expression;
-
- function Default_Storage_Pool
- (N : Node_Id) return Node_Id is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Compilation_Unit_Aux);
- return Node3 (N);
- end Default_Storage_Pool;
-
- function Default_Name
- (N : Node_Id) return Node_Id is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Formal_Abstract_Subprogram_Declaration
- or else NT (N).Nkind = N_Formal_Concrete_Subprogram_Declaration);
- return Node2 (N);
- end Default_Name;
-
- function Defining_Identifier
- (N : Node_Id) return Entity_Id is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Component_Declaration
- or else NT (N).Nkind = N_Defining_Program_Unit_Name
- or else NT (N).Nkind = N_Discriminant_Specification
- or else NT (N).Nkind = N_Entry_Body
- or else NT (N).Nkind = N_Entry_Declaration
- or else NT (N).Nkind = N_Entry_Index_Specification
- or else NT (N).Nkind = N_Exception_Declaration
- or else NT (N).Nkind = N_Exception_Renaming_Declaration
- or else NT (N).Nkind = N_Formal_Object_Declaration
- or else NT (N).Nkind = N_Formal_Package_Declaration
- or else NT (N).Nkind = N_Formal_Type_Declaration
- or else NT (N).Nkind = N_Full_Type_Declaration
- or else NT (N).Nkind = N_Implicit_Label_Declaration
- or else NT (N).Nkind = N_Incomplete_Type_Declaration
- or else NT (N).Nkind = N_Iterated_Component_Association
- or else NT (N).Nkind = N_Iterator_Specification
- or else NT (N).Nkind = N_Loop_Parameter_Specification
- or else NT (N).Nkind = N_Number_Declaration
- or else NT (N).Nkind = N_Object_Declaration
- or else NT (N).Nkind = N_Object_Renaming_Declaration
- or else NT (N).Nkind = N_Package_Body_Stub
- or else NT (N).Nkind = N_Parameter_Specification
- or else NT (N).Nkind = N_Private_Extension_Declaration
- or else NT (N).Nkind = N_Private_Type_Declaration
- or else NT (N).Nkind = N_Protected_Body
- or else NT (N).Nkind = N_Protected_Body_Stub
- or else NT (N).Nkind = N_Protected_Type_Declaration
- or else NT (N).Nkind = N_Single_Protected_Declaration
- or else NT (N).Nkind = N_Single_Task_Declaration
- or else NT (N).Nkind = N_Subtype_Declaration
- or else NT (N).Nkind = N_Task_Body
- or else NT (N).Nkind = N_Task_Body_Stub
- or else NT (N).Nkind = N_Task_Type_Declaration);
- return Node1 (N);
- end Defining_Identifier;
-
- function Defining_Unit_Name
- (N : Node_Id) return Node_Id is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Function_Instantiation
- or else NT (N).Nkind = N_Function_Specification
- or else NT (N).Nkind = N_Generic_Function_Renaming_Declaration
- or else NT (N).Nkind = N_Generic_Package_Renaming_Declaration
- or else NT (N).Nkind = N_Generic_Procedure_Renaming_Declaration
- or else NT (N).Nkind = N_Package_Body
- or else NT (N).Nkind = N_Package_Instantiation
- or else NT (N).Nkind = N_Package_Renaming_Declaration
- or else NT (N).Nkind = N_Package_Specification
- or else NT (N).Nkind = N_Procedure_Instantiation
- or else NT (N).Nkind = N_Procedure_Specification);
- return Node1 (N);
- end Defining_Unit_Name;
-
- function Delay_Alternative
- (N : Node_Id) return Node_Id is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Timed_Entry_Call);
- return Node4 (N);
- end Delay_Alternative;
-
- function Delay_Statement
- (N : Node_Id) return Node_Id is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Delay_Alternative);
- return Node2 (N);
- end Delay_Statement;
-
- function Delta_Expression
- (N : Node_Id) return Node_Id is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Decimal_Fixed_Point_Definition
- or else NT (N).Nkind = N_Delta_Constraint
- or else NT (N).Nkind = N_Ordinary_Fixed_Point_Definition);
- return Node3 (N);
- end Delta_Expression;
-
- function Digits_Expression
- (N : Node_Id) return Node_Id is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Decimal_Fixed_Point_Definition
- or else NT (N).Nkind = N_Digits_Constraint
- or else NT (N).Nkind = N_Floating_Point_Definition);
- return Node2 (N);
- end Digits_Expression;
-
- function Discr_Check_Funcs_Built
- (N : Node_Id) return Boolean is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Full_Type_Declaration);
- return Flag11 (N);
- end Discr_Check_Funcs_Built;
-
- function Discrete_Choices
- (N : Node_Id) return List_Id is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Case_Expression_Alternative
- or else NT (N).Nkind = N_Case_Statement_Alternative
- or else NT (N).Nkind = N_Iterated_Component_Association
- or else NT (N).Nkind = N_Variant);
- return List4 (N);
- end Discrete_Choices;
-
- function Discrete_Range
- (N : Node_Id) return Node_Id is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Slice);
- return Node4 (N);
- end Discrete_Range;
-
- function Discrete_Subtype_Definition
- (N : Node_Id) return Node_Id is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Entry_Declaration
- or else NT (N).Nkind = N_Entry_Index_Specification
- or else NT (N).Nkind = N_Loop_Parameter_Specification);
- return Node4 (N);
- end Discrete_Subtype_Definition;
-
- function Discrete_Subtype_Definitions
- (N : Node_Id) return List_Id is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Constrained_Array_Definition);
- return List2 (N);
- end Discrete_Subtype_Definitions;
-
- function Discriminant_Specifications
- (N : Node_Id) return List_Id is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Formal_Type_Declaration
- or else NT (N).Nkind = N_Full_Type_Declaration
- or else NT (N).Nkind = N_Incomplete_Type_Declaration
- or else NT (N).Nkind = N_Private_Extension_Declaration
- or else NT (N).Nkind = N_Private_Type_Declaration
- or else NT (N).Nkind = N_Protected_Type_Declaration
- or else NT (N).Nkind = N_Task_Type_Declaration);
- return List4 (N);
- end Discriminant_Specifications;
-
- function Discriminant_Type
- (N : Node_Id) return Node_Id is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Discriminant_Specification);
- return Node5 (N);
- end Discriminant_Type;
-
- function Do_Accessibility_Check
- (N : Node_Id) return Boolean is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Parameter_Specification);
- return Flag13 (N);
- end Do_Accessibility_Check;
-
- function Do_Discriminant_Check
- (N : Node_Id) return Boolean is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Assignment_Statement
- or else NT (N).Nkind = N_Selected_Component
- or else NT (N).Nkind = N_Type_Conversion);
- return Flag3 (N);
- end Do_Discriminant_Check;
-
- function Do_Division_Check
- (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_Rem);
- return Flag13 (N);
- end Do_Division_Check;
-
- function Do_Length_Check
- (N : Node_Id) return Boolean is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Assignment_Statement
- or else NT (N).Nkind = N_Op_And
- or else NT (N).Nkind = N_Op_Or
- or else NT (N).Nkind = N_Op_Xor
- or else NT (N).Nkind = N_Type_Conversion);
- return Flag4 (N);
- end Do_Length_Check;
-
- function Do_Overflow_Check
- (N : Node_Id) return Boolean is
- begin
- pragma Assert (False
- or else NT (N).Nkind in N_Op
- or else NT (N).Nkind = N_Attribute_Reference
- or else NT (N).Nkind = N_Case_Expression
- or else NT (N).Nkind = N_If_Expression
- or else NT (N).Nkind = N_Type_Conversion);
- return Flag17 (N);
- end Do_Overflow_Check;
-
- function Do_Range_Check
- (N : Node_Id) return Boolean is
- begin
- pragma Assert (False
- or else NT (N).Nkind in N_Subexpr);
- return Flag9 (N);
- end Do_Range_Check;
-
- function Do_Storage_Check
- (N : Node_Id) return Boolean is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Allocator
- or else NT (N).Nkind = N_Subprogram_Body);
- return Flag17 (N);
- end Do_Storage_Check;
-
- function Do_Tag_Check
- (N : Node_Id) return Boolean is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Assignment_Statement
- or else NT (N).Nkind = N_Extended_Return_Statement
- or else NT (N).Nkind = N_Function_Call
- or else NT (N).Nkind = N_Procedure_Call_Statement
- or else NT (N).Nkind = N_Simple_Return_Statement
- or else NT (N).Nkind = N_Type_Conversion);
- return Flag13 (N);
- end Do_Tag_Check;
-
- function Elaborate_All_Desirable
- (N : Node_Id) return Boolean is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_With_Clause);
- return Flag9 (N);
- end Elaborate_All_Desirable;
-
- function Elaborate_All_Present
- (N : Node_Id) return Boolean is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_With_Clause);
- return Flag14 (N);
- end Elaborate_All_Present;
-
- function Elaborate_Desirable
- (N : Node_Id) return Boolean is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_With_Clause);
- return Flag11 (N);
- end Elaborate_Desirable;
-
- function Elaborate_Present
- (N : Node_Id) return Boolean is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_With_Clause);
- return Flag4 (N);
- end Elaborate_Present;
-
- function Else_Actions
- (N : Node_Id) return List_Id is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_If_Expression);
- return List3 (N);
- end Else_Actions;
-
- function Else_Statements
- (N : Node_Id) return List_Id is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Conditional_Entry_Call
- or else NT (N).Nkind = N_If_Statement
- or else NT (N).Nkind = N_Selective_Accept);
- return List4 (N);
- end Else_Statements;
-
- function Elsif_Parts
- (N : Node_Id) return List_Id is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_If_Statement);
- return List3 (N);
- end Elsif_Parts;
-
- function Enclosing_Variant
- (N : Node_Id) return Node_Id is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Variant);
- return Node2 (N);
- end Enclosing_Variant;
-
- function End_Label
- (N : Node_Id) return Node_Id is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Enumeration_Type_Definition
- or else NT (N).Nkind = N_Handled_Sequence_Of_Statements
- or else NT (N).Nkind = N_Loop_Statement
- or else NT (N).Nkind = N_Package_Specification
- or else NT (N).Nkind = N_Protected_Body
- or else NT (N).Nkind = N_Protected_Definition
- or else NT (N).Nkind = N_Record_Definition
- or else NT (N).Nkind = N_Task_Definition);
- return Node4 (N);
- end End_Label;
-
- function End_Span
- (N : Node_Id) return Uint is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Case_Statement
- or else NT (N).Nkind = N_If_Statement);
- return Uint5 (N);
- end End_Span;
-
- function Entity
- (N : Node_Id) return Node_Id is
- begin
- pragma Assert (False
- or else NT (N).Nkind in N_Has_Entity
- or else NT (N).Nkind = N_Aspect_Specification
- or else NT (N).Nkind = N_Attribute_Definition_Clause
- or else NT (N).Nkind = N_Freeze_Entity
- or else NT (N).Nkind = N_Freeze_Generic_Entity);
- return Node4 (N);
- end Entity;
-
- function Entity_Or_Associated_Node
- (N : Node_Id) return Node_Id is
- begin
- pragma Assert (False
- or else NT (N).Nkind in N_Has_Entity
- or else NT (N).Nkind = N_Freeze_Entity);
- return Node4 (N);
- end Entity_Or_Associated_Node;
-
- function Entry_Body_Formal_Part
- (N : Node_Id) return Node_Id is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Entry_Body);
- return Node5 (N);
- end Entry_Body_Formal_Part;
-
- function Entry_Call_Alternative
- (N : Node_Id) return Node_Id is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Conditional_Entry_Call
- or else NT (N).Nkind = N_Timed_Entry_Call);
- return Node1 (N);
- end Entry_Call_Alternative;
-
- function Entry_Call_Statement
- (N : Node_Id) return Node_Id is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Entry_Call_Alternative);
- return Node1 (N);
- end Entry_Call_Statement;
-
- function Entry_Direct_Name
- (N : Node_Id) return Node_Id is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Accept_Statement);
- return Node1 (N);
- end Entry_Direct_Name;
-
- function Entry_Index
- (N : Node_Id) return Node_Id is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Accept_Statement);
- return Node5 (N);
- end Entry_Index;
-
- function Entry_Index_Specification
- (N : Node_Id) return Node_Id is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Entry_Body_Formal_Part);
- return Node4 (N);
- end Entry_Index_Specification;
-
- function Etype
- (N : Node_Id) return Node_Id is
- begin
- pragma Assert (False
- or else NT (N).Nkind in N_Has_Etype);
- return Node5 (N);
- end Etype;
-
- function Exception_Choices
- (N : Node_Id) return List_Id is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Exception_Handler);
- return List4 (N);
- end Exception_Choices;
-
- function Exception_Handlers
- (N : Node_Id) return List_Id is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Handled_Sequence_Of_Statements);
- return List5 (N);
- end Exception_Handlers;
-
- function Exception_Junk
- (N : Node_Id) return Boolean is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Block_Statement
- or else NT (N).Nkind = N_Goto_Statement
- or else NT (N).Nkind = N_Label
- or else NT (N).Nkind = N_Object_Declaration
- or else NT (N).Nkind = N_Subtype_Declaration);
- return Flag8 (N);
- end Exception_Junk;
-
- function Exception_Label
- (N : Node_Id) return Node_Id is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Exception_Handler
- or else NT (N).Nkind = N_Push_Constraint_Error_Label
- or else NT (N).Nkind = N_Push_Program_Error_Label
- or else NT (N).Nkind = N_Push_Storage_Error_Label);
- return Node5 (N);
- end Exception_Label;
-
- function Expansion_Delayed
- (N : Node_Id) return Boolean is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Aggregate
- or else NT (N).Nkind = N_Extension_Aggregate);
- return Flag11 (N);
- end Expansion_Delayed;
-
- function Explicit_Actual_Parameter
- (N : Node_Id) return Node_Id is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Parameter_Association);
- return Node3 (N);
- end Explicit_Actual_Parameter;
-
- function Explicit_Generic_Actual_Parameter
- (N : Node_Id) return Node_Id is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Generic_Association);
- return Node1 (N);
- end Explicit_Generic_Actual_Parameter;
-
- function Expression
- (N : Node_Id) return Node_Id is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Allocator
- or else NT (N).Nkind = N_Aspect_Specification
- or else NT (N).Nkind = N_Assignment_Statement
- or else NT (N).Nkind = N_At_Clause
- or else NT (N).Nkind = N_Attribute_Definition_Clause
- or else NT (N).Nkind = N_Case_Expression
- or else NT (N).Nkind = N_Case_Expression_Alternative
- or else NT (N).Nkind = N_Case_Statement
- or else NT (N).Nkind = N_Code_Statement
- or else NT (N).Nkind = N_Component_Association
- or else NT (N).Nkind = N_Component_Declaration
- or else NT (N).Nkind = N_Delay_Relative_Statement
- or else NT (N).Nkind = N_Delay_Until_Statement
- or else NT (N).Nkind = N_Delta_Aggregate
- or else NT (N).Nkind = N_Discriminant_Association
- or else NT (N).Nkind = N_Discriminant_Specification
- or else NT (N).Nkind = N_Exception_Declaration
- or else NT (N).Nkind = N_Expression_Function
- 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
- or else NT (N).Nkind = N_Object_Declaration
- or else NT (N).Nkind = N_Parameter_Specification
- or else NT (N).Nkind = N_Pragma_Argument_Association
- or else NT (N).Nkind = N_Qualified_Expression
- or else NT (N).Nkind = N_Raise_Expression
- or else NT (N).Nkind = N_Raise_Statement
- or else NT (N).Nkind = N_Simple_Return_Statement
- or else NT (N).Nkind = N_Type_Conversion
- or else NT (N).Nkind = N_Unchecked_Expression
- or else NT (N).Nkind = N_Unchecked_Type_Conversion);
- return Node3 (N);
- end Expression;
-
- function Expression_Copy
- (N : Node_Id) return Node_Id is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Pragma_Argument_Association);
- return Node2 (N);
- end Expression_Copy;
-
- function Expressions
- (N : Node_Id) return List_Id is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Aggregate
- or else NT (N).Nkind = N_Attribute_Reference
- or else NT (N).Nkind = N_Extension_Aggregate
- or else NT (N).Nkind = N_If_Expression
- or else NT (N).Nkind = N_Indexed_Component);
- return List1 (N);
- end Expressions;
-
- function First_Bit
- (N : Node_Id) return Node_Id is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Component_Clause);
- return Node3 (N);
- end First_Bit;
-
- function First_Inlined_Subprogram
- (N : Node_Id) return Entity_Id is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Compilation_Unit);
- return Node3 (N);
- end First_Inlined_Subprogram;
-
- function First_Name
- (N : Node_Id) return Boolean is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_With_Clause);
- return Flag5 (N);
- end First_Name;
-
- function First_Named_Actual
- (N : Node_Id) return Node_Id is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Entry_Call_Statement
- or else NT (N).Nkind = N_Function_Call
- or else NT (N).Nkind = N_Procedure_Call_Statement);
- return Node4 (N);
- end First_Named_Actual;
-
- function First_Real_Statement
- (N : Node_Id) return Node_Id is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Handled_Sequence_Of_Statements);
- return Node2 (N);
- end First_Real_Statement;
-
- function First_Subtype_Link
- (N : Node_Id) return Entity_Id is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Freeze_Entity);
- return Node5 (N);
- end First_Subtype_Link;
-
- function Float_Truncate
- (N : Node_Id) return Boolean is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Type_Conversion);
- return Flag11 (N);
- end Float_Truncate;
-
- function Formal_Type_Definition
- (N : Node_Id) return Node_Id is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Formal_Type_Declaration);
- return Node3 (N);
- end Formal_Type_Definition;
-
- function Forwards_OK
- (N : Node_Id) return Boolean is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Assignment_Statement);
- return Flag5 (N);
- end Forwards_OK;
-
- function From_Aspect_Specification
- (N : Node_Id) return Boolean is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Attribute_Definition_Clause
- or else NT (N).Nkind = N_Pragma);
- return Flag13 (N);
- end From_Aspect_Specification;
-
- function From_At_End
- (N : Node_Id) return Boolean is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Raise_Statement);
- return Flag4 (N);
- end From_At_End;
-
- function From_At_Mod
- (N : Node_Id) return Boolean is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Attribute_Definition_Clause);
- return Flag4 (N);
- end From_At_Mod;
-
- function From_Conditional_Expression
- (N : Node_Id) return Boolean is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Case_Statement
- or else NT (N).Nkind = N_If_Statement);
- return Flag1 (N);
- end From_Conditional_Expression;
-
- function From_Default
- (N : Node_Id) return Boolean is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Subprogram_Renaming_Declaration);
- return Flag6 (N);
- end From_Default;
-
- function Generalized_Indexing
- (N : Node_Id) return Node_Id is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Indexed_Component);
- return Node4 (N);
- end Generalized_Indexing;
-
- function Generic_Associations
- (N : Node_Id) return List_Id is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Formal_Package_Declaration
- or else NT (N).Nkind = N_Function_Instantiation
- or else NT (N).Nkind = N_Package_Instantiation
- or else NT (N).Nkind = N_Procedure_Instantiation);
- return List3 (N);
- end Generic_Associations;
-
- function Generic_Formal_Declarations
- (N : Node_Id) return List_Id is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Generic_Package_Declaration
- or else NT (N).Nkind = N_Generic_Subprogram_Declaration);
- return List2 (N);
- end Generic_Formal_Declarations;
-
- function Generic_Parent
- (N : Node_Id) return Node_Id is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Function_Specification
- or else NT (N).Nkind = N_Package_Specification
- or else NT (N).Nkind = N_Procedure_Specification);
- return Node5 (N);
- end Generic_Parent;
-
- function Generic_Parent_Type
- (N : Node_Id) return Node_Id is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Subtype_Declaration);
- return Node4 (N);
- end Generic_Parent_Type;
-
- function Handled_Statement_Sequence
- (N : Node_Id) return Node_Id is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Accept_Statement
- or else NT (N).Nkind = N_Block_Statement
- or else NT (N).Nkind = N_Entry_Body
- or else NT (N).Nkind = N_Extended_Return_Statement
- or else NT (N).Nkind = N_Package_Body
- or else NT (N).Nkind = N_Subprogram_Body
- or else NT (N).Nkind = N_Task_Body);
- return Node4 (N);
- end Handled_Statement_Sequence;
-
- function Handler_List_Entry
- (N : Node_Id) return Node_Id is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Object_Declaration);
- return Node2 (N);
- end Handler_List_Entry;
-
- function Has_Created_Identifier
- (N : Node_Id) return Boolean is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Block_Statement
- or else NT (N).Nkind = N_Loop_Statement);
- return Flag15 (N);
- end Has_Created_Identifier;
-
- function Has_Dereference_Action
- (N : Node_Id) return Boolean is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Explicit_Dereference);
- return Flag13 (N);
- end Has_Dereference_Action;
-
- function Has_Dynamic_Length_Check
- (N : Node_Id) return Boolean is
- begin
- pragma Assert (False
- or else NT (N).Nkind in N_Subexpr);
- return Flag10 (N);
- end Has_Dynamic_Length_Check;
-
- function Has_Init_Expression
- (N : Node_Id) return Boolean is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Object_Declaration);
- return Flag14 (N);
- end Has_Init_Expression;
-
- function Has_Local_Raise
- (N : Node_Id) return Boolean is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Exception_Handler);
- return Flag8 (N);
- end Has_Local_Raise;
-
- function Has_No_Elaboration_Code
- (N : Node_Id) return Boolean is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Compilation_Unit);
- return Flag17 (N);
- end Has_No_Elaboration_Code;
-
- function Has_Pragma_Suppress_All
- (N : Node_Id) return Boolean is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Compilation_Unit);
- return Flag14 (N);
- end Has_Pragma_Suppress_All;
-
- function Has_Private_View
- (N : Node_Id) return Boolean is
- begin
- pragma Assert (False
- or else NT (N).Nkind in N_Op
- or else NT (N).Nkind = N_Character_Literal
- or else NT (N).Nkind = N_Expanded_Name
- or else NT (N).Nkind = N_Identifier
- or else NT (N).Nkind = N_Operator_Symbol);
- return Flag11 (N);
- end Has_Private_View;
-
- function Has_Relative_Deadline_Pragma
- (N : Node_Id) return Boolean is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Subprogram_Body
- or else NT (N).Nkind = N_Task_Definition);
- return Flag9 (N);
- end Has_Relative_Deadline_Pragma;
-
- function Has_Self_Reference
- (N : Node_Id) return Boolean is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Aggregate
- or else NT (N).Nkind = N_Extension_Aggregate);
- return Flag13 (N);
- end Has_Self_Reference;
-
- function Has_SP_Choice
- (N : Node_Id) return Boolean is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Case_Expression_Alternative
- or else NT (N).Nkind = N_Case_Statement_Alternative
- or else NT (N).Nkind = N_Variant);
- return Flag15 (N);
- end Has_SP_Choice;
-
- function Has_Storage_Size_Pragma
- (N : Node_Id) return Boolean is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Task_Definition);
- return Flag5 (N);
- end Has_Storage_Size_Pragma;
-
- function Has_Target_Names
- (N : Node_Id) return Boolean is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Assignment_Statement);
- return Flag8 (N);
- end Has_Target_Names;
-
- function Has_Wide_Character
- (N : Node_Id) return Boolean is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_String_Literal);
- return Flag11 (N);
- end Has_Wide_Character;
-
- function Has_Wide_Wide_Character
- (N : Node_Id) return Boolean is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_String_Literal);
- return Flag13 (N);
- end Has_Wide_Wide_Character;
-
- function Header_Size_Added
- (N : Node_Id) return Boolean is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Attribute_Reference);
- return Flag11 (N);
- end Header_Size_Added;
-
- function Hidden_By_Use_Clause
- (N : Node_Id) return Elist_Id is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Use_Package_Clause
- or else NT (N).Nkind = N_Use_Type_Clause);
- return Elist5 (N);
- end Hidden_By_Use_Clause;
-
- function High_Bound
- (N : Node_Id) return Node_Id is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Range
- or else NT (N).Nkind = N_Real_Range_Specification
- or else NT (N).Nkind = N_Signed_Integer_Type_Definition);
- return Node2 (N);
- end High_Bound;
-
- function Identifier
- (N : Node_Id) return Node_Id is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Aspect_Specification
- or else NT (N).Nkind = N_At_Clause
- or else NT (N).Nkind = N_Block_Statement
- or else NT (N).Nkind = N_Designator
- or else NT (N).Nkind = N_Enumeration_Representation_Clause
- or else NT (N).Nkind = N_Label
- or else NT (N).Nkind = N_Loop_Statement
- or else NT (N).Nkind = N_Record_Representation_Clause);
- return Node1 (N);
- end Identifier;
-
- function Implicit_With
- (N : Node_Id) return Boolean is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_With_Clause);
- return Flag16 (N);
- end Implicit_With;
-
- function Interface_List
- (N : Node_Id) return List_Id is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Derived_Type_Definition
- or else NT (N).Nkind = N_Formal_Derived_Type_Definition
- or else NT (N).Nkind = N_Private_Extension_Declaration
- or else NT (N).Nkind = N_Protected_Type_Declaration
- or else NT (N).Nkind = N_Record_Definition
- or else NT (N).Nkind = N_Single_Protected_Declaration
- or else NT (N).Nkind = N_Single_Task_Declaration
- or else NT (N).Nkind = N_Task_Type_Declaration);
- return List2 (N);
- end Interface_List;
-
- function Interface_Present
- (N : Node_Id) return Boolean is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Derived_Type_Definition
- or else NT (N).Nkind = N_Record_Definition);
- return Flag16 (N);
- end Interface_Present;
-
- function Import_Interface_Present
- (N : Node_Id) return Boolean is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Pragma);
- return Flag16 (N);
- end Import_Interface_Present;
-
- function In_Present
- (N : Node_Id) return Boolean is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Formal_Object_Declaration
- or else NT (N).Nkind = N_Parameter_Specification);
- return Flag15 (N);
- end In_Present;
-
- function Includes_Infinities
- (N : Node_Id) return Boolean is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Range);
- return Flag11 (N);
- end Includes_Infinities;
-
- function Incomplete_View
- (N : Node_Id) return Node_Id is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Full_Type_Declaration);
- return Node2 (N);
- end Incomplete_View;
-
- function Inherited_Discriminant
- (N : Node_Id) return Boolean is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Component_Association);
- return Flag13 (N);
- end Inherited_Discriminant;
-
- function Instance_Spec
- (N : Node_Id) return Node_Id is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Formal_Package_Declaration
- or else NT (N).Nkind = N_Function_Instantiation
- or else NT (N).Nkind = N_Package_Instantiation
- or else NT (N).Nkind = N_Procedure_Instantiation);
- return Node5 (N);
- end Instance_Spec;
-
- function Intval
- (N : Node_Id) return Uint is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Integer_Literal);
- return Uint3 (N);
- end Intval;
-
- function Is_Abort_Block
- (N : Node_Id) return Boolean is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Block_Statement);
- return Flag4 (N);
- end Is_Abort_Block;
-
- function Is_Accessibility_Actual
- (N : Node_Id) return Boolean is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Parameter_Association);
- return Flag13 (N);
- end Is_Accessibility_Actual;
-
- function Is_Analyzed_Pragma
- (N : Node_Id) return Boolean is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Pragma);
- return Flag5 (N);
- end Is_Analyzed_Pragma;
-
- function Is_Asynchronous_Call_Block
- (N : Node_Id) return Boolean is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Block_Statement);
- return Flag7 (N);
- end Is_Asynchronous_Call_Block;
-
- function Is_Boolean_Aspect
- (N : Node_Id) return Boolean is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Aspect_Specification);
- return Flag16 (N);
- end Is_Boolean_Aspect;
-
- function Is_Checked
- (N : Node_Id) return Boolean is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Aspect_Specification
- or else NT (N).Nkind = N_Pragma);
- return Flag11 (N);
- end Is_Checked;
-
- function Is_Checked_Ghost_Pragma
- (N : Node_Id) return Boolean is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Pragma);
- return Flag3 (N);
- end Is_Checked_Ghost_Pragma;
-
- function Is_Component_Left_Opnd
- (N : Node_Id) return Boolean is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Op_Concat);
- return Flag13 (N);
- end Is_Component_Left_Opnd;
-
- function Is_Component_Right_Opnd
- (N : Node_Id) return Boolean is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Op_Concat);
- return Flag14 (N);
- end Is_Component_Right_Opnd;
-
- function Is_Controlling_Actual
- (N : Node_Id) return Boolean is
- begin
- pragma Assert (False
- or else NT (N).Nkind in N_Subexpr);
- return Flag16 (N);
- end Is_Controlling_Actual;
-
- function Is_Declaration_Level_Node
- (N : Node_Id) return Boolean is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Call_Marker
- or else NT (N).Nkind = N_Function_Instantiation
- or else NT (N).Nkind = N_Package_Instantiation
- or else NT (N).Nkind = N_Procedure_Instantiation);
- return Flag5 (N);
- end Is_Declaration_Level_Node;
-
- function Is_Delayed_Aspect
- (N : Node_Id) return Boolean is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Aspect_Specification
- or else NT (N).Nkind = N_Attribute_Definition_Clause
- or else NT (N).Nkind = N_Pragma);
- return Flag14 (N);
- end Is_Delayed_Aspect;
-
- function Is_Disabled
- (N : Node_Id) return Boolean is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Aspect_Specification
- or else NT (N).Nkind = N_Pragma);
- return Flag15 (N);
- end Is_Disabled;
-
- function Is_Dispatching_Call
- (N : Node_Id) return Boolean is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Call_Marker);
- return Flag6 (N);
- end Is_Dispatching_Call;
-
- function Is_Dynamic_Coextension
- (N : Node_Id) return Boolean is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Allocator);
- return Flag18 (N);
- end Is_Dynamic_Coextension;
-
- function Is_Effective_Use_Clause
- (N : Node_Id) return Boolean is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Use_Package_Clause
- or else NT (N).Nkind = N_Use_Type_Clause);
- return Flag1 (N);
- end Is_Effective_Use_Clause;
-
- function Is_Elaboration_Checks_OK_Node
- (N : Node_Id) return Boolean is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Assignment_Statement
- or else NT (N).Nkind = N_Attribute_Reference
- or else NT (N).Nkind = N_Call_Marker
- or else NT (N).Nkind = N_Entry_Call_Statement
- or else NT (N).Nkind = N_Expanded_Name
- or else NT (N).Nkind = N_Function_Call
- or else NT (N).Nkind = N_Function_Instantiation
- or else NT (N).Nkind = N_Identifier
- or else NT (N).Nkind = N_Package_Instantiation
- or else NT (N).Nkind = N_Procedure_Call_Statement
- or else NT (N).Nkind = N_Procedure_Instantiation
- or else NT (N).Nkind = N_Requeue_Statement
- or else NT (N).Nkind = N_Variable_Reference_Marker);
- return Flag1 (N);
- end Is_Elaboration_Checks_OK_Node;
-
- function Is_Elaboration_Code
- (N : Node_Id) return Boolean is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Assignment_Statement);
- return Flag9 (N);
- end Is_Elaboration_Code;
-
- function Is_Elaboration_Warnings_OK_Node
- (N : Node_Id) return Boolean is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Attribute_Reference
- or else NT (N).Nkind = N_Call_Marker
- or else NT (N).Nkind = N_Entry_Call_Statement
- or else NT (N).Nkind = N_Expanded_Name
- or else NT (N).Nkind = N_Function_Call
- or else NT (N).Nkind = N_Function_Instantiation
- or else NT (N).Nkind = N_Identifier
- or else NT (N).Nkind = N_Package_Instantiation
- or else NT (N).Nkind = N_Procedure_Call_Statement
- or else NT (N).Nkind = N_Procedure_Instantiation
- or else NT (N).Nkind = N_Requeue_Statement
- or else NT (N).Nkind = N_Variable_Reference_Marker);
- return Flag3 (N);
- end Is_Elaboration_Warnings_OK_Node;
-
- function Is_Elsif
- (N : Node_Id) return Boolean is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_If_Expression);
- return Flag13 (N);
- end Is_Elsif;
-
- function Is_Entry_Barrier_Function
- (N : Node_Id) return Boolean is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Subprogram_Body
- or else NT (N).Nkind = N_Subprogram_Declaration);
- return Flag8 (N);
- end Is_Entry_Barrier_Function;
-
- function Is_Expanded_Build_In_Place_Call
- (N : Node_Id) return Boolean is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Function_Call);
- return Flag11 (N);
- end Is_Expanded_Build_In_Place_Call;
-
- function Is_Expanded_Contract
- (N : Node_Id) return Boolean is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Contract);
- return Flag1 (N);
- end Is_Expanded_Contract;
-
- function Is_Finalization_Wrapper
- (N : Node_Id) return Boolean is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Block_Statement);
- return Flag9 (N);
- end Is_Finalization_Wrapper;
-
- function Is_Folded_In_Parser
- (N : Node_Id) return Boolean is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_String_Literal);
- return Flag4 (N);
- end Is_Folded_In_Parser;
-
- function Is_Generic_Contract_Pragma
- (N : Node_Id) return Boolean is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Pragma);
- return Flag2 (N);
- end Is_Generic_Contract_Pragma;
-
- function Is_Homogeneous_Aggregate
- (N : Node_Id) return Boolean is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Aggregate);
- return Flag14 (N);
- end Is_Homogeneous_Aggregate;
-
- function Is_Ignored
- (N : Node_Id) return Boolean is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Aspect_Specification
- or else NT (N).Nkind = N_Pragma);
- return Flag9 (N);
- end Is_Ignored;
-
- function Is_Ignored_Ghost_Pragma
- (N : Node_Id) return Boolean is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Pragma);
- return Flag8 (N);
- end Is_Ignored_Ghost_Pragma;
-
- function Is_In_Discriminant_Check
- (N : Node_Id) return Boolean is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Selected_Component);
- return Flag11 (N);
- end Is_In_Discriminant_Check;
-
- function Is_Inherited_Pragma
- (N : Node_Id) return Boolean is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Pragma);
- return Flag4 (N);
- end Is_Inherited_Pragma;
-
- function Is_Initialization_Block
- (N : Node_Id) return Boolean is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Block_Statement);
- return Flag1 (N);
- end Is_Initialization_Block;
-
- function Is_Known_Guaranteed_ABE
- (N : Node_Id) return Boolean is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Call_Marker
- or else NT (N).Nkind = N_Formal_Package_Declaration
- or else NT (N).Nkind = N_Function_Call
- or else NT (N).Nkind = N_Function_Instantiation
- or else NT (N).Nkind = N_Package_Instantiation
- or else NT (N).Nkind = N_Procedure_Call_Statement
- or else NT (N).Nkind = N_Procedure_Instantiation);
- return Flag18 (N);
- end Is_Known_Guaranteed_ABE;
-
- function Is_Machine_Number
- (N : Node_Id) return Boolean is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Real_Literal);
- return Flag11 (N);
- end Is_Machine_Number;
-
- function Is_Null_Loop
- (N : Node_Id) return Boolean is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Loop_Statement);
- return Flag16 (N);
- end Is_Null_Loop;
-
- function Is_Overloaded
- (N : Node_Id) return Boolean is
- begin
- pragma Assert (False
- or else NT (N).Nkind in N_Subexpr);
- return Flag5 (N);
- end Is_Overloaded;
-
- function Is_Power_Of_2_For_Shift
- (N : Node_Id) return Boolean is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Op_Expon);
- 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
- pragma Assert (False
- or else NT (N).Nkind = N_Selected_Component);
- return Flag17 (N);
- end Is_Prefixed_Call;
-
- function Is_Protected_Subprogram_Body
- (N : Node_Id) return Boolean is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Subprogram_Body);
- return Flag7 (N);
- end Is_Protected_Subprogram_Body;
-
- function Is_Qualified_Universal_Literal
- (N : Node_Id) return Boolean is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Qualified_Expression);
- return Flag4 (N);
- end Is_Qualified_Universal_Literal;
-
- function Is_Read
- (N : Node_Id) return Boolean is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Variable_Reference_Marker);
- return Flag4 (N);
- end Is_Read;
-
- function Is_Source_Call
- (N : Node_Id) return Boolean is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Call_Marker);
- return Flag4 (N);
- end Is_Source_Call;
-
- function Is_SPARK_Mode_On_Node
- (N : Node_Id) return Boolean is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Assignment_Statement
- or else NT (N).Nkind = N_Attribute_Reference
- or else NT (N).Nkind = N_Call_Marker
- or else NT (N).Nkind = N_Entry_Call_Statement
- or else NT (N).Nkind = N_Expanded_Name
- or else NT (N).Nkind = N_Function_Call
- or else NT (N).Nkind = N_Function_Instantiation
- or else NT (N).Nkind = N_Identifier
- or else NT (N).Nkind = N_Package_Instantiation
- or else NT (N).Nkind = N_Procedure_Call_Statement
- or else NT (N).Nkind = N_Procedure_Instantiation
- or else NT (N).Nkind = N_Requeue_Statement
- or else NT (N).Nkind = N_Variable_Reference_Marker);
- return Flag2 (N);
- end Is_SPARK_Mode_On_Node;
-
- function Is_Static_Coextension
- (N : Node_Id) return Boolean is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Allocator);
- return Flag14 (N);
- end Is_Static_Coextension;
-
- function Is_Static_Expression
- (N : Node_Id) return Boolean is
- begin
- pragma Assert (False
- or else NT (N).Nkind in N_Subexpr);
- return Flag6 (N);
- end Is_Static_Expression;
-
- function Is_Subprogram_Descriptor
- (N : Node_Id) return Boolean is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Object_Declaration);
- return Flag16 (N);
- end Is_Subprogram_Descriptor;
-
- function Is_Task_Allocation_Block
- (N : Node_Id) return Boolean is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Block_Statement);
- return Flag6 (N);
- end Is_Task_Allocation_Block;
-
- function Is_Task_Body_Procedure
- (N : Node_Id) return Boolean is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Subprogram_Body
- or else NT (N).Nkind = N_Subprogram_Declaration);
- return Flag1 (N);
- end Is_Task_Body_Procedure;
-
- function Is_Task_Master
- (N : Node_Id) return Boolean is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Block_Statement
- or else NT (N).Nkind = N_Subprogram_Body
- or else NT (N).Nkind = N_Task_Body);
- return Flag5 (N);
- end Is_Task_Master;
-
- function Is_Write
- (N : Node_Id) return Boolean is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Variable_Reference_Marker);
- 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
- pragma Assert (False
- or else NT (N).Nkind = N_Loop_Statement);
- return Node2 (N);
- end Iteration_Scheme;
-
- function Iterator_Specification
- (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);
- end Iterator_Specification;
-
- function Itype
- (N : Node_Id) return Node_Id is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Itype_Reference);
- 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
- pragma Assert (False
- or else NT (N).Nkind = N_Unchecked_Type_Conversion);
- return Flag11 (N);
- end Kill_Range_Check;
-
- function Label_Construct
- (N : Node_Id) return Node_Id is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Implicit_Label_Declaration);
- return Node2 (N);
- end Label_Construct;
-
- function Last_Bit
- (N : Node_Id) return Node_Id is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Component_Clause);
- return Node4 (N);
- end Last_Bit;
-
- function Last_Name
- (N : Node_Id) return Boolean is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_With_Clause);
- return Flag6 (N);
- end Last_Name;
-
- function Left_Opnd
- (N : Node_Id) return Node_Id is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_And_Then
- or else NT (N).Nkind = N_In
- or else NT (N).Nkind = N_Not_In
- or else NT (N).Nkind = N_Or_Else
- or else NT (N).Nkind in N_Binary_Op);
- return Node2 (N);
- end Left_Opnd;
-
- function Library_Unit
- (N : Node_Id) return Node_Id is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Compilation_Unit
- or else NT (N).Nkind = N_Package_Body_Stub
- or else NT (N).Nkind = N_Protected_Body_Stub
- or else NT (N).Nkind = N_Subprogram_Body_Stub
- or else NT (N).Nkind = N_Task_Body_Stub
- or else NT (N).Nkind = N_With_Clause);
- return Node4 (N);
- end Library_Unit;
-
- function Limited_View_Installed
- (N : Node_Id) return Boolean is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Package_Specification
- or else NT (N).Nkind = N_With_Clause);
- return Flag18 (N);
- end Limited_View_Installed;
-
- function Limited_Present
- (N : Node_Id) return Boolean is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Derived_Type_Definition
- or else NT (N).Nkind = N_Formal_Derived_Type_Definition
- or else NT (N).Nkind = N_Formal_Private_Type_Definition
- or else NT (N).Nkind = N_Private_Extension_Declaration
- or else NT (N).Nkind = N_Private_Type_Declaration
- or else NT (N).Nkind = N_Record_Definition
- or else NT (N).Nkind = N_With_Clause);
- return Flag17 (N);
- end Limited_Present;
-
- function Literals
- (N : Node_Id) return List_Id is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Enumeration_Type_Definition);
- return List1 (N);
- end Literals;
-
- function Local_Raise_Not_OK
- (N : Node_Id) return Boolean is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Exception_Handler);
- return Flag7 (N);
- end Local_Raise_Not_OK;
-
- function Local_Raise_Statements
- (N : Node_Id) return Elist_Id is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Exception_Handler);
- return Elist1 (N);
- end Local_Raise_Statements;
-
- function Loop_Actions
- (N : Node_Id) return List_Id is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Component_Association
- 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);
- end Loop_Parameter_Specification;
-
- function Low_Bound
- (N : Node_Id) return Node_Id is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Range
- or else NT (N).Nkind = N_Real_Range_Specification
- or else NT (N).Nkind = N_Signed_Integer_Type_Definition);
- return Node1 (N);
- end Low_Bound;
-
- function Mod_Clause
- (N : Node_Id) return Node_Id is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Record_Representation_Clause);
- return Node2 (N);
- end Mod_Clause;
-
- function More_Ids
- (N : Node_Id) return Boolean is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Component_Declaration
- or else NT (N).Nkind = N_Discriminant_Specification
- or else NT (N).Nkind = N_Exception_Declaration
- or else NT (N).Nkind = N_Formal_Object_Declaration
- or else NT (N).Nkind = N_Number_Declaration
- or else NT (N).Nkind = N_Object_Declaration
- or else NT (N).Nkind = N_Parameter_Specification
- or else NT (N).Nkind = N_Use_Package_Clause
- or else NT (N).Nkind = N_Use_Type_Clause);
- return Flag5 (N);
- end More_Ids;
-
- function Must_Be_Byte_Aligned
- (N : Node_Id) return Boolean is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Attribute_Reference);
- return Flag14 (N);
- end Must_Be_Byte_Aligned;
-
- function Must_Not_Freeze
- (N : Node_Id) return Boolean is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Subtype_Indication
- or else NT (N).Nkind in N_Subexpr);
- return Flag8 (N);
- end Must_Not_Freeze;
-
- function Must_Not_Override
- (N : Node_Id) return Boolean is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Entry_Declaration
- or else NT (N).Nkind = N_Function_Instantiation
- or else NT (N).Nkind = N_Function_Specification
- or else NT (N).Nkind = N_Procedure_Instantiation
- or else NT (N).Nkind = N_Procedure_Specification);
- return Flag15 (N);
- end Must_Not_Override;
-
- function Must_Override
- (N : Node_Id) return Boolean is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Entry_Declaration
- or else NT (N).Nkind = N_Function_Instantiation
- or else NT (N).Nkind = N_Function_Specification
- or else NT (N).Nkind = N_Procedure_Instantiation
- or else NT (N).Nkind = N_Procedure_Specification);
- return Flag14 (N);
- end Must_Override;
-
- function Name
- (N : Node_Id) return Node_Id is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Assignment_Statement
- or else NT (N).Nkind = N_Attribute_Definition_Clause
- or else NT (N).Nkind = N_Defining_Program_Unit_Name
- or else NT (N).Nkind = N_Designator
- or else NT (N).Nkind = N_Entry_Call_Statement
- or else NT (N).Nkind = N_Exception_Renaming_Declaration
- or else NT (N).Nkind = N_Exit_Statement
- or else NT (N).Nkind = N_Formal_Package_Declaration
- or else NT (N).Nkind = N_Function_Call
- or else NT (N).Nkind = N_Function_Instantiation
- or else NT (N).Nkind = N_Generic_Function_Renaming_Declaration
- or else NT (N).Nkind = N_Generic_Package_Renaming_Declaration
- or else NT (N).Nkind = N_Generic_Procedure_Renaming_Declaration
- or else NT (N).Nkind = N_Goto_Statement
- or else NT (N).Nkind = N_Iterator_Specification
- or else NT (N).Nkind = N_Object_Renaming_Declaration
- or else NT (N).Nkind = N_Package_Instantiation
- or else NT (N).Nkind = N_Package_Renaming_Declaration
- or else NT (N).Nkind = N_Procedure_Call_Statement
- or else NT (N).Nkind = N_Procedure_Instantiation
- or else NT (N).Nkind = N_Raise_Expression
- or else NT (N).Nkind = N_Raise_Statement
- or else NT (N).Nkind = N_Requeue_Statement
- or else NT (N).Nkind = N_Subprogram_Renaming_Declaration
- or else NT (N).Nkind = N_Subunit
- or else NT (N).Nkind = N_Use_Package_Clause
- or else NT (N).Nkind = N_Variant_Part
- or else NT (N).Nkind = N_With_Clause);
- return Node2 (N);
- end Name;
-
- function Names
- (N : Node_Id) return List_Id is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Abort_Statement);
- return List2 (N);
- end Names;
-
- function Next_Entity
- (N : Node_Id) return Node_Id is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Defining_Character_Literal
- or else NT (N).Nkind = N_Defining_Identifier
- or else NT (N).Nkind = N_Defining_Operator_Symbol);
- return Node2 (N);
- end Next_Entity;
-
- function Next_Exit_Statement
- (N : Node_Id) return Node_Id is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Exit_Statement);
- return Node3 (N);
- end Next_Exit_Statement;
-
- function Next_Implicit_With
- (N : Node_Id) return Node_Id is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_With_Clause);
- return Node3 (N);
- end Next_Implicit_With;
-
- function Next_Named_Actual
- (N : Node_Id) return Node_Id is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Parameter_Association);
- return Node4 (N);
- end Next_Named_Actual;
-
- function Next_Pragma
- (N : Node_Id) return Node_Id is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Pragma);
- return Node1 (N);
- end Next_Pragma;
-
- function Next_Rep_Item
- (N : Node_Id) return Node_Id is
- begin
- pragma Assert (False
- 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);
- end Next_Rep_Item;
-
- function Next_Use_Clause
- (N : Node_Id) return Node_Id is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Use_Package_Clause
- or else NT (N).Nkind = N_Use_Type_Clause);
- return Node3 (N);
- end Next_Use_Clause;
-
- function No_Ctrl_Actions
- (N : Node_Id) return Boolean is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Assignment_Statement);
- return Flag7 (N);
- end No_Ctrl_Actions;
-
- function No_Elaboration_Check
- (N : Node_Id) return Boolean is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Function_Call
- or else NT (N).Nkind = N_Procedure_Call_Statement);
- return Flag4 (N);
- end No_Elaboration_Check;
-
- function No_Entities_Ref_In_Spec
- (N : Node_Id) return Boolean is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_With_Clause);
- return Flag8 (N);
- end No_Entities_Ref_In_Spec;
-
- function No_Initialization
- (N : Node_Id) return Boolean is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Allocator
- or else NT (N).Nkind = N_Object_Declaration);
- return Flag13 (N);
- end No_Initialization;
-
- function No_Minimize_Eliminate
- (N : Node_Id) return Boolean is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_In
- or else NT (N).Nkind = N_Not_In);
- return Flag17 (N);
- end No_Minimize_Eliminate;
-
- function No_Side_Effect_Removal
- (N : Node_Id) return Boolean is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Function_Call);
- return Flag17 (N);
- end No_Side_Effect_Removal;
-
- function No_Truncation
- (N : Node_Id) return Boolean is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Unchecked_Type_Conversion);
- return Flag17 (N);
- end No_Truncation;
-
- function Null_Excluding_Subtype
- (N : Node_Id) return Boolean is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Access_To_Object_Definition);
- return Flag16 (N);
- end Null_Excluding_Subtype;
-
- function Null_Exclusion_Present
- (N : Node_Id) return Boolean is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Access_Definition
- or else NT (N).Nkind = N_Access_Function_Definition
- or else NT (N).Nkind = N_Access_Procedure_Definition
- or else NT (N).Nkind = N_Access_To_Object_Definition
- or else NT (N).Nkind = N_Allocator
- or else NT (N).Nkind = N_Component_Definition
- or else NT (N).Nkind = N_Derived_Type_Definition
- or else NT (N).Nkind = N_Discriminant_Specification
- or else NT (N).Nkind = N_Formal_Object_Declaration
- or else NT (N).Nkind = N_Function_Specification
- or else NT (N).Nkind = N_Object_Declaration
- or else NT (N).Nkind = N_Object_Renaming_Declaration
- or else NT (N).Nkind = N_Parameter_Specification
- or else NT (N).Nkind = N_Subtype_Declaration);
- return Flag11 (N);
- end Null_Exclusion_Present;
-
- function Null_Exclusion_In_Return_Present
- (N : Node_Id) return Boolean is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Access_Function_Definition);
- return Flag14 (N);
- end Null_Exclusion_In_Return_Present;
-
- function Null_Present
- (N : Node_Id) return Boolean is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Component_List
- or else NT (N).Nkind = N_Procedure_Specification
- or else NT (N).Nkind = N_Record_Definition);
- return Flag13 (N);
- end Null_Present;
-
- function Null_Record_Present
- (N : Node_Id) return Boolean is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Aggregate
- or else NT (N).Nkind = N_Extension_Aggregate);
- return Flag17 (N);
- end Null_Record_Present;
-
- function Null_Statement
- (N : Node_Id) return Node_Id is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Procedure_Specification);
- return Node2 (N);
- end Null_Statement;
-
- function Object_Definition
- (N : Node_Id) return Node_Id is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Object_Declaration);
- return Node4 (N);
- end Object_Definition;
-
- function Of_Present
- (N : Node_Id) return Boolean is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Iterator_Specification);
- return Flag16 (N);
- end Of_Present;
-
- function Original_Discriminant
- (N : Node_Id) return Node_Id is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Identifier);
- return Node2 (N);
- end Original_Discriminant;
-
- function Original_Entity
- (N : Node_Id) return Entity_Id is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Integer_Literal
- or else NT (N).Nkind = N_Real_Literal);
- return Node2 (N);
- end Original_Entity;
-
- function Others_Discrete_Choices
- (N : Node_Id) return List_Id is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Others_Choice);
- return List1 (N);
- end Others_Discrete_Choices;
-
- function Out_Present
- (N : Node_Id) return Boolean is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Formal_Object_Declaration
- or else NT (N).Nkind = N_Parameter_Specification);
- return Flag17 (N);
- end Out_Present;
-
- function Parameter_Associations
- (N : Node_Id) return List_Id is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Entry_Call_Statement
- or else NT (N).Nkind = N_Function_Call
- or else NT (N).Nkind = N_Procedure_Call_Statement);
- return List3 (N);
- end Parameter_Associations;
-
- function Parameter_Specifications
- (N : Node_Id) return List_Id is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Accept_Statement
- or else NT (N).Nkind = N_Access_Function_Definition
- or else NT (N).Nkind = N_Access_Procedure_Definition
- or else NT (N).Nkind = N_Entry_Body_Formal_Part
- or else NT (N).Nkind = N_Entry_Declaration
- or else NT (N).Nkind = N_Function_Specification
- or else NT (N).Nkind = N_Procedure_Specification);
- return List3 (N);
- end Parameter_Specifications;
-
- function Parameter_Type
- (N : Node_Id) return Node_Id is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Parameter_Specification);
- return Node2 (N);
- end Parameter_Type;
-
- function Parent_Spec
- (N : Node_Id) return Node_Id is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Function_Instantiation
- or else NT (N).Nkind = N_Generic_Function_Renaming_Declaration
- or else NT (N).Nkind = N_Generic_Package_Declaration
- or else NT (N).Nkind = N_Generic_Package_Renaming_Declaration
- or else NT (N).Nkind = N_Generic_Procedure_Renaming_Declaration
- or else NT (N).Nkind = N_Generic_Subprogram_Declaration
- or else NT (N).Nkind = N_Package_Declaration
- or else NT (N).Nkind = N_Package_Instantiation
- or else NT (N).Nkind = N_Package_Renaming_Declaration
- or else NT (N).Nkind = N_Procedure_Instantiation
- or else NT (N).Nkind = N_Subprogram_Declaration
- or else NT (N).Nkind = N_Subprogram_Renaming_Declaration);
- return Node4 (N);
- end Parent_Spec;
-
- function Parent_With
- (N : Node_Id) return Boolean is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_With_Clause);
- return Flag1 (N);
- end Parent_With;
-
- function Position
- (N : Node_Id) return Node_Id is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Component_Clause);
- return Node2 (N);
- end Position;
-
- function Pragma_Argument_Associations
- (N : Node_Id) return List_Id is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Pragma);
- return List2 (N);
- end Pragma_Argument_Associations;
-
- function Pragma_Identifier
- (N : Node_Id) return Node_Id is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Pragma);
- return Node4 (N);
- end Pragma_Identifier;
-
- function Pragmas_After
- (N : Node_Id) return List_Id is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Compilation_Unit_Aux
- or else NT (N).Nkind = N_Terminate_Alternative);
- return List5 (N);
- end Pragmas_After;
-
- function Pragmas_Before
- (N : Node_Id) return List_Id is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Accept_Alternative
- or else NT (N).Nkind = N_Delay_Alternative
- or else NT (N).Nkind = N_Entry_Call_Alternative
- or else NT (N).Nkind = N_Mod_Clause
- or else NT (N).Nkind = N_Terminate_Alternative
- or else NT (N).Nkind = N_Triggering_Alternative);
- return List4 (N);
- end Pragmas_Before;
-
- function Pre_Post_Conditions
- (N : Node_Id) return Node_Id is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Contract);
- return Node1 (N);
- end Pre_Post_Conditions;
-
- function Prefix
- (N : Node_Id) return Node_Id is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Attribute_Reference
- or else NT (N).Nkind = N_Expanded_Name
- or else NT (N).Nkind = N_Explicit_Dereference
- or else NT (N).Nkind = N_Indexed_Component
- or else NT (N).Nkind = N_Reference
- or else NT (N).Nkind = N_Selected_Component
- or else NT (N).Nkind = N_Slice);
- return Node3 (N);
- end Prefix;
-
- function Premature_Use
- (N : Node_Id) return Node_Id is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Incomplete_Type_Declaration);
- return Node5 (N);
- end Premature_Use;
-
- function Present_Expr
- (N : Node_Id) return Uint is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Variant);
- return Uint3 (N);
- end Present_Expr;
-
- function Prev_Ids
- (N : Node_Id) return Boolean is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Component_Declaration
- or else NT (N).Nkind = N_Discriminant_Specification
- or else NT (N).Nkind = N_Exception_Declaration
- or else NT (N).Nkind = N_Formal_Object_Declaration
- or else NT (N).Nkind = N_Number_Declaration
- or else NT (N).Nkind = N_Object_Declaration
- or else NT (N).Nkind = N_Parameter_Specification
- or else NT (N).Nkind = N_Use_Package_Clause
- or else NT (N).Nkind = N_Use_Type_Clause);
- return Flag6 (N);
- end Prev_Ids;
-
- function Prev_Use_Clause
- (N : Node_Id) return Node_Id is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Use_Package_Clause
- or else NT (N).Nkind = N_Use_Type_Clause);
- return Node1 (N);
- end Prev_Use_Clause;
-
- function Print_In_Hex
- (N : Node_Id) return Boolean is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Integer_Literal);
- return Flag13 (N);
- end Print_In_Hex;
-
- function Private_Declarations
- (N : Node_Id) return List_Id is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Package_Specification
- or else NT (N).Nkind = N_Protected_Definition
- or else NT (N).Nkind = N_Task_Definition);
- return List3 (N);
- end Private_Declarations;
-
- function Private_Present
- (N : Node_Id) return Boolean is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Compilation_Unit
- or else NT (N).Nkind = N_Formal_Derived_Type_Definition
- or else NT (N).Nkind = N_With_Clause);
- return Flag15 (N);
- end Private_Present;
-
- function Procedure_To_Call
- (N : Node_Id) return Node_Id is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Allocator
- or else NT (N).Nkind = N_Extended_Return_Statement
- or else NT (N).Nkind = N_Free_Statement
- or else NT (N).Nkind = N_Simple_Return_Statement);
- return Node2 (N);
- end Procedure_To_Call;
-
- function Proper_Body
- (N : Node_Id) return Node_Id is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Subunit);
- return Node1 (N);
- end Proper_Body;
-
- function Protected_Definition
- (N : Node_Id) return Node_Id is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Protected_Type_Declaration
- or else NT (N).Nkind = N_Single_Protected_Declaration);
- return Node3 (N);
- end Protected_Definition;
-
- function Protected_Present
- (N : Node_Id) return Boolean is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Access_Function_Definition
- or else NT (N).Nkind = N_Access_Procedure_Definition
- or else NT (N).Nkind = N_Derived_Type_Definition
- or else NT (N).Nkind = N_Record_Definition);
- return Flag6 (N);
- end Protected_Present;
-
- function Raises_Constraint_Error
- (N : Node_Id) return Boolean is
- begin
- pragma Assert (False
- or else NT (N).Nkind in N_Subexpr);
- return Flag7 (N);
- end Raises_Constraint_Error;
-
- function Range_Constraint
- (N : Node_Id) return Node_Id is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Delta_Constraint
- or else NT (N).Nkind = N_Digits_Constraint);
- return Node4 (N);
- end Range_Constraint;
-
- function Range_Expression
- (N : Node_Id) return Node_Id is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Range_Constraint);
- return Node4 (N);
- end Range_Expression;
-
- function Real_Range_Specification
- (N : Node_Id) return Node_Id is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Decimal_Fixed_Point_Definition
- or else NT (N).Nkind = N_Floating_Point_Definition
- or else NT (N).Nkind = N_Ordinary_Fixed_Point_Definition);
- return Node4 (N);
- end Real_Range_Specification;
-
- function Realval
- (N : Node_Id) return Ureal is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Real_Literal);
- return Ureal3 (N);
- end Realval;
-
- function Reason
- (N : Node_Id) return Uint is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Raise_Constraint_Error
- or else NT (N).Nkind = N_Raise_Program_Error
- or else NT (N).Nkind = N_Raise_Storage_Error);
- return Uint3 (N);
- end Reason;
-
- function Record_Extension_Part
- (N : Node_Id) return Node_Id is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Derived_Type_Definition);
- return Node3 (N);
- end Record_Extension_Part;
-
- function Redundant_Use
- (N : Node_Id) return Boolean is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Attribute_Reference
- or else NT (N).Nkind = N_Expanded_Name
- or else NT (N).Nkind = N_Identifier);
- return Flag13 (N);
- end Redundant_Use;
-
- function Renaming_Exception
- (N : Node_Id) return Node_Id is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Exception_Declaration);
- return Node2 (N);
- end Renaming_Exception;
-
- function Result_Definition
- (N : Node_Id) return Node_Id is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Access_Function_Definition
- or else NT (N).Nkind = N_Function_Specification);
- return Node4 (N);
- end Result_Definition;
-
- function Return_Object_Declarations
- (N : Node_Id) return List_Id is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Extended_Return_Statement);
- return List3 (N);
- end Return_Object_Declarations;
-
- function Return_Statement_Entity
- (N : Node_Id) return Node_Id is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Extended_Return_Statement
- or else NT (N).Nkind = N_Simple_Return_Statement);
- return Node5 (N);
- end Return_Statement_Entity;
-
- function Reverse_Present
- (N : Node_Id) return Boolean is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Iterator_Specification
- or else NT (N).Nkind = N_Loop_Parameter_Specification);
- return Flag15 (N);
- end Reverse_Present;
-
- function Right_Opnd
- (N : Node_Id) return Node_Id is
- begin
- pragma Assert (False
- or else NT (N).Nkind in N_Op
- or else NT (N).Nkind = N_And_Then
- or else NT (N).Nkind = N_In
- or else NT (N).Nkind = N_Not_In
- or else NT (N).Nkind = N_Or_Else);
- return Node3 (N);
- end Right_Opnd;
-
- function Rounded_Result
- (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_Multiply
- or else NT (N).Nkind = N_Type_Conversion);
- return Flag18 (N);
- end Rounded_Result;
-
- function Save_Invocation_Graph_Of_Body
- (N : Node_Id) return Boolean is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Compilation_Unit);
- return Flag1 (N);
- end Save_Invocation_Graph_Of_Body;
-
- function SCIL_Controlling_Tag
- (N : Node_Id) return Node_Id is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_SCIL_Dispatching_Call);
- return Node5 (N);
- end SCIL_Controlling_Tag;
-
- function SCIL_Entity
- (N : Node_Id) return Node_Id is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_SCIL_Dispatch_Table_Tag_Init
- or else NT (N).Nkind = N_SCIL_Dispatching_Call
- or else NT (N).Nkind = N_SCIL_Membership_Test);
- return Node4 (N);
- end SCIL_Entity;
-
- function SCIL_Tag_Value
- (N : Node_Id) return Node_Id is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_SCIL_Membership_Test);
- return Node5 (N);
- end SCIL_Tag_Value;
-
- function SCIL_Target_Prim
- (N : Node_Id) return Node_Id is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_SCIL_Dispatching_Call);
- return Node2 (N);
- end SCIL_Target_Prim;
-
- function Scope
- (N : Node_Id) return Node_Id is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Defining_Character_Literal
- or else NT (N).Nkind = N_Defining_Identifier
- or else NT (N).Nkind = N_Defining_Operator_Symbol);
- return Node3 (N);
- end Scope;
-
- function Select_Alternatives
- (N : Node_Id) return List_Id is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Selective_Accept);
- return List1 (N);
- end Select_Alternatives;
-
- function Selector_Name
- (N : Node_Id) return Node_Id is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Expanded_Name
- or else NT (N).Nkind = N_Generic_Association
- or else NT (N).Nkind = N_Parameter_Association
- or else NT (N).Nkind = N_Selected_Component);
- return Node2 (N);
- end Selector_Name;
-
- function Selector_Names
- (N : Node_Id) return List_Id is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Discriminant_Association);
- return List1 (N);
- end Selector_Names;
-
- function Shift_Count_OK
- (N : Node_Id) return Boolean is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Op_Rotate_Left
- or else NT (N).Nkind = N_Op_Rotate_Right
- or else NT (N).Nkind = N_Op_Shift_Left
- or else NT (N).Nkind = N_Op_Shift_Right
- or else NT (N).Nkind = N_Op_Shift_Right_Arithmetic);
- return Flag4 (N);
- end Shift_Count_OK;
-
- function Source_Type
- (N : Node_Id) return Entity_Id is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Validate_Unchecked_Conversion);
- return Node1 (N);
- end Source_Type;
-
- function Specification
- (N : Node_Id) return Node_Id is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Abstract_Subprogram_Declaration
- or else NT (N).Nkind = N_Expression_Function
- or else NT (N).Nkind = N_Formal_Abstract_Subprogram_Declaration
- or else NT (N).Nkind = N_Formal_Concrete_Subprogram_Declaration
- or else NT (N).Nkind = N_Generic_Package_Declaration
- or else NT (N).Nkind = N_Generic_Subprogram_Declaration
- or else NT (N).Nkind = N_Package_Declaration
- or else NT (N).Nkind = N_Subprogram_Body
- or else NT (N).Nkind = N_Subprogram_Body_Stub
- or else NT (N).Nkind = N_Subprogram_Declaration
- or else NT (N).Nkind = N_Subprogram_Renaming_Declaration);
- return Node1 (N);
- end Specification;
-
- function Split_PPC
- (N : Node_Id) return Boolean is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Aspect_Specification
- or else NT (N).Nkind = N_Pragma);
- return Flag17 (N);
- end Split_PPC;
-
- function Statements
- (N : Node_Id) return List_Id is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Abortable_Part
- or else NT (N).Nkind = N_Accept_Alternative
- or else NT (N).Nkind = N_Case_Statement_Alternative
- or else NT (N).Nkind = N_Delay_Alternative
- or else NT (N).Nkind = N_Entry_Call_Alternative
- or else NT (N).Nkind = N_Exception_Handler
- or else NT (N).Nkind = N_Handled_Sequence_Of_Statements
- or else NT (N).Nkind = N_Loop_Statement
- or else NT (N).Nkind = N_Triggering_Alternative);
- return List3 (N);
- end Statements;
-
- function Storage_Pool
- (N : Node_Id) return Node_Id is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Allocator
- or else NT (N).Nkind = N_Extended_Return_Statement
- or else NT (N).Nkind = N_Free_Statement
- or else NT (N).Nkind = N_Simple_Return_Statement);
- return Node1 (N);
- end Storage_Pool;
-
- function Subpool_Handle_Name
- (N : Node_Id) return Node_Id is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Allocator);
- return Node4 (N);
- end Subpool_Handle_Name;
-
- function Strval
- (N : Node_Id) return String_Id is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Operator_Symbol
- or else NT (N).Nkind = N_String_Literal);
- return Str3 (N);
- end Strval;
-
- function Subtype_Indication
- (N : Node_Id) return Node_Id is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Access_To_Object_Definition
- or else NT (N).Nkind = N_Component_Definition
- or else NT (N).Nkind = N_Derived_Type_Definition
- or else NT (N).Nkind = N_Iterator_Specification
- or else NT (N).Nkind = N_Private_Extension_Declaration
- or else NT (N).Nkind = N_Subtype_Declaration);
- return Node5 (N);
- end Subtype_Indication;
-
- function Suppress_Assignment_Checks
- (N : Node_Id) return Boolean is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Assignment_Statement
- or else NT (N).Nkind = N_Object_Declaration);
- return Flag18 (N);
- end Suppress_Assignment_Checks;
-
- function Suppress_Loop_Warnings
- (N : Node_Id) return Boolean is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Loop_Statement);
- return Flag17 (N);
- end Suppress_Loop_Warnings;
-
- function Subtype_Mark
- (N : Node_Id) return Node_Id is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Access_Definition
- or else NT (N).Nkind = N_Formal_Derived_Type_Definition
- or else NT (N).Nkind = N_Formal_Object_Declaration
- or else NT (N).Nkind = N_Object_Renaming_Declaration
- or else NT (N).Nkind = N_Qualified_Expression
- or else NT (N).Nkind = N_Subtype_Indication
- or else NT (N).Nkind = N_Type_Conversion
- or else NT (N).Nkind = N_Unchecked_Type_Conversion
- or else NT (N).Nkind = N_Use_Type_Clause);
- return Node4 (N);
- end Subtype_Mark;
-
- function Subtype_Marks
- (N : Node_Id) return List_Id is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Unconstrained_Array_Definition);
- return List2 (N);
- end Subtype_Marks;
-
- function Synchronized_Present
- (N : Node_Id) return Boolean is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Derived_Type_Definition
- or else NT (N).Nkind = N_Formal_Derived_Type_Definition
- or else NT (N).Nkind = N_Private_Extension_Declaration
- or else NT (N).Nkind = N_Record_Definition);
- return Flag7 (N);
- end Synchronized_Present;
-
- function Tagged_Present
- (N : Node_Id) return Boolean is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Formal_Incomplete_Type_Definition
- or else NT (N).Nkind = N_Formal_Private_Type_Definition
- or else NT (N).Nkind = N_Incomplete_Type_Declaration
- or else NT (N).Nkind = N_Private_Type_Declaration
- or else NT (N).Nkind = N_Record_Definition);
- return Flag15 (N);
- end Tagged_Present;
-
- function Target
- (N : Node_Id) return Entity_Id is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Call_Marker
- or else NT (N).Nkind = N_Variable_Reference_Marker);
- return Node1 (N);
- end Target;
-
- function Target_Type
- (N : Node_Id) return Entity_Id is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Validate_Unchecked_Conversion);
- return Node2 (N);
- end Target_Type;
-
- function Task_Definition
- (N : Node_Id) return Node_Id is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Single_Task_Declaration
- or else NT (N).Nkind = N_Task_Type_Declaration);
- return Node3 (N);
- end Task_Definition;
-
- function Task_Present
- (N : Node_Id) return Boolean is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Derived_Type_Definition
- or else NT (N).Nkind = N_Record_Definition);
- return Flag5 (N);
- end Task_Present;
-
- function Then_Actions
- (N : Node_Id) return List_Id is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_If_Expression);
- return List2 (N);
- end Then_Actions;
-
- function Then_Statements
- (N : Node_Id) return List_Id is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Elsif_Part
- or else NT (N).Nkind = N_If_Statement);
- return List2 (N);
- end Then_Statements;
-
- function Triggering_Alternative
- (N : Node_Id) return Node_Id is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Asynchronous_Select);
- return Node1 (N);
- end Triggering_Alternative;
-
- function Triggering_Statement
- (N : Node_Id) return Node_Id is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Triggering_Alternative);
- return Node1 (N);
- end Triggering_Statement;
-
- function TSS_Elist
- (N : Node_Id) return Elist_Id is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Freeze_Entity);
- return Elist3 (N);
- end TSS_Elist;
-
- function Type_Definition
- (N : Node_Id) return Node_Id is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Full_Type_Declaration);
- return Node3 (N);
- end Type_Definition;
-
- function Uneval_Old_Accept
- (N : Node_Id) return Boolean is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Pragma);
- return Flag7 (N);
- end Uneval_Old_Accept;
-
- function Uneval_Old_Warn
- (N : Node_Id) return Boolean is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Pragma);
- return Flag18 (N);
- end Uneval_Old_Warn;
-
- function Unit
- (N : Node_Id) return Node_Id is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Compilation_Unit);
- return Node2 (N);
- end Unit;
-
- function Unknown_Discriminants_Present
- (N : Node_Id) return Boolean is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Formal_Type_Declaration
- or else NT (N).Nkind = N_Incomplete_Type_Declaration
- or else NT (N).Nkind = N_Private_Extension_Declaration
- or else NT (N).Nkind = N_Private_Type_Declaration);
- return Flag13 (N);
- end Unknown_Discriminants_Present;
-
- function Unreferenced_In_Spec
- (N : Node_Id) return Boolean is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_With_Clause);
- return Flag7 (N);
- end Unreferenced_In_Spec;
-
- function Variant_Part
- (N : Node_Id) return Node_Id is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Component_List);
- return Node4 (N);
- end Variant_Part;
-
- function Variants
- (N : Node_Id) return List_Id is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Variant_Part);
- return List1 (N);
- end Variants;
-
- function Visible_Declarations
- (N : Node_Id) return List_Id is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Package_Specification
- or else NT (N).Nkind = N_Protected_Definition
- or else NT (N).Nkind = N_Task_Definition);
- return List2 (N);
- end Visible_Declarations;
-
- function Uninitialized_Variable
- (N : Node_Id) return Node_Id is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Formal_Private_Type_Definition
- or else NT (N).Nkind = N_Private_Extension_Declaration);
- return Node3 (N);
- end Uninitialized_Variable;
-
- function Used_Operations
- (N : Node_Id) return Elist_Id is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Use_Type_Clause);
- return Elist2 (N);
- end Used_Operations;
-
- function Was_Attribute_Reference
- (N : Node_Id) return Boolean is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Subprogram_Body);
- return Flag2 (N);
- end Was_Attribute_Reference;
-
- function Was_Default_Init_Box_Association
- (N : Node_Id) return Boolean is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Component_Association);
- return Flag14 (N);
- end Was_Default_Init_Box_Association;
-
- function Was_Expression_Function
- (N : Node_Id) return Boolean is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Subprogram_Body);
- return Flag18 (N);
- end Was_Expression_Function;
-
- function Was_Originally_Stub
- (N : Node_Id) return Boolean is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Package_Body
- or else NT (N).Nkind = N_Protected_Body
- or else NT (N).Nkind = N_Subprogram_Body
- or else NT (N).Nkind = N_Task_Body);
- return Flag13 (N);
- end Was_Originally_Stub;
-
- --------------------------
- -- Field Set Procedures --
- --------------------------
-
- procedure Set_Abort_Present
- (N : Node_Id; Val : Boolean := True) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Requeue_Statement);
- Set_Flag15 (N, Val);
- end Set_Abort_Present;
-
- procedure Set_Abortable_Part
- (N : Node_Id; Val : Node_Id) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Asynchronous_Select);
- Set_Node2_With_Parent (N, Val);
- end Set_Abortable_Part;
-
- procedure Set_Abstract_Present
- (N : Node_Id; Val : Boolean := True) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Derived_Type_Definition
- or else NT (N).Nkind = N_Formal_Derived_Type_Definition
- or else NT (N).Nkind = N_Formal_Private_Type_Definition
- or else NT (N).Nkind = N_Private_Extension_Declaration
- or else NT (N).Nkind = N_Private_Type_Declaration
- or else NT (N).Nkind = N_Record_Definition);
- Set_Flag4 (N, Val);
- end Set_Abstract_Present;
-
- procedure Set_Accept_Handler_Records
- (N : Node_Id; Val : List_Id) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Accept_Alternative);
- Set_List5 (N, Val); -- semantic field, no parent set
- end Set_Accept_Handler_Records;
-
- procedure Set_Accept_Statement
- (N : Node_Id; Val : Node_Id) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Accept_Alternative);
- Set_Node2_With_Parent (N, Val);
- end Set_Accept_Statement;
-
- procedure Set_Access_Definition
- (N : Node_Id; Val : Node_Id) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Component_Definition
- or else NT (N).Nkind = N_Formal_Object_Declaration
- or else NT (N).Nkind = N_Object_Renaming_Declaration);
- Set_Node3_With_Parent (N, Val);
- end Set_Access_Definition;
-
- procedure Set_Access_To_Subprogram_Definition
- (N : Node_Id; Val : Node_Id) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Access_Definition);
- Set_Node3_With_Parent (N, Val);
- end Set_Access_To_Subprogram_Definition;
-
- procedure Set_Access_Types_To_Process
- (N : Node_Id; Val : Elist_Id) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Freeze_Entity);
- Set_Elist2 (N, Val); -- semantic field, no parent set
- end Set_Access_Types_To_Process;
-
- procedure Set_Actions
- (N : Node_Id; Val : List_Id) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_And_Then
- or else NT (N).Nkind = N_Case_Expression_Alternative
- or else NT (N).Nkind = N_Compilation_Unit_Aux
- or else NT (N).Nkind = N_Compound_Statement
- or else NT (N).Nkind = N_Expression_With_Actions
- or else NT (N).Nkind = N_Freeze_Entity
- or else NT (N).Nkind = N_Or_Else);
- Set_List1_With_Parent (N, Val);
- end Set_Actions;
-
- procedure Set_Activation_Chain_Entity
- (N : Node_Id; Val : Node_Id) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Block_Statement
- or else NT (N).Nkind = N_Entry_Body
- or else NT (N).Nkind = N_Generic_Package_Declaration
- or else NT (N).Nkind = N_Package_Declaration
- or else NT (N).Nkind = N_Subprogram_Body
- or else NT (N).Nkind = N_Task_Body);
- Set_Node3 (N, Val); -- semantic field, no parent set
- end Set_Activation_Chain_Entity;
-
- procedure Set_Acts_As_Spec
- (N : Node_Id; Val : Boolean := True) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Compilation_Unit
- or else NT (N).Nkind = N_Subprogram_Body);
- Set_Flag4 (N, Val);
- end Set_Acts_As_Spec;
-
- procedure Set_Actual_Designated_Subtype
- (N : Node_Id; Val : Node_Id) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Explicit_Dereference
- or else NT (N).Nkind = N_Free_Statement);
- Set_Node4 (N, Val);
- end Set_Actual_Designated_Subtype;
-
- procedure Set_Address_Warning_Posted
- (N : Node_Id; Val : Boolean := True) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Attribute_Definition_Clause);
- Set_Flag18 (N, Val);
- end Set_Address_Warning_Posted;
-
- procedure Set_Aggregate_Bounds
- (N : Node_Id; Val : Node_Id) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Aggregate);
- Set_Node3 (N, Val); -- semantic field, no parent set
- end Set_Aggregate_Bounds;
-
- procedure Set_Aliased_Present
- (N : Node_Id; Val : Boolean := True) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Component_Definition
- or else NT (N).Nkind = N_Object_Declaration
- or else NT (N).Nkind = N_Parameter_Specification);
- Set_Flag4 (N, Val);
- end Set_Aliased_Present;
-
- procedure Set_Alloc_For_BIP_Return
- (N : Node_Id; Val : Boolean := True) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Allocator);
- Set_Flag1 (N, Val);
- end Set_Alloc_For_BIP_Return;
-
- procedure Set_All_Others
- (N : Node_Id; Val : Boolean := True) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Others_Choice);
- Set_Flag11 (N, Val);
- end Set_All_Others;
-
- procedure Set_All_Present
- (N : Node_Id; Val : Boolean := True) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Access_Definition
- or else NT (N).Nkind = N_Access_To_Object_Definition
- or else NT (N).Nkind = N_Quantified_Expression
- or else NT (N).Nkind = N_Use_Type_Clause);
- Set_Flag15 (N, Val);
- end Set_All_Present;
-
- procedure Set_Alternatives
- (N : Node_Id; Val : List_Id) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Case_Expression
- or else NT (N).Nkind = N_Case_Statement
- or else NT (N).Nkind = N_In
- or else NT (N).Nkind = N_Not_In);
- Set_List4_With_Parent (N, Val);
- end Set_Alternatives;
-
- procedure Set_Ancestor_Part
- (N : Node_Id; Val : Node_Id) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Extension_Aggregate);
- Set_Node3_With_Parent (N, Val);
- end Set_Ancestor_Part;
-
- procedure Set_Atomic_Sync_Required
- (N : Node_Id; Val : Boolean := True) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Expanded_Name
- or else NT (N).Nkind = N_Explicit_Dereference
- or else NT (N).Nkind = N_Identifier
- or else NT (N).Nkind = N_Indexed_Component
- or else NT (N).Nkind = N_Selected_Component);
- Set_Flag14 (N, Val);
- end Set_Atomic_Sync_Required;
-
- procedure Set_Array_Aggregate
- (N : Node_Id; Val : Node_Id) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Enumeration_Representation_Clause);
- Set_Node3_With_Parent (N, Val);
- end Set_Array_Aggregate;
-
- procedure Set_Aspect_On_Partial_View
- (N : Node_Id; Val : Boolean := True) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Aspect_Specification);
- Set_Flag18 (N, Val);
- end Set_Aspect_On_Partial_View;
-
- procedure Set_Aspect_Rep_Item
- (N : Node_Id; Val : Node_Id) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Aspect_Specification);
- Set_Node2 (N, Val);
- end Set_Aspect_Rep_Item;
-
- procedure Set_Assignment_OK
- (N : Node_Id; Val : Boolean := True) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Object_Declaration
- or else NT (N).Nkind in N_Subexpr);
- Set_Flag15 (N, Val);
- end Set_Assignment_OK;
-
- procedure Set_Associated_Node
- (N : Node_Id; Val : Node_Id) is
- begin
- pragma Assert (False
- or else NT (N).Nkind in N_Has_Entity
- or else NT (N).Nkind = N_Aggregate
- or else NT (N).Nkind = N_Extension_Aggregate
- or else NT (N).Nkind = N_Selected_Component
- or else NT (N).Nkind = N_Use_Package_Clause);
- Set_Node4 (N, Val); -- semantic field, no parent set
- end Set_Associated_Node;
-
- procedure Set_At_End_Proc
- (N : Node_Id; Val : Node_Id) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Handled_Sequence_Of_Statements);
- Set_Node1 (N, Val);
- end Set_At_End_Proc;
-
- procedure Set_Attribute_Name
- (N : Node_Id; Val : Name_Id) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Attribute_Reference);
- Set_Name2 (N, Val);
- end Set_Attribute_Name;
-
- procedure Set_Aux_Decls_Node
- (N : Node_Id; Val : Node_Id) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Compilation_Unit);
- Set_Node5_With_Parent (N, Val);
- end Set_Aux_Decls_Node;
-
- procedure Set_Backwards_OK
- (N : Node_Id; Val : Boolean := True) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Assignment_Statement);
- Set_Flag6 (N, Val);
- end Set_Backwards_OK;
-
- procedure Set_Bad_Is_Detected
- (N : Node_Id; Val : Boolean := True) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Subprogram_Body);
- Set_Flag15 (N, Val);
- end Set_Bad_Is_Detected;
-
- procedure Set_Body_Required
- (N : Node_Id; Val : Boolean := True) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Compilation_Unit);
- Set_Flag13 (N, Val);
- end Set_Body_Required;
-
- procedure Set_Body_To_Inline
- (N : Node_Id; Val : Node_Id) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Subprogram_Declaration);
- Set_Node3 (N, Val);
- end Set_Body_To_Inline;
-
- procedure Set_Box_Present
- (N : Node_Id; Val : Boolean := True) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Component_Association
- or else NT (N).Nkind = N_Formal_Abstract_Subprogram_Declaration
- or else NT (N).Nkind = N_Formal_Concrete_Subprogram_Declaration
- or else NT (N).Nkind = N_Formal_Package_Declaration
- or else NT (N).Nkind = N_Generic_Association
- or else NT (N).Nkind = N_Iterated_Component_Association
- or else NT (N).Nkind = N_Iterated_Element_Association);
- Set_Flag15 (N, Val);
- end Set_Box_Present;
-
- procedure Set_By_Ref
- (N : Node_Id; Val : Boolean := True) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Extended_Return_Statement
- or else NT (N).Nkind = N_Simple_Return_Statement);
- Set_Flag5 (N, Val);
- end Set_By_Ref;
-
- procedure Set_Char_Literal_Value
- (N : Node_Id; Val : Uint) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Character_Literal);
- Set_Uint2 (N, Val);
- end Set_Char_Literal_Value;
-
- procedure Set_Chars
- (N : Node_Id; Val : Name_Id) is
- begin
- pragma Assert (False
- or else NT (N).Nkind in N_Has_Chars);
- Set_Name1 (N, Val);
- end Set_Chars;
-
- procedure Set_Check_Address_Alignment
- (N : Node_Id; Val : Boolean := True) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Attribute_Definition_Clause);
- Set_Flag11 (N, Val);
- end Set_Check_Address_Alignment;
-
- procedure Set_Choice_Parameter
- (N : Node_Id; Val : Node_Id) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Exception_Handler);
- Set_Node2_With_Parent (N, Val);
- end Set_Choice_Parameter;
-
- procedure Set_Choices
- (N : Node_Id; Val : List_Id) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Component_Association);
- Set_List1_With_Parent (N, Val);
- end Set_Choices;
-
- procedure Set_Class_Present
- (N : Node_Id; Val : Boolean := True) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Aspect_Specification
- or else NT (N).Nkind = N_Pragma);
- Set_Flag6 (N, Val);
- end Set_Class_Present;
-
- procedure Set_Classifications
- (N : Node_Id; Val : Node_Id) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Contract);
- Set_Node3 (N, Val); -- semantic field, no parent set
- end Set_Classifications;
-
- procedure Set_Cleanup_Actions
- (N : Node_Id; Val : List_Id) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Block_Statement);
- Set_List5 (N, Val); -- semantic field, no parent set
- end Set_Cleanup_Actions;
-
- procedure Set_Comes_From_Extended_Return_Statement
- (N : Node_Id; Val : Boolean := True) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Simple_Return_Statement);
- Set_Flag18 (N, Val);
- end Set_Comes_From_Extended_Return_Statement;
-
- procedure Set_Compile_Time_Known_Aggregate
- (N : Node_Id; Val : Boolean := True) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Aggregate);
- Set_Flag18 (N, Val);
- end Set_Compile_Time_Known_Aggregate;
-
- procedure Set_Component_Associations
- (N : Node_Id; Val : List_Id) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Aggregate
- or else NT (N).Nkind = N_Delta_Aggregate
- or else NT (N).Nkind = N_Extension_Aggregate);
- Set_List2_With_Parent (N, Val);
- end Set_Component_Associations;
-
- procedure Set_Component_Clauses
- (N : Node_Id; Val : List_Id) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Record_Representation_Clause);
- Set_List3_With_Parent (N, Val);
- end Set_Component_Clauses;
-
- procedure Set_Component_Definition
- (N : Node_Id; Val : Node_Id) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Component_Declaration
- or else NT (N).Nkind = N_Constrained_Array_Definition
- or else NT (N).Nkind = N_Unconstrained_Array_Definition);
- Set_Node4_With_Parent (N, Val);
- end Set_Component_Definition;
-
- procedure Set_Component_Items
- (N : Node_Id; Val : List_Id) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Component_List);
- Set_List3_With_Parent (N, Val);
- end Set_Component_Items;
-
- procedure Set_Component_List
- (N : Node_Id; Val : Node_Id) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Record_Definition
- or else NT (N).Nkind = N_Variant);
- Set_Node1_With_Parent (N, Val);
- end Set_Component_List;
-
- procedure Set_Component_Name
- (N : Node_Id; Val : Node_Id) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Component_Clause);
- Set_Node1_With_Parent (N, Val);
- end Set_Component_Name;
-
- procedure Set_Componentwise_Assignment
- (N : Node_Id; Val : Boolean := True) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Assignment_Statement);
- Set_Flag14 (N, Val);
- end Set_Componentwise_Assignment;
-
- procedure Set_Condition
- (N : Node_Id; Val : Node_Id) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Accept_Alternative
- or else NT (N).Nkind = N_Delay_Alternative
- or else NT (N).Nkind = N_Elsif_Part
- or else NT (N).Nkind = N_Entry_Body_Formal_Part
- or else NT (N).Nkind = N_Exit_Statement
- or else NT (N).Nkind = N_If_Statement
- or else NT (N).Nkind = N_Iteration_Scheme
- or else NT (N).Nkind = N_Quantified_Expression
- or else NT (N).Nkind = N_Raise_Constraint_Error
- or else NT (N).Nkind = N_Raise_Program_Error
- or else NT (N).Nkind = N_Raise_Storage_Error
- or else NT (N).Nkind = N_Terminate_Alternative);
- Set_Node1_With_Parent (N, Val);
- end Set_Condition;
-
- procedure Set_Condition_Actions
- (N : Node_Id; Val : List_Id) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Elsif_Part
- or else NT (N).Nkind = N_Iteration_Scheme);
- Set_List3 (N, Val); -- semantic field, no parent set
- end Set_Condition_Actions;
-
- procedure Set_Config_Pragmas
- (N : Node_Id; Val : List_Id) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Compilation_Unit_Aux);
- Set_List4_With_Parent (N, Val);
- end Set_Config_Pragmas;
-
- procedure Set_Constant_Present
- (N : Node_Id; Val : Boolean := True) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Access_Definition
- or else NT (N).Nkind = N_Access_To_Object_Definition
- or else NT (N).Nkind = N_Object_Declaration);
- Set_Flag17 (N, Val);
- end Set_Constant_Present;
-
- procedure Set_Constraint
- (N : Node_Id; Val : Node_Id) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Subtype_Indication);
- Set_Node3_With_Parent (N, Val);
- end Set_Constraint;
-
- procedure Set_Constraints
- (N : Node_Id; Val : List_Id) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Index_Or_Discriminant_Constraint);
- Set_List1_With_Parent (N, Val);
- end Set_Constraints;
-
- procedure Set_Context_Installed
- (N : Node_Id; Val : Boolean := True) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_With_Clause);
- Set_Flag13 (N, Val);
- end Set_Context_Installed;
-
- procedure Set_Context_Items
- (N : Node_Id; Val : List_Id) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Compilation_Unit);
- Set_List1_With_Parent (N, Val);
- end Set_Context_Items;
-
- procedure Set_Context_Pending
- (N : Node_Id; Val : Boolean := True) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Compilation_Unit);
- Set_Flag16 (N, Val);
- end Set_Context_Pending;
-
- procedure Set_Contract_Test_Cases
- (N : Node_Id; Val : Node_Id) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Contract);
- Set_Node2 (N, Val); -- semantic field, no parent set
- end Set_Contract_Test_Cases;
-
- procedure Set_Controlling_Argument
- (N : Node_Id; Val : Node_Id) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Function_Call
- or else NT (N).Nkind = N_Procedure_Call_Statement);
- Set_Node1 (N, Val); -- semantic field, no parent set
- end Set_Controlling_Argument;
-
- procedure Set_Conversion_OK
- (N : Node_Id; Val : Boolean := True) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Type_Conversion);
- Set_Flag14 (N, Val);
- end Set_Conversion_OK;
-
- procedure Set_Convert_To_Return_False
- (N : Node_Id; Val : Boolean := True) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Raise_Expression);
- Set_Flag13 (N, Val);
- end Set_Convert_To_Return_False;
-
- procedure Set_Corresponding_Aspect
- (N : Node_Id; Val : Node_Id) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Pragma);
- Set_Node3 (N, Val);
- end Set_Corresponding_Aspect;
-
- procedure Set_Corresponding_Body
- (N : Node_Id; Val : Node_Id) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Entry_Declaration
- or else NT (N).Nkind = N_Generic_Package_Declaration
- or else NT (N).Nkind = N_Generic_Subprogram_Declaration
- or else NT (N).Nkind = N_Package_Body_Stub
- or else NT (N).Nkind = N_Package_Declaration
- or else NT (N).Nkind = N_Protected_Body_Stub
- or else NT (N).Nkind = N_Protected_Type_Declaration
- or else NT (N).Nkind = N_Subprogram_Body_Stub
- or else NT (N).Nkind = N_Subprogram_Declaration
- or else NT (N).Nkind = N_Task_Body_Stub
- or else NT (N).Nkind = N_Task_Type_Declaration);
- Set_Node5 (N, Val); -- semantic field, no parent set
- end Set_Corresponding_Body;
-
- procedure Set_Corresponding_Formal_Spec
- (N : Node_Id; Val : Node_Id) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Subprogram_Renaming_Declaration);
- Set_Node3 (N, Val); -- semantic field, no parent set
- end Set_Corresponding_Formal_Spec;
-
- procedure Set_Corresponding_Generic_Association
- (N : Node_Id; Val : Node_Id) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Object_Declaration
- or else NT (N).Nkind = N_Object_Renaming_Declaration);
- Set_Node5 (N, Val); -- semantic field, no parent set
- end Set_Corresponding_Generic_Association;
-
- procedure Set_Corresponding_Integer_Value
- (N : Node_Id; Val : Uint) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Real_Literal);
- Set_Uint4 (N, Val); -- semantic field, no parent set
- end Set_Corresponding_Integer_Value;
-
- procedure Set_Corresponding_Spec
- (N : Node_Id; Val : Entity_Id) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Expression_Function
- or else NT (N).Nkind = N_Package_Body
- or else NT (N).Nkind = N_Protected_Body
- or else NT (N).Nkind = N_Subprogram_Body
- or else NT (N).Nkind = N_Subprogram_Renaming_Declaration
- or else NT (N).Nkind = N_Task_Body
- or else NT (N).Nkind = N_With_Clause);
- Set_Node5 (N, Val); -- semantic field, no parent set
- end Set_Corresponding_Spec;
-
- procedure Set_Corresponding_Spec_Of_Stub
- (N : Node_Id; Val : Entity_Id) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Package_Body_Stub
- or else NT (N).Nkind = N_Protected_Body_Stub
- or else NT (N).Nkind = N_Subprogram_Body_Stub
- or else NT (N).Nkind = N_Task_Body_Stub);
- Set_Node2 (N, Val); -- semantic field, no parent set
- end Set_Corresponding_Spec_Of_Stub;
-
- procedure Set_Corresponding_Stub
- (N : Node_Id; Val : Node_Id) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Subunit);
- Set_Node3 (N, Val);
- end Set_Corresponding_Stub;
-
- procedure Set_Dcheck_Function
- (N : Node_Id; Val : Entity_Id) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Variant);
- Set_Node5 (N, Val); -- semantic field, no parent set
- end Set_Dcheck_Function;
-
- procedure Set_Declarations
- (N : Node_Id; Val : List_Id) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Accept_Statement
- or else NT (N).Nkind = N_Block_Statement
- or else NT (N).Nkind = N_Compilation_Unit_Aux
- or else NT (N).Nkind = N_Entry_Body
- or else NT (N).Nkind = N_Package_Body
- or else NT (N).Nkind = N_Protected_Body
- or else NT (N).Nkind = N_Subprogram_Body
- or else NT (N).Nkind = N_Task_Body);
- Set_List2_With_Parent (N, Val);
- end Set_Declarations;
-
- procedure Set_Default_Expression
- (N : Node_Id; Val : Node_Id) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Formal_Object_Declaration
- or else NT (N).Nkind = N_Parameter_Specification);
- Set_Node5 (N, Val); -- semantic field, no parent set
- end Set_Default_Expression;
-
- procedure Set_Default_Storage_Pool
- (N : Node_Id; Val : Node_Id) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Compilation_Unit_Aux);
- Set_Node3 (N, Val); -- semantic field, no parent set
- end Set_Default_Storage_Pool;
-
- procedure Set_Default_Name
- (N : Node_Id; Val : Node_Id) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Formal_Abstract_Subprogram_Declaration
- or else NT (N).Nkind = N_Formal_Concrete_Subprogram_Declaration);
- Set_Node2_With_Parent (N, Val);
- end Set_Default_Name;
-
- procedure Set_Defining_Identifier
- (N : Node_Id; Val : Entity_Id) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Component_Declaration
- or else NT (N).Nkind = N_Defining_Program_Unit_Name
- or else NT (N).Nkind = N_Discriminant_Specification
- or else NT (N).Nkind = N_Entry_Body
- or else NT (N).Nkind = N_Entry_Declaration
- or else NT (N).Nkind = N_Entry_Index_Specification
- or else NT (N).Nkind = N_Exception_Declaration
- or else NT (N).Nkind = N_Exception_Renaming_Declaration
- or else NT (N).Nkind = N_Formal_Object_Declaration
- or else NT (N).Nkind = N_Formal_Package_Declaration
- or else NT (N).Nkind = N_Formal_Type_Declaration
- or else NT (N).Nkind = N_Full_Type_Declaration
- or else NT (N).Nkind = N_Implicit_Label_Declaration
- or else NT (N).Nkind = N_Incomplete_Type_Declaration
- or else NT (N).Nkind = N_Iterated_Component_Association
- or else NT (N).Nkind = N_Iterator_Specification
- or else NT (N).Nkind = N_Loop_Parameter_Specification
- or else NT (N).Nkind = N_Number_Declaration
- or else NT (N).Nkind = N_Object_Declaration
- or else NT (N).Nkind = N_Object_Renaming_Declaration
- or else NT (N).Nkind = N_Package_Body_Stub
- or else NT (N).Nkind = N_Parameter_Specification
- or else NT (N).Nkind = N_Private_Extension_Declaration
- or else NT (N).Nkind = N_Private_Type_Declaration
- or else NT (N).Nkind = N_Protected_Body
- or else NT (N).Nkind = N_Protected_Body_Stub
- or else NT (N).Nkind = N_Protected_Type_Declaration
- or else NT (N).Nkind = N_Single_Protected_Declaration
- or else NT (N).Nkind = N_Single_Task_Declaration
- or else NT (N).Nkind = N_Subtype_Declaration
- or else NT (N).Nkind = N_Task_Body
- or else NT (N).Nkind = N_Task_Body_Stub
- or else NT (N).Nkind = N_Task_Type_Declaration);
- Set_Node1_With_Parent (N, Val);
- end Set_Defining_Identifier;
-
- procedure Set_Defining_Unit_Name
- (N : Node_Id; Val : Node_Id) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Function_Instantiation
- or else NT (N).Nkind = N_Function_Specification
- or else NT (N).Nkind = N_Generic_Function_Renaming_Declaration
- or else NT (N).Nkind = N_Generic_Package_Renaming_Declaration
- or else NT (N).Nkind = N_Generic_Procedure_Renaming_Declaration
- or else NT (N).Nkind = N_Package_Body
- or else NT (N).Nkind = N_Package_Instantiation
- or else NT (N).Nkind = N_Package_Renaming_Declaration
- or else NT (N).Nkind = N_Package_Specification
- or else NT (N).Nkind = N_Procedure_Instantiation
- or else NT (N).Nkind = N_Procedure_Specification);
- Set_Node1_With_Parent (N, Val);
- end Set_Defining_Unit_Name;
-
- procedure Set_Delay_Alternative
- (N : Node_Id; Val : Node_Id) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Timed_Entry_Call);
- Set_Node4_With_Parent (N, Val);
- end Set_Delay_Alternative;
-
- procedure Set_Delay_Statement
- (N : Node_Id; Val : Node_Id) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Delay_Alternative);
- Set_Node2_With_Parent (N, Val);
- end Set_Delay_Statement;
-
- procedure Set_Delta_Expression
- (N : Node_Id; Val : Node_Id) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Decimal_Fixed_Point_Definition
- or else NT (N).Nkind = N_Delta_Constraint
- or else NT (N).Nkind = N_Ordinary_Fixed_Point_Definition);
- Set_Node3_With_Parent (N, Val);
- end Set_Delta_Expression;
-
- procedure Set_Digits_Expression
- (N : Node_Id; Val : Node_Id) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Decimal_Fixed_Point_Definition
- or else NT (N).Nkind = N_Digits_Constraint
- or else NT (N).Nkind = N_Floating_Point_Definition);
- Set_Node2_With_Parent (N, Val);
- end Set_Digits_Expression;
-
- procedure Set_Discr_Check_Funcs_Built
- (N : Node_Id; Val : Boolean := True) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Full_Type_Declaration);
- Set_Flag11 (N, Val);
- end Set_Discr_Check_Funcs_Built;
-
- procedure Set_Discrete_Choices
- (N : Node_Id; Val : List_Id) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Case_Expression_Alternative
- or else NT (N).Nkind = N_Case_Statement_Alternative
- or else NT (N).Nkind = N_Iterated_Component_Association
- or else NT (N).Nkind = N_Variant);
- Set_List4_With_Parent (N, Val);
- end Set_Discrete_Choices;
-
- procedure Set_Discrete_Range
- (N : Node_Id; Val : Node_Id) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Slice);
- Set_Node4_With_Parent (N, Val);
- end Set_Discrete_Range;
-
- procedure Set_Discrete_Subtype_Definition
- (N : Node_Id; Val : Node_Id) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Entry_Declaration
- or else NT (N).Nkind = N_Entry_Index_Specification
- or else NT (N).Nkind = N_Loop_Parameter_Specification);
- Set_Node4_With_Parent (N, Val);
- end Set_Discrete_Subtype_Definition;
-
- procedure Set_Discrete_Subtype_Definitions
- (N : Node_Id; Val : List_Id) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Constrained_Array_Definition);
- Set_List2_With_Parent (N, Val);
- end Set_Discrete_Subtype_Definitions;
-
- procedure Set_Discriminant_Specifications
- (N : Node_Id; Val : List_Id) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Formal_Type_Declaration
- or else NT (N).Nkind = N_Full_Type_Declaration
- or else NT (N).Nkind = N_Incomplete_Type_Declaration
- or else NT (N).Nkind = N_Private_Extension_Declaration
- or else NT (N).Nkind = N_Private_Type_Declaration
- or else NT (N).Nkind = N_Protected_Type_Declaration
- or else NT (N).Nkind = N_Task_Type_Declaration);
- Set_List4_With_Parent (N, Val);
- end Set_Discriminant_Specifications;
-
- procedure Set_Discriminant_Type
- (N : Node_Id; Val : Node_Id) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Discriminant_Specification);
- Set_Node5_With_Parent (N, Val);
- end Set_Discriminant_Type;
-
- procedure Set_Do_Accessibility_Check
- (N : Node_Id; Val : Boolean := True) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Parameter_Specification);
- Set_Flag13 (N, Val);
- end Set_Do_Accessibility_Check;
-
- procedure Set_Do_Discriminant_Check
- (N : Node_Id; Val : Boolean := True) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Assignment_Statement
- or else NT (N).Nkind = N_Selected_Component
- or else NT (N).Nkind = N_Type_Conversion);
- Set_Flag3 (N, Val);
- end Set_Do_Discriminant_Check;
-
- procedure Set_Do_Division_Check
- (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_Rem);
- Set_Flag13 (N, Val);
- end Set_Do_Division_Check;
-
- procedure Set_Do_Length_Check
- (N : Node_Id; Val : Boolean := True) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Assignment_Statement
- or else NT (N).Nkind = N_Op_And
- or else NT (N).Nkind = N_Op_Or
- or else NT (N).Nkind = N_Op_Xor
- or else NT (N).Nkind = N_Type_Conversion);
- Set_Flag4 (N, Val);
- end Set_Do_Length_Check;
-
- procedure Set_Do_Overflow_Check
- (N : Node_Id; Val : Boolean := True) is
- begin
- pragma Assert (False
- or else NT (N).Nkind in N_Op
- or else NT (N).Nkind = N_Attribute_Reference
- or else NT (N).Nkind = N_Case_Expression
- or else NT (N).Nkind = N_If_Expression
- or else NT (N).Nkind = N_Type_Conversion);
- Set_Flag17 (N, Val);
- end Set_Do_Overflow_Check;
-
- procedure Set_Do_Range_Check
- (N : Node_Id; Val : Boolean := True) is
- begin
- pragma Assert (False
- or else NT (N).Nkind in N_Subexpr);
- Set_Flag9 (N, Val);
- end Set_Do_Range_Check;
-
- procedure Set_Do_Storage_Check
- (N : Node_Id; Val : Boolean := True) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Allocator
- or else NT (N).Nkind = N_Subprogram_Body);
- Set_Flag17 (N, Val);
- end Set_Do_Storage_Check;
-
- procedure Set_Do_Tag_Check
- (N : Node_Id; Val : Boolean := True) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Assignment_Statement
- or else NT (N).Nkind = N_Extended_Return_Statement
- or else NT (N).Nkind = N_Function_Call
- or else NT (N).Nkind = N_Procedure_Call_Statement
- or else NT (N).Nkind = N_Simple_Return_Statement
- or else NT (N).Nkind = N_Type_Conversion);
- Set_Flag13 (N, Val);
- end Set_Do_Tag_Check;
-
- procedure Set_Elaborate_All_Desirable
- (N : Node_Id; Val : Boolean := True) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_With_Clause);
- Set_Flag9 (N, Val);
- end Set_Elaborate_All_Desirable;
-
- procedure Set_Elaborate_All_Present
- (N : Node_Id; Val : Boolean := True) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_With_Clause);
- Set_Flag14 (N, Val);
- end Set_Elaborate_All_Present;
-
- procedure Set_Elaborate_Desirable
- (N : Node_Id; Val : Boolean := True) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_With_Clause);
- Set_Flag11 (N, Val);
- end Set_Elaborate_Desirable;
-
- procedure Set_Elaborate_Present
- (N : Node_Id; Val : Boolean := True) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_With_Clause);
- Set_Flag4 (N, Val);
- end Set_Elaborate_Present;
-
- procedure Set_Else_Actions
- (N : Node_Id; Val : List_Id) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_If_Expression);
- Set_List3_With_Parent (N, Val); -- semantic field, but needs parents
- end Set_Else_Actions;
-
- procedure Set_Else_Statements
- (N : Node_Id; Val : List_Id) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Conditional_Entry_Call
- or else NT (N).Nkind = N_If_Statement
- or else NT (N).Nkind = N_Selective_Accept);
- Set_List4_With_Parent (N, Val);
- end Set_Else_Statements;
-
- procedure Set_Elsif_Parts
- (N : Node_Id; Val : List_Id) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_If_Statement);
- Set_List3_With_Parent (N, Val);
- end Set_Elsif_Parts;
-
- procedure Set_Enclosing_Variant
- (N : Node_Id; Val : Node_Id) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Variant);
- Set_Node2 (N, Val); -- semantic field, no parent set
- end Set_Enclosing_Variant;
-
- procedure Set_End_Label
- (N : Node_Id; Val : Node_Id) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Enumeration_Type_Definition
- or else NT (N).Nkind = N_Handled_Sequence_Of_Statements
- or else NT (N).Nkind = N_Loop_Statement
- or else NT (N).Nkind = N_Package_Specification
- or else NT (N).Nkind = N_Protected_Body
- or else NT (N).Nkind = N_Protected_Definition
- or else NT (N).Nkind = N_Record_Definition
- or else NT (N).Nkind = N_Task_Definition);
- Set_Node4_With_Parent (N, Val);
- end Set_End_Label;
-
- procedure Set_End_Span
- (N : Node_Id; Val : Uint) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Case_Statement
- or else NT (N).Nkind = N_If_Statement);
- Set_Uint5 (N, Val);
- end Set_End_Span;
-
- procedure Set_Entity
- (N : Node_Id; Val : Node_Id) is
- begin
- pragma Assert (False
- or else NT (N).Nkind in N_Has_Entity
- or else NT (N).Nkind = N_Aspect_Specification
- or else NT (N).Nkind = N_Attribute_Definition_Clause
- or else NT (N).Nkind = N_Freeze_Entity
- or else NT (N).Nkind = N_Freeze_Generic_Entity);
- Set_Node4 (N, Val); -- semantic field, no parent set
- end Set_Entity;
-
- procedure Set_Entry_Body_Formal_Part
- (N : Node_Id; Val : Node_Id) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Entry_Body);
- Set_Node5_With_Parent (N, Val);
- end Set_Entry_Body_Formal_Part;
-
- procedure Set_Entry_Call_Alternative
- (N : Node_Id; Val : Node_Id) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Conditional_Entry_Call
- or else NT (N).Nkind = N_Timed_Entry_Call);
- Set_Node1_With_Parent (N, Val);
- end Set_Entry_Call_Alternative;
-
- procedure Set_Entry_Call_Statement
- (N : Node_Id; Val : Node_Id) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Entry_Call_Alternative);
- Set_Node1_With_Parent (N, Val);
- end Set_Entry_Call_Statement;
-
- procedure Set_Entry_Direct_Name
- (N : Node_Id; Val : Node_Id) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Accept_Statement);
- Set_Node1_With_Parent (N, Val);
- end Set_Entry_Direct_Name;
-
- procedure Set_Entry_Index
- (N : Node_Id; Val : Node_Id) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Accept_Statement);
- Set_Node5_With_Parent (N, Val);
- end Set_Entry_Index;
-
- procedure Set_Entry_Index_Specification
- (N : Node_Id; Val : Node_Id) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Entry_Body_Formal_Part);
- Set_Node4_With_Parent (N, Val);
- end Set_Entry_Index_Specification;
-
- procedure Set_Etype
- (N : Node_Id; Val : Node_Id) is
- begin
- pragma Assert (False
- or else NT (N).Nkind in N_Has_Etype);
- Set_Node5 (N, Val); -- semantic field, no parent set
- end Set_Etype;
-
- procedure Set_Exception_Choices
- (N : Node_Id; Val : List_Id) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Exception_Handler);
- Set_List4_With_Parent (N, Val);
- end Set_Exception_Choices;
-
- procedure Set_Exception_Handlers
- (N : Node_Id; Val : List_Id) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Handled_Sequence_Of_Statements);
- Set_List5_With_Parent (N, Val);
- end Set_Exception_Handlers;
-
- procedure Set_Exception_Junk
- (N : Node_Id; Val : Boolean := True) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Block_Statement
- or else NT (N).Nkind = N_Goto_Statement
- or else NT (N).Nkind = N_Label
- or else NT (N).Nkind = N_Object_Declaration
- or else NT (N).Nkind = N_Subtype_Declaration);
- Set_Flag8 (N, Val);
- end Set_Exception_Junk;
-
- procedure Set_Exception_Label
- (N : Node_Id; Val : Node_Id) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Exception_Handler
- or else NT (N).Nkind = N_Push_Constraint_Error_Label
- or else NT (N).Nkind = N_Push_Program_Error_Label
- or else NT (N).Nkind = N_Push_Storage_Error_Label);
- Set_Node5 (N, Val); -- semantic field, no parent set
- end Set_Exception_Label;
-
- procedure Set_Expansion_Delayed
- (N : Node_Id; Val : Boolean := True) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Aggregate
- or else NT (N).Nkind = N_Extension_Aggregate);
- Set_Flag11 (N, Val);
- end Set_Expansion_Delayed;
-
- procedure Set_Explicit_Actual_Parameter
- (N : Node_Id; Val : Node_Id) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Parameter_Association);
- Set_Node3_With_Parent (N, Val);
- end Set_Explicit_Actual_Parameter;
-
- procedure Set_Explicit_Generic_Actual_Parameter
- (N : Node_Id; Val : Node_Id) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Generic_Association);
- Set_Node1_With_Parent (N, Val);
- end Set_Explicit_Generic_Actual_Parameter;
-
- procedure Set_Expression
- (N : Node_Id; Val : Node_Id) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Allocator
- or else NT (N).Nkind = N_Aspect_Specification
- or else NT (N).Nkind = N_Assignment_Statement
- or else NT (N).Nkind = N_At_Clause
- or else NT (N).Nkind = N_Attribute_Definition_Clause
- or else NT (N).Nkind = N_Case_Expression
- or else NT (N).Nkind = N_Case_Expression_Alternative
- or else NT (N).Nkind = N_Case_Statement
- or else NT (N).Nkind = N_Code_Statement
- or else NT (N).Nkind = N_Component_Association
- or else NT (N).Nkind = N_Component_Declaration
- or else NT (N).Nkind = N_Delay_Relative_Statement
- or else NT (N).Nkind = N_Delay_Until_Statement
- or else NT (N).Nkind = N_Delta_Aggregate
- or else NT (N).Nkind = N_Discriminant_Association
- or else NT (N).Nkind = N_Discriminant_Specification
- or else NT (N).Nkind = N_Exception_Declaration
- or else NT (N).Nkind = N_Expression_Function
- 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
- or else NT (N).Nkind = N_Object_Declaration
- or else NT (N).Nkind = N_Parameter_Specification
- or else NT (N).Nkind = N_Pragma_Argument_Association
- or else NT (N).Nkind = N_Qualified_Expression
- or else NT (N).Nkind = N_Raise_Expression
- or else NT (N).Nkind = N_Raise_Statement
- or else NT (N).Nkind = N_Simple_Return_Statement
- or else NT (N).Nkind = N_Type_Conversion
- or else NT (N).Nkind = N_Unchecked_Expression
- or else NT (N).Nkind = N_Unchecked_Type_Conversion);
- Set_Node3_With_Parent (N, Val);
- end Set_Expression;
-
- procedure Set_Expression_Copy
- (N : Node_Id; Val : Node_Id) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Pragma_Argument_Association);
- Set_Node2 (N, Val); -- semantic field, no parent set
- end Set_Expression_Copy;
-
- procedure Set_Expressions
- (N : Node_Id; Val : List_Id) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Aggregate
- or else NT (N).Nkind = N_Attribute_Reference
- or else NT (N).Nkind = N_Extension_Aggregate
- or else NT (N).Nkind = N_If_Expression
- or else NT (N).Nkind = N_Indexed_Component);
- Set_List1_With_Parent (N, Val);
- end Set_Expressions;
-
- procedure Set_First_Bit
- (N : Node_Id; Val : Node_Id) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Component_Clause);
- Set_Node3_With_Parent (N, Val);
- end Set_First_Bit;
-
- procedure Set_First_Inlined_Subprogram
- (N : Node_Id; Val : Entity_Id) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Compilation_Unit);
- Set_Node3 (N, Val); -- semantic field, no parent set
- end Set_First_Inlined_Subprogram;
-
- procedure Set_First_Name
- (N : Node_Id; Val : Boolean := True) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_With_Clause);
- Set_Flag5 (N, Val);
- end Set_First_Name;
-
- procedure Set_First_Named_Actual
- (N : Node_Id; Val : Node_Id) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Entry_Call_Statement
- or else NT (N).Nkind = N_Function_Call
- or else NT (N).Nkind = N_Procedure_Call_Statement);
- Set_Node4 (N, Val); -- semantic field, no parent set
- end Set_First_Named_Actual;
-
- procedure Set_First_Real_Statement
- (N : Node_Id; Val : Node_Id) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Handled_Sequence_Of_Statements);
- Set_Node2 (N, Val); -- semantic field, no parent set
- end Set_First_Real_Statement;
-
- procedure Set_First_Subtype_Link
- (N : Node_Id; Val : Entity_Id) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Freeze_Entity);
- Set_Node5 (N, Val); -- semantic field, no parent set
- end Set_First_Subtype_Link;
-
- procedure Set_Float_Truncate
- (N : Node_Id; Val : Boolean := True) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Type_Conversion);
- Set_Flag11 (N, Val);
- end Set_Float_Truncate;
-
- procedure Set_Formal_Type_Definition
- (N : Node_Id; Val : Node_Id) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Formal_Type_Declaration);
- Set_Node3_With_Parent (N, Val);
- end Set_Formal_Type_Definition;
-
- procedure Set_Forwards_OK
- (N : Node_Id; Val : Boolean := True) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Assignment_Statement);
- Set_Flag5 (N, Val);
- end Set_Forwards_OK;
-
- procedure Set_From_Aspect_Specification
- (N : Node_Id; Val : Boolean := True) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Attribute_Definition_Clause
- or else NT (N).Nkind = N_Pragma);
- Set_Flag13 (N, Val);
- end Set_From_Aspect_Specification;
-
- procedure Set_From_At_End
- (N : Node_Id; Val : Boolean := True) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Raise_Statement);
- Set_Flag4 (N, Val);
- end Set_From_At_End;
-
- procedure Set_From_At_Mod
- (N : Node_Id; Val : Boolean := True) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Attribute_Definition_Clause);
- Set_Flag4 (N, Val);
- end Set_From_At_Mod;
-
- procedure Set_From_Conditional_Expression
- (N : Node_Id; Val : Boolean := True) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Case_Statement
- or else NT (N).Nkind = N_If_Statement);
- Set_Flag1 (N, Val);
- end Set_From_Conditional_Expression;
-
- procedure Set_From_Default
- (N : Node_Id; Val : Boolean := True) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Subprogram_Renaming_Declaration);
- Set_Flag6 (N, Val);
- end Set_From_Default;
-
- procedure Set_Generalized_Indexing
- (N : Node_Id; Val : Node_Id) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Indexed_Component);
- Set_Node4 (N, Val);
- end Set_Generalized_Indexing;
-
- procedure Set_Generic_Associations
- (N : Node_Id; Val : List_Id) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Formal_Package_Declaration
- or else NT (N).Nkind = N_Function_Instantiation
- or else NT (N).Nkind = N_Package_Instantiation
- or else NT (N).Nkind = N_Procedure_Instantiation);
- Set_List3_With_Parent (N, Val);
- end Set_Generic_Associations;
-
- procedure Set_Generic_Formal_Declarations
- (N : Node_Id; Val : List_Id) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Generic_Package_Declaration
- or else NT (N).Nkind = N_Generic_Subprogram_Declaration);
- Set_List2_With_Parent (N, Val);
- end Set_Generic_Formal_Declarations;
-
- procedure Set_Generic_Parent
- (N : Node_Id; Val : Node_Id) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Function_Specification
- or else NT (N).Nkind = N_Package_Specification
- or else NT (N).Nkind = N_Procedure_Specification);
- Set_Node5 (N, Val);
- end Set_Generic_Parent;
-
- procedure Set_Generic_Parent_Type
- (N : Node_Id; Val : Node_Id) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Subtype_Declaration);
- Set_Node4 (N, Val);
- end Set_Generic_Parent_Type;
-
- procedure Set_Handled_Statement_Sequence
- (N : Node_Id; Val : Node_Id) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Accept_Statement
- or else NT (N).Nkind = N_Block_Statement
- or else NT (N).Nkind = N_Entry_Body
- or else NT (N).Nkind = N_Extended_Return_Statement
- or else NT (N).Nkind = N_Package_Body
- or else NT (N).Nkind = N_Subprogram_Body
- or else NT (N).Nkind = N_Task_Body);
- Set_Node4_With_Parent (N, Val);
- end Set_Handled_Statement_Sequence;
-
- procedure Set_Handler_List_Entry
- (N : Node_Id; Val : Node_Id) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Object_Declaration);
- Set_Node2 (N, Val);
- end Set_Handler_List_Entry;
-
- procedure Set_Has_Created_Identifier
- (N : Node_Id; Val : Boolean := True) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Block_Statement
- or else NT (N).Nkind = N_Loop_Statement);
- Set_Flag15 (N, Val);
- end Set_Has_Created_Identifier;
-
- procedure Set_Has_Dereference_Action
- (N : Node_Id; Val : Boolean := True) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Explicit_Dereference);
- Set_Flag13 (N, Val);
- end Set_Has_Dereference_Action;
-
- procedure Set_Has_Dynamic_Length_Check
- (N : Node_Id; Val : Boolean := True) is
- begin
- pragma Assert (False
- or else NT (N).Nkind in N_Subexpr);
- Set_Flag10 (N, Val);
- end Set_Has_Dynamic_Length_Check;
-
- procedure Set_Has_Init_Expression
- (N : Node_Id; Val : Boolean := True) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Object_Declaration);
- Set_Flag14 (N, Val);
- end Set_Has_Init_Expression;
-
- procedure Set_Has_Local_Raise
- (N : Node_Id; Val : Boolean := True) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Exception_Handler);
- Set_Flag8 (N, Val);
- end Set_Has_Local_Raise;
-
- procedure Set_Has_No_Elaboration_Code
- (N : Node_Id; Val : Boolean := True) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Compilation_Unit);
- Set_Flag17 (N, Val);
- end Set_Has_No_Elaboration_Code;
-
- procedure Set_Has_Pragma_Suppress_All
- (N : Node_Id; Val : Boolean := True) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Compilation_Unit);
- Set_Flag14 (N, Val);
- end Set_Has_Pragma_Suppress_All;
-
- procedure Set_Has_Private_View
- (N : Node_Id; Val : Boolean := True) is
- begin
- pragma Assert (False
- or else NT (N).Nkind in N_Op
- or else NT (N).Nkind = N_Character_Literal
- or else NT (N).Nkind = N_Expanded_Name
- or else NT (N).Nkind = N_Identifier
- or else NT (N).Nkind = N_Operator_Symbol);
- Set_Flag11 (N, Val);
- end Set_Has_Private_View;
-
- procedure Set_Has_Relative_Deadline_Pragma
- (N : Node_Id; Val : Boolean := True) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Subprogram_Body
- or else NT (N).Nkind = N_Task_Definition);
- Set_Flag9 (N, Val);
- end Set_Has_Relative_Deadline_Pragma;
-
- procedure Set_Has_Self_Reference
- (N : Node_Id; Val : Boolean := True) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Aggregate
- or else NT (N).Nkind = N_Extension_Aggregate);
- Set_Flag13 (N, Val);
- end Set_Has_Self_Reference;
-
- procedure Set_Has_SP_Choice
- (N : Node_Id; Val : Boolean := True) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Case_Expression_Alternative
- or else NT (N).Nkind = N_Case_Statement_Alternative
- or else NT (N).Nkind = N_Variant);
- Set_Flag15 (N, Val);
- end Set_Has_SP_Choice;
-
- procedure Set_Has_Storage_Size_Pragma
- (N : Node_Id; Val : Boolean := True) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Task_Definition);
- Set_Flag5 (N, Val);
- end Set_Has_Storage_Size_Pragma;
-
- procedure Set_Has_Target_Names
- (N : Node_Id; Val : Boolean := True) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Assignment_Statement);
- Set_Flag8 (N, Val);
- end Set_Has_Target_Names;
-
- procedure Set_Has_Wide_Character
- (N : Node_Id; Val : Boolean := True) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_String_Literal);
- Set_Flag11 (N, Val);
- end Set_Has_Wide_Character;
-
- procedure Set_Has_Wide_Wide_Character
- (N : Node_Id; Val : Boolean := True) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_String_Literal);
- Set_Flag13 (N, Val);
- end Set_Has_Wide_Wide_Character;
-
- procedure Set_Header_Size_Added
- (N : Node_Id; Val : Boolean := True) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Attribute_Reference);
- Set_Flag11 (N, Val);
- end Set_Header_Size_Added;
-
- procedure Set_Hidden_By_Use_Clause
- (N : Node_Id; Val : Elist_Id) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Use_Package_Clause
- or else NT (N).Nkind = N_Use_Type_Clause);
- Set_Elist5 (N, Val);
- end Set_Hidden_By_Use_Clause;
-
- procedure Set_High_Bound
- (N : Node_Id; Val : Node_Id) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Range
- or else NT (N).Nkind = N_Real_Range_Specification
- or else NT (N).Nkind = N_Signed_Integer_Type_Definition);
- Set_Node2_With_Parent (N, Val);
- end Set_High_Bound;
-
- procedure Set_Identifier
- (N : Node_Id; Val : Node_Id) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Aspect_Specification
- or else NT (N).Nkind = N_At_Clause
- or else NT (N).Nkind = N_Block_Statement
- or else NT (N).Nkind = N_Designator
- or else NT (N).Nkind = N_Enumeration_Representation_Clause
- or else NT (N).Nkind = N_Label
- or else NT (N).Nkind = N_Loop_Statement
- or else NT (N).Nkind = N_Record_Representation_Clause);
- Set_Node1_With_Parent (N, Val);
- end Set_Identifier;
-
- procedure Set_Implicit_With
- (N : Node_Id; Val : Boolean := True) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_With_Clause);
- Set_Flag16 (N, Val);
- end Set_Implicit_With;
-
- procedure Set_Interface_List
- (N : Node_Id; Val : List_Id) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Derived_Type_Definition
- or else NT (N).Nkind = N_Formal_Derived_Type_Definition
- or else NT (N).Nkind = N_Private_Extension_Declaration
- or else NT (N).Nkind = N_Protected_Type_Declaration
- or else NT (N).Nkind = N_Record_Definition
- or else NT (N).Nkind = N_Single_Protected_Declaration
- or else NT (N).Nkind = N_Single_Task_Declaration
- or else NT (N).Nkind = N_Task_Type_Declaration);
- Set_List2_With_Parent (N, Val);
- end Set_Interface_List;
-
- procedure Set_Interface_Present
- (N : Node_Id; Val : Boolean := True) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Derived_Type_Definition
- or else NT (N).Nkind = N_Record_Definition);
- Set_Flag16 (N, Val);
- end Set_Interface_Present;
-
- procedure Set_Import_Interface_Present
- (N : Node_Id; Val : Boolean := True) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Pragma);
- Set_Flag16 (N, Val);
- end Set_Import_Interface_Present;
-
- procedure Set_In_Present
- (N : Node_Id; Val : Boolean := True) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Formal_Object_Declaration
- or else NT (N).Nkind = N_Parameter_Specification);
- Set_Flag15 (N, Val);
- end Set_In_Present;
-
- procedure Set_Includes_Infinities
- (N : Node_Id; Val : Boolean := True) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Range);
- Set_Flag11 (N, Val);
- end Set_Includes_Infinities;
-
- procedure Set_Incomplete_View
- (N : Node_Id; Val : Node_Id) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Full_Type_Declaration);
- Set_Node2 (N, Val); -- semantic field, no Parent set
- end Set_Incomplete_View;
-
- procedure Set_Inherited_Discriminant
- (N : Node_Id; Val : Boolean := True) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Component_Association);
- Set_Flag13 (N, Val);
- end Set_Inherited_Discriminant;
-
- procedure Set_Instance_Spec
- (N : Node_Id; Val : Node_Id) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Formal_Package_Declaration
- or else NT (N).Nkind = N_Function_Instantiation
- or else NT (N).Nkind = N_Package_Instantiation
- or else NT (N).Nkind = N_Procedure_Instantiation);
- Set_Node5 (N, Val); -- semantic field, no Parent set
- end Set_Instance_Spec;
-
- procedure Set_Intval
- (N : Node_Id; Val : Uint) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Integer_Literal);
- Set_Uint3 (N, Val);
- end Set_Intval;
-
- procedure Set_Is_Abort_Block
- (N : Node_Id; Val : Boolean := True) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Block_Statement);
- Set_Flag4 (N, Val);
- end Set_Is_Abort_Block;
-
- procedure Set_Is_Accessibility_Actual
- (N : Node_Id; Val : Boolean := True) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Parameter_Association);
- Set_Flag13 (N, Val);
- end Set_Is_Accessibility_Actual;
-
- procedure Set_Is_Analyzed_Pragma
- (N : Node_Id; Val : Boolean := True) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Pragma);
- Set_Flag5 (N, Val);
- end Set_Is_Analyzed_Pragma;
-
- procedure Set_Is_Asynchronous_Call_Block
- (N : Node_Id; Val : Boolean := True) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Block_Statement);
- Set_Flag7 (N, Val);
- end Set_Is_Asynchronous_Call_Block;
-
- procedure Set_Is_Boolean_Aspect
- (N : Node_Id; Val : Boolean := True) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Aspect_Specification);
- Set_Flag16 (N, Val);
- end Set_Is_Boolean_Aspect;
-
- procedure Set_Is_Checked
- (N : Node_Id; Val : Boolean := True) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Aspect_Specification
- or else NT (N).Nkind = N_Pragma);
- Set_Flag11 (N, Val);
- end Set_Is_Checked;
-
- procedure Set_Is_Checked_Ghost_Pragma
- (N : Node_Id; Val : Boolean := True) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Pragma);
- Set_Flag3 (N, Val);
- end Set_Is_Checked_Ghost_Pragma;
-
- procedure Set_Is_Component_Left_Opnd
- (N : Node_Id; Val : Boolean := True) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Op_Concat);
- Set_Flag13 (N, Val);
- end Set_Is_Component_Left_Opnd;
-
- procedure Set_Is_Component_Right_Opnd
- (N : Node_Id; Val : Boolean := True) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Op_Concat);
- Set_Flag14 (N, Val);
- end Set_Is_Component_Right_Opnd;
-
- procedure Set_Is_Controlling_Actual
- (N : Node_Id; Val : Boolean := True) is
- begin
- pragma Assert (False
- or else NT (N).Nkind in N_Subexpr);
- Set_Flag16 (N, Val);
- end Set_Is_Controlling_Actual;
-
- procedure Set_Is_Declaration_Level_Node
- (N : Node_Id; Val : Boolean := True) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Call_Marker
- or else NT (N).Nkind = N_Function_Instantiation
- or else NT (N).Nkind = N_Package_Instantiation
- or else NT (N).Nkind = N_Procedure_Instantiation);
- Set_Flag5 (N, Val);
- end Set_Is_Declaration_Level_Node;
-
- procedure Set_Is_Delayed_Aspect
- (N : Node_Id; Val : Boolean := True) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Aspect_Specification
- or else NT (N).Nkind = N_Attribute_Definition_Clause
- or else NT (N).Nkind = N_Pragma);
- Set_Flag14 (N, Val);
- end Set_Is_Delayed_Aspect;
-
- procedure Set_Is_Disabled
- (N : Node_Id; Val : Boolean := True) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Aspect_Specification
- or else NT (N).Nkind = N_Pragma);
- Set_Flag15 (N, Val);
- end Set_Is_Disabled;
-
- procedure Set_Is_Dispatching_Call
- (N : Node_Id; Val : Boolean := True) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Call_Marker);
- Set_Flag6 (N, Val);
- end Set_Is_Dispatching_Call;
-
- procedure Set_Is_Dynamic_Coextension
- (N : Node_Id; Val : Boolean := True) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Allocator);
- pragma Assert (not Val
- or else not Is_Static_Coextension (N));
- Set_Flag18 (N, Val);
- end Set_Is_Dynamic_Coextension;
-
- procedure Set_Is_Effective_Use_Clause
- (N : Node_Id; Val : Boolean := True) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Use_Package_Clause
- or else NT (N).Nkind = N_Use_Type_Clause);
- Set_Flag1 (N, Val);
- end Set_Is_Effective_Use_Clause;
-
- procedure Set_Is_Elaboration_Checks_OK_Node
- (N : Node_Id; Val : Boolean := True) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Assignment_Statement
- or else NT (N).Nkind = N_Attribute_Reference
- or else NT (N).Nkind = N_Call_Marker
- or else NT (N).Nkind = N_Entry_Call_Statement
- or else NT (N).Nkind = N_Expanded_Name
- or else NT (N).Nkind = N_Function_Call
- or else NT (N).Nkind = N_Function_Instantiation
- or else NT (N).Nkind = N_Identifier
- or else NT (N).Nkind = N_Package_Instantiation
- or else NT (N).Nkind = N_Procedure_Call_Statement
- or else NT (N).Nkind = N_Procedure_Instantiation
- or else NT (N).Nkind = N_Requeue_Statement
- or else NT (N).Nkind = N_Variable_Reference_Marker);
- Set_Flag1 (N, Val);
- end Set_Is_Elaboration_Checks_OK_Node;
-
- procedure Set_Is_Elaboration_Code
- (N : Node_Id; Val : Boolean := True) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Assignment_Statement);
- Set_Flag9 (N, Val);
- end Set_Is_Elaboration_Code;
-
- procedure Set_Is_Elaboration_Warnings_OK_Node
- (N : Node_Id; Val : Boolean := True) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Attribute_Reference
- or else NT (N).Nkind = N_Call_Marker
- or else NT (N).Nkind = N_Entry_Call_Statement
- or else NT (N).Nkind = N_Expanded_Name
- or else NT (N).Nkind = N_Function_Call
- or else NT (N).Nkind = N_Function_Instantiation
- or else NT (N).Nkind = N_Identifier
- or else NT (N).Nkind = N_Package_Instantiation
- or else NT (N).Nkind = N_Procedure_Call_Statement
- or else NT (N).Nkind = N_Procedure_Instantiation
- or else NT (N).Nkind = N_Requeue_Statement
- or else NT (N).Nkind = N_Variable_Reference_Marker);
- Set_Flag3 (N, Val);
- end Set_Is_Elaboration_Warnings_OK_Node;
-
- procedure Set_Is_Elsif
- (N : Node_Id; Val : Boolean := True) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_If_Expression);
- Set_Flag13 (N, Val);
- end Set_Is_Elsif;
-
- procedure Set_Is_Entry_Barrier_Function
- (N : Node_Id; Val : Boolean := True) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Subprogram_Body
- or else NT (N).Nkind = N_Subprogram_Declaration);
- Set_Flag8 (N, Val);
- end Set_Is_Entry_Barrier_Function;
-
- procedure Set_Is_Expanded_Build_In_Place_Call
- (N : Node_Id; Val : Boolean := True) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Function_Call);
- Set_Flag11 (N, Val);
- end Set_Is_Expanded_Build_In_Place_Call;
-
- procedure Set_Is_Expanded_Contract
- (N : Node_Id; Val : Boolean := True) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Contract);
- Set_Flag1 (N, Val);
- end Set_Is_Expanded_Contract;
-
- procedure Set_Is_Finalization_Wrapper
- (N : Node_Id; Val : Boolean := True) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Block_Statement);
- Set_Flag9 (N, Val);
- end Set_Is_Finalization_Wrapper;
-
- procedure Set_Is_Folded_In_Parser
- (N : Node_Id; Val : Boolean := True) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_String_Literal);
- Set_Flag4 (N, Val);
- end Set_Is_Folded_In_Parser;
-
- procedure Set_Is_Generic_Contract_Pragma
- (N : Node_Id; Val : Boolean := True) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Pragma);
- Set_Flag2 (N, Val);
- end Set_Is_Generic_Contract_Pragma;
-
- procedure Set_Is_Homogeneous_Aggregate
- (N : Node_Id; Val : Boolean := True) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Aggregate);
- Set_Flag14 (N, Val);
- end Set_Is_Homogeneous_Aggregate;
-
- procedure Set_Is_Ignored
- (N : Node_Id; Val : Boolean := True) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Aspect_Specification
- or else NT (N).Nkind = N_Pragma);
- Set_Flag9 (N, Val);
- end Set_Is_Ignored;
-
- procedure Set_Is_Ignored_Ghost_Pragma
- (N : Node_Id; Val : Boolean := True) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Pragma);
- Set_Flag8 (N, Val);
- end Set_Is_Ignored_Ghost_Pragma;
-
- procedure Set_Is_In_Discriminant_Check
- (N : Node_Id; Val : Boolean := True) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Selected_Component);
- Set_Flag11 (N, Val);
- end Set_Is_In_Discriminant_Check;
-
- procedure Set_Is_Inherited_Pragma
- (N : Node_Id; Val : Boolean := True) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Pragma);
- Set_Flag4 (N, Val);
- end Set_Is_Inherited_Pragma;
-
- procedure Set_Is_Initialization_Block
- (N : Node_Id; Val : Boolean := True) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Block_Statement);
- Set_Flag1 (N, Val);
- end Set_Is_Initialization_Block;
-
- procedure Set_Is_Known_Guaranteed_ABE
- (N : Node_Id; Val : Boolean := True) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Call_Marker
- or else NT (N).Nkind = N_Formal_Package_Declaration
- or else NT (N).Nkind = N_Function_Call
- or else NT (N).Nkind = N_Function_Instantiation
- or else NT (N).Nkind = N_Package_Instantiation
- or else NT (N).Nkind = N_Procedure_Call_Statement
- or else NT (N).Nkind = N_Procedure_Instantiation);
- Set_Flag18 (N, Val);
- end Set_Is_Known_Guaranteed_ABE;
-
- procedure Set_Is_Machine_Number
- (N : Node_Id; Val : Boolean := True) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Real_Literal);
- Set_Flag11 (N, Val);
- end Set_Is_Machine_Number;
-
- procedure Set_Is_Null_Loop
- (N : Node_Id; Val : Boolean := True) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Loop_Statement);
- Set_Flag16 (N, Val);
- end Set_Is_Null_Loop;
-
- procedure Set_Is_Overloaded
- (N : Node_Id; Val : Boolean := True) is
- begin
- pragma Assert (False
- or else NT (N).Nkind in N_Subexpr);
- Set_Flag5 (N, Val);
- end Set_Is_Overloaded;
-
- procedure Set_Is_Power_Of_2_For_Shift
- (N : Node_Id; Val : Boolean := True) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Op_Expon);
- 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
- pragma Assert (False
- or else NT (N).Nkind = N_Selected_Component);
- Set_Flag17 (N, Val);
- end Set_Is_Prefixed_Call;
-
- procedure Set_Is_Protected_Subprogram_Body
- (N : Node_Id; Val : Boolean := True) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Subprogram_Body);
- Set_Flag7 (N, Val);
- end Set_Is_Protected_Subprogram_Body;
-
- procedure Set_Is_Qualified_Universal_Literal
- (N : Node_Id; Val : Boolean := True) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Qualified_Expression);
- Set_Flag4 (N, Val);
- end Set_Is_Qualified_Universal_Literal;
-
- procedure Set_Is_Read
- (N : Node_Id; Val : Boolean := True) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Variable_Reference_Marker);
- Set_Flag4 (N, Val);
- end Set_Is_Read;
-
- procedure Set_Is_Source_Call
- (N : Node_Id; Val : Boolean := True) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Call_Marker);
- Set_Flag4 (N, Val);
- end Set_Is_Source_Call;
-
- procedure Set_Is_SPARK_Mode_On_Node
- (N : Node_Id; Val : Boolean := True) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Assignment_Statement
- or else NT (N).Nkind = N_Attribute_Reference
- or else NT (N).Nkind = N_Call_Marker
- or else NT (N).Nkind = N_Entry_Call_Statement
- or else NT (N).Nkind = N_Expanded_Name
- or else NT (N).Nkind = N_Function_Call
- or else NT (N).Nkind = N_Function_Instantiation
- or else NT (N).Nkind = N_Identifier
- or else NT (N).Nkind = N_Package_Instantiation
- or else NT (N).Nkind = N_Procedure_Call_Statement
- or else NT (N).Nkind = N_Procedure_Instantiation
- or else NT (N).Nkind = N_Requeue_Statement
- or else NT (N).Nkind = N_Variable_Reference_Marker);
- Set_Flag2 (N, Val);
- end Set_Is_SPARK_Mode_On_Node;
-
- procedure Set_Is_Static_Coextension
- (N : Node_Id; Val : Boolean := True) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Allocator);
- pragma Assert (not Val
- or else not Is_Dynamic_Coextension (N));
- Set_Flag14 (N, Val);
- end Set_Is_Static_Coextension;
-
- procedure Set_Is_Static_Expression
- (N : Node_Id; Val : Boolean := True) is
- begin
- pragma Assert (False
- or else NT (N).Nkind in N_Subexpr);
- Set_Flag6 (N, Val);
- end Set_Is_Static_Expression;
-
- procedure Set_Is_Subprogram_Descriptor
- (N : Node_Id; Val : Boolean := True) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Object_Declaration);
- Set_Flag16 (N, Val);
- end Set_Is_Subprogram_Descriptor;
-
- procedure Set_Is_Task_Allocation_Block
- (N : Node_Id; Val : Boolean := True) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Block_Statement);
- Set_Flag6 (N, Val);
- end Set_Is_Task_Allocation_Block;
-
- procedure Set_Is_Task_Body_Procedure
- (N : Node_Id; Val : Boolean := True) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Subprogram_Body
- or else NT (N).Nkind = N_Subprogram_Declaration);
- Set_Flag1 (N, Val);
- end Set_Is_Task_Body_Procedure;
-
- procedure Set_Is_Task_Master
- (N : Node_Id; Val : Boolean := True) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Block_Statement
- or else NT (N).Nkind = N_Subprogram_Body
- or else NT (N).Nkind = N_Task_Body);
- Set_Flag5 (N, Val);
- end Set_Is_Task_Master;
-
- procedure Set_Is_Write
- (N : Node_Id; Val : Boolean := True) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Variable_Reference_Marker);
- 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
- pragma Assert (False
- or else NT (N).Nkind = N_Loop_Statement);
- Set_Node2_With_Parent (N, Val);
- end Set_Iteration_Scheme;
-
- procedure Set_Iterator_Specification
- (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);
- end Set_Iterator_Specification;
-
- procedure Set_Itype
- (N : Node_Id; Val : Entity_Id) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Itype_Reference);
- 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
- pragma Assert (False
- or else NT (N).Nkind = N_Unchecked_Type_Conversion);
- Set_Flag11 (N, Val);
- end Set_Kill_Range_Check;
-
- procedure Set_Label_Construct
- (N : Node_Id; Val : Node_Id) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Implicit_Label_Declaration);
- Set_Node2 (N, Val); -- semantic field, no parent set
- end Set_Label_Construct;
-
- procedure Set_Last_Bit
- (N : Node_Id; Val : Node_Id) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Component_Clause);
- Set_Node4_With_Parent (N, Val);
- end Set_Last_Bit;
-
- procedure Set_Last_Name
- (N : Node_Id; Val : Boolean := True) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_With_Clause);
- Set_Flag6 (N, Val);
- end Set_Last_Name;
-
- procedure Set_Left_Opnd
- (N : Node_Id; Val : Node_Id) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_And_Then
- or else NT (N).Nkind = N_In
- or else NT (N).Nkind = N_Not_In
- or else NT (N).Nkind = N_Or_Else
- or else NT (N).Nkind in N_Binary_Op);
- Set_Node2_With_Parent (N, Val);
- end Set_Left_Opnd;
-
- procedure Set_Library_Unit
- (N : Node_Id; Val : Node_Id) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Compilation_Unit
- or else NT (N).Nkind = N_Package_Body_Stub
- or else NT (N).Nkind = N_Protected_Body_Stub
- or else NT (N).Nkind = N_Subprogram_Body_Stub
- or else NT (N).Nkind = N_Task_Body_Stub
- or else NT (N).Nkind = N_With_Clause);
- Set_Node4 (N, Val); -- semantic field, no parent set
- end Set_Library_Unit;
-
- procedure Set_Limited_View_Installed
- (N : Node_Id; Val : Boolean := True) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Package_Specification
- or else NT (N).Nkind = N_With_Clause);
- Set_Flag18 (N, Val);
- end Set_Limited_View_Installed;
-
- procedure Set_Limited_Present
- (N : Node_Id; Val : Boolean := True) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Derived_Type_Definition
- or else NT (N).Nkind = N_Formal_Derived_Type_Definition
- or else NT (N).Nkind = N_Formal_Private_Type_Definition
- or else NT (N).Nkind = N_Private_Extension_Declaration
- or else NT (N).Nkind = N_Private_Type_Declaration
- or else NT (N).Nkind = N_Record_Definition
- or else NT (N).Nkind = N_With_Clause);
- Set_Flag17 (N, Val);
- end Set_Limited_Present;
-
- procedure Set_Literals
- (N : Node_Id; Val : List_Id) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Enumeration_Type_Definition);
- Set_List1_With_Parent (N, Val);
- end Set_Literals;
-
- procedure Set_Local_Raise_Not_OK
- (N : Node_Id; Val : Boolean := True) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Exception_Handler);
- Set_Flag7 (N, Val);
- end Set_Local_Raise_Not_OK;
-
- procedure Set_Local_Raise_Statements
- (N : Node_Id; Val : Elist_Id) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Exception_Handler);
- Set_Elist1 (N, Val);
- end Set_Local_Raise_Statements;
-
- procedure Set_Loop_Actions
- (N : Node_Id; Val : List_Id) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Component_Association
- 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);
- end Set_Loop_Parameter_Specification;
-
- procedure Set_Low_Bound
- (N : Node_Id; Val : Node_Id) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Range
- or else NT (N).Nkind = N_Real_Range_Specification
- or else NT (N).Nkind = N_Signed_Integer_Type_Definition);
- Set_Node1_With_Parent (N, Val);
- end Set_Low_Bound;
-
- procedure Set_Mod_Clause
- (N : Node_Id; Val : Node_Id) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Record_Representation_Clause);
- Set_Node2_With_Parent (N, Val);
- end Set_Mod_Clause;
-
- procedure Set_More_Ids
- (N : Node_Id; Val : Boolean := True) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Component_Declaration
- or else NT (N).Nkind = N_Discriminant_Specification
- or else NT (N).Nkind = N_Exception_Declaration
- or else NT (N).Nkind = N_Formal_Object_Declaration
- or else NT (N).Nkind = N_Number_Declaration
- or else NT (N).Nkind = N_Object_Declaration
- or else NT (N).Nkind = N_Parameter_Specification
- or else NT (N).Nkind = N_Use_Package_Clause
- or else NT (N).Nkind = N_Use_Type_Clause);
- Set_Flag5 (N, Val);
- end Set_More_Ids;
-
- procedure Set_Must_Be_Byte_Aligned
- (N : Node_Id; Val : Boolean := True) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Attribute_Reference);
- Set_Flag14 (N, Val);
- end Set_Must_Be_Byte_Aligned;
-
- procedure Set_Must_Not_Freeze
- (N : Node_Id; Val : Boolean := True) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Subtype_Indication
- or else NT (N).Nkind in N_Subexpr);
- Set_Flag8 (N, Val);
- end Set_Must_Not_Freeze;
-
- procedure Set_Must_Not_Override
- (N : Node_Id; Val : Boolean := True) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Entry_Declaration
- or else NT (N).Nkind = N_Function_Instantiation
- or else NT (N).Nkind = N_Function_Specification
- or else NT (N).Nkind = N_Procedure_Instantiation
- or else NT (N).Nkind = N_Procedure_Specification);
- Set_Flag15 (N, Val);
- end Set_Must_Not_Override;
-
- procedure Set_Must_Override
- (N : Node_Id; Val : Boolean := True) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Entry_Declaration
- or else NT (N).Nkind = N_Function_Instantiation
- or else NT (N).Nkind = N_Function_Specification
- or else NT (N).Nkind = N_Procedure_Instantiation
- or else NT (N).Nkind = N_Procedure_Specification);
- Set_Flag14 (N, Val);
- end Set_Must_Override;
-
- procedure Set_Name
- (N : Node_Id; Val : Node_Id) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Assignment_Statement
- or else NT (N).Nkind = N_Attribute_Definition_Clause
- or else NT (N).Nkind = N_Defining_Program_Unit_Name
- or else NT (N).Nkind = N_Designator
- or else NT (N).Nkind = N_Entry_Call_Statement
- or else NT (N).Nkind = N_Exception_Renaming_Declaration
- or else NT (N).Nkind = N_Exit_Statement
- or else NT (N).Nkind = N_Formal_Package_Declaration
- or else NT (N).Nkind = N_Function_Call
- or else NT (N).Nkind = N_Function_Instantiation
- or else NT (N).Nkind = N_Generic_Function_Renaming_Declaration
- or else NT (N).Nkind = N_Generic_Package_Renaming_Declaration
- or else NT (N).Nkind = N_Generic_Procedure_Renaming_Declaration
- or else NT (N).Nkind = N_Goto_Statement
- or else NT (N).Nkind = N_Iterator_Specification
- or else NT (N).Nkind = N_Object_Renaming_Declaration
- or else NT (N).Nkind = N_Package_Instantiation
- or else NT (N).Nkind = N_Package_Renaming_Declaration
- or else NT (N).Nkind = N_Procedure_Call_Statement
- or else NT (N).Nkind = N_Procedure_Instantiation
- or else NT (N).Nkind = N_Raise_Expression
- or else NT (N).Nkind = N_Raise_Statement
- or else NT (N).Nkind = N_Requeue_Statement
- or else NT (N).Nkind = N_Subprogram_Renaming_Declaration
- or else NT (N).Nkind = N_Subunit
- or else NT (N).Nkind = N_Use_Package_Clause
- or else NT (N).Nkind = N_Variant_Part
- or else NT (N).Nkind = N_With_Clause);
- Set_Node2_With_Parent (N, Val);
- end Set_Name;
-
- procedure Set_Names
- (N : Node_Id; Val : List_Id) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Abort_Statement);
- Set_List2_With_Parent (N, Val);
- end Set_Names;
-
- procedure Set_Next_Entity
- (N : Node_Id; Val : Node_Id) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Defining_Character_Literal
- or else NT (N).Nkind = N_Defining_Identifier
- or else NT (N).Nkind = N_Defining_Operator_Symbol);
- Set_Node2 (N, Val); -- semantic field, no parent set
- end Set_Next_Entity;
-
- procedure Set_Next_Exit_Statement
- (N : Node_Id; Val : Node_Id) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Exit_Statement);
- Set_Node3 (N, Val); -- semantic field, no parent set
- end Set_Next_Exit_Statement;
-
- procedure Set_Next_Implicit_With
- (N : Node_Id; Val : Node_Id) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_With_Clause);
- Set_Node3 (N, Val); -- semantic field, no parent set
- end Set_Next_Implicit_With;
-
- procedure Set_Next_Named_Actual
- (N : Node_Id; Val : Node_Id) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Parameter_Association);
- Set_Node4 (N, Val); -- semantic field, no parent set
- end Set_Next_Named_Actual;
-
- procedure Set_Next_Pragma
- (N : Node_Id; Val : Node_Id) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Pragma);
- Set_Node1 (N, Val); -- semantic field, no parent set
- end Set_Next_Pragma;
-
- procedure Set_Next_Rep_Item
- (N : Node_Id; Val : Node_Id) is
- begin
- pragma Assert (False
- 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
- end Set_Next_Rep_Item;
-
- procedure Set_Next_Use_Clause
- (N : Node_Id; Val : Node_Id) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Use_Package_Clause
- or else NT (N).Nkind = N_Use_Type_Clause);
- Set_Node3 (N, Val); -- semantic field, no parent set
- end Set_Next_Use_Clause;
-
- procedure Set_No_Ctrl_Actions
- (N : Node_Id; Val : Boolean := True) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Assignment_Statement);
- Set_Flag7 (N, Val);
- end Set_No_Ctrl_Actions;
-
- procedure Set_No_Elaboration_Check
- (N : Node_Id; Val : Boolean := True) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Function_Call
- or else NT (N).Nkind = N_Procedure_Call_Statement);
- Set_Flag4 (N, Val);
- end Set_No_Elaboration_Check;
-
- procedure Set_No_Entities_Ref_In_Spec
- (N : Node_Id; Val : Boolean := True) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_With_Clause);
- Set_Flag8 (N, Val);
- end Set_No_Entities_Ref_In_Spec;
-
- procedure Set_No_Initialization
- (N : Node_Id; Val : Boolean := True) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Allocator
- or else NT (N).Nkind = N_Object_Declaration);
- Set_Flag13 (N, Val);
- end Set_No_Initialization;
-
- procedure Set_No_Minimize_Eliminate
- (N : Node_Id; Val : Boolean := True) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_In
- or else NT (N).Nkind = N_Not_In);
- Set_Flag17 (N, Val);
- end Set_No_Minimize_Eliminate;
-
- procedure Set_No_Side_Effect_Removal
- (N : Node_Id; Val : Boolean := True) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Function_Call);
- Set_Flag17 (N, Val);
- end Set_No_Side_Effect_Removal;
-
- procedure Set_No_Truncation
- (N : Node_Id; Val : Boolean := True) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Unchecked_Type_Conversion);
- Set_Flag17 (N, Val);
- end Set_No_Truncation;
-
- procedure Set_Null_Excluding_Subtype
- (N : Node_Id; Val : Boolean := True) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Access_To_Object_Definition);
- Set_Flag16 (N, Val);
- end Set_Null_Excluding_Subtype;
-
- procedure Set_Null_Exclusion_Present
- (N : Node_Id; Val : Boolean := True) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Access_Definition
- or else NT (N).Nkind = N_Access_Function_Definition
- or else NT (N).Nkind = N_Access_Procedure_Definition
- or else NT (N).Nkind = N_Access_To_Object_Definition
- or else NT (N).Nkind = N_Allocator
- or else NT (N).Nkind = N_Component_Definition
- or else NT (N).Nkind = N_Derived_Type_Definition
- or else NT (N).Nkind = N_Discriminant_Specification
- or else NT (N).Nkind = N_Formal_Object_Declaration
- or else NT (N).Nkind = N_Function_Specification
- or else NT (N).Nkind = N_Object_Declaration
- or else NT (N).Nkind = N_Object_Renaming_Declaration
- or else NT (N).Nkind = N_Parameter_Specification
- or else NT (N).Nkind = N_Subtype_Declaration);
- Set_Flag11 (N, Val);
- end Set_Null_Exclusion_Present;
-
- procedure Set_Null_Exclusion_In_Return_Present
- (N : Node_Id; Val : Boolean := True) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Access_Function_Definition);
- Set_Flag14 (N, Val);
- end Set_Null_Exclusion_In_Return_Present;
-
- procedure Set_Null_Present
- (N : Node_Id; Val : Boolean := True) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Component_List
- or else NT (N).Nkind = N_Procedure_Specification
- or else NT (N).Nkind = N_Record_Definition);
- Set_Flag13 (N, Val);
- end Set_Null_Present;
-
- procedure Set_Null_Record_Present
- (N : Node_Id; Val : Boolean := True) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Aggregate
- or else NT (N).Nkind = N_Extension_Aggregate);
- Set_Flag17 (N, Val);
- end Set_Null_Record_Present;
-
- procedure Set_Null_Statement
- (N : Node_Id; Val : Node_Id) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Procedure_Specification);
- Set_Node2 (N, Val);
- end Set_Null_Statement;
-
- procedure Set_Object_Definition
- (N : Node_Id; Val : Node_Id) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Object_Declaration);
- Set_Node4_With_Parent (N, Val);
- end Set_Object_Definition;
-
- procedure Set_Of_Present
- (N : Node_Id; Val : Boolean := True) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Iterator_Specification);
- Set_Flag16 (N, Val);
- end Set_Of_Present;
-
- procedure Set_Original_Discriminant
- (N : Node_Id; Val : Node_Id) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Identifier);
- Set_Node2 (N, Val); -- semantic field, no parent set
- end Set_Original_Discriminant;
-
- procedure Set_Original_Entity
- (N : Node_Id; Val : Entity_Id) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Integer_Literal
- or else NT (N).Nkind = N_Real_Literal);
- Set_Node2 (N, Val); -- semantic field, no parent set
- end Set_Original_Entity;
-
- procedure Set_Others_Discrete_Choices
- (N : Node_Id; Val : List_Id) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Others_Choice);
- Set_List1_With_Parent (N, Val);
- end Set_Others_Discrete_Choices;
-
- procedure Set_Out_Present
- (N : Node_Id; Val : Boolean := True) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Formal_Object_Declaration
- or else NT (N).Nkind = N_Parameter_Specification);
- Set_Flag17 (N, Val);
- end Set_Out_Present;
-
- procedure Set_Parameter_Associations
- (N : Node_Id; Val : List_Id) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Entry_Call_Statement
- or else NT (N).Nkind = N_Function_Call
- or else NT (N).Nkind = N_Procedure_Call_Statement);
- Set_List3_With_Parent (N, Val);
- end Set_Parameter_Associations;
-
- procedure Set_Parameter_Specifications
- (N : Node_Id; Val : List_Id) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Accept_Statement
- or else NT (N).Nkind = N_Access_Function_Definition
- or else NT (N).Nkind = N_Access_Procedure_Definition
- or else NT (N).Nkind = N_Entry_Body_Formal_Part
- or else NT (N).Nkind = N_Entry_Declaration
- or else NT (N).Nkind = N_Function_Specification
- or else NT (N).Nkind = N_Procedure_Specification);
- Set_List3_With_Parent (N, Val);
- end Set_Parameter_Specifications;
-
- procedure Set_Parameter_Type
- (N : Node_Id; Val : Node_Id) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Parameter_Specification);
- Set_Node2_With_Parent (N, Val);
- end Set_Parameter_Type;
-
- procedure Set_Parent_Spec
- (N : Node_Id; Val : Node_Id) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Function_Instantiation
- or else NT (N).Nkind = N_Generic_Function_Renaming_Declaration
- or else NT (N).Nkind = N_Generic_Package_Declaration
- or else NT (N).Nkind = N_Generic_Package_Renaming_Declaration
- or else NT (N).Nkind = N_Generic_Procedure_Renaming_Declaration
- or else NT (N).Nkind = N_Generic_Subprogram_Declaration
- or else NT (N).Nkind = N_Package_Declaration
- or else NT (N).Nkind = N_Package_Instantiation
- or else NT (N).Nkind = N_Package_Renaming_Declaration
- or else NT (N).Nkind = N_Procedure_Instantiation
- or else NT (N).Nkind = N_Subprogram_Declaration
- or else NT (N).Nkind = N_Subprogram_Renaming_Declaration);
- Set_Node4 (N, Val); -- semantic field, no parent set
- end Set_Parent_Spec;
-
- procedure Set_Parent_With
- (N : Node_Id; Val : Boolean := True) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_With_Clause);
- Set_Flag1 (N, Val);
- end Set_Parent_With;
-
- procedure Set_Position
- (N : Node_Id; Val : Node_Id) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Component_Clause);
- Set_Node2_With_Parent (N, Val);
- end Set_Position;
-
- procedure Set_Pragma_Argument_Associations
- (N : Node_Id; Val : List_Id) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Pragma);
- Set_List2_With_Parent (N, Val);
- end Set_Pragma_Argument_Associations;
-
- procedure Set_Pragma_Identifier
- (N : Node_Id; Val : Node_Id) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Pragma);
- Set_Node4_With_Parent (N, Val);
- end Set_Pragma_Identifier;
-
- procedure Set_Pragmas_After
- (N : Node_Id; Val : List_Id) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Compilation_Unit_Aux
- or else NT (N).Nkind = N_Terminate_Alternative);
- Set_List5_With_Parent (N, Val);
- end Set_Pragmas_After;
-
- procedure Set_Pragmas_Before
- (N : Node_Id; Val : List_Id) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Accept_Alternative
- or else NT (N).Nkind = N_Delay_Alternative
- or else NT (N).Nkind = N_Entry_Call_Alternative
- or else NT (N).Nkind = N_Mod_Clause
- or else NT (N).Nkind = N_Terminate_Alternative
- or else NT (N).Nkind = N_Triggering_Alternative);
- Set_List4_With_Parent (N, Val);
- end Set_Pragmas_Before;
-
- procedure Set_Pre_Post_Conditions
- (N : Node_Id; Val : Node_Id) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Contract);
- Set_Node1 (N, Val); -- semantic field, no parent set
- end Set_Pre_Post_Conditions;
-
- procedure Set_Prefix
- (N : Node_Id; Val : Node_Id) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Attribute_Reference
- or else NT (N).Nkind = N_Expanded_Name
- or else NT (N).Nkind = N_Explicit_Dereference
- or else NT (N).Nkind = N_Indexed_Component
- or else NT (N).Nkind = N_Reference
- or else NT (N).Nkind = N_Selected_Component
- or else NT (N).Nkind = N_Slice);
- Set_Node3_With_Parent (N, Val);
- end Set_Prefix;
-
- procedure Set_Premature_Use
- (N : Node_Id; Val : Node_Id) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Incomplete_Type_Declaration);
- Set_Node5 (N, Val);
- end Set_Premature_Use;
-
- procedure Set_Present_Expr
- (N : Node_Id; Val : Uint) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Variant);
- Set_Uint3 (N, Val);
- end Set_Present_Expr;
-
- procedure Set_Prev_Ids
- (N : Node_Id; Val : Boolean := True) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Component_Declaration
- or else NT (N).Nkind = N_Discriminant_Specification
- or else NT (N).Nkind = N_Exception_Declaration
- or else NT (N).Nkind = N_Formal_Object_Declaration
- or else NT (N).Nkind = N_Number_Declaration
- or else NT (N).Nkind = N_Object_Declaration
- or else NT (N).Nkind = N_Parameter_Specification
- or else NT (N).Nkind = N_Use_Package_Clause
- or else NT (N).Nkind = N_Use_Type_Clause);
- Set_Flag6 (N, Val);
- end Set_Prev_Ids;
-
- procedure Set_Prev_Use_Clause
- (N : Node_Id; Val : Node_Id) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Use_Package_Clause
- or else NT (N).Nkind = N_Use_Type_Clause);
- Set_Node1 (N, Val); -- semantic field, no parent set
- end Set_Prev_Use_Clause;
-
- procedure Set_Print_In_Hex
- (N : Node_Id; Val : Boolean := True) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Integer_Literal);
- Set_Flag13 (N, Val);
- end Set_Print_In_Hex;
-
- procedure Set_Private_Declarations
- (N : Node_Id; Val : List_Id) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Package_Specification
- or else NT (N).Nkind = N_Protected_Definition
- or else NT (N).Nkind = N_Task_Definition);
- Set_List3_With_Parent (N, Val);
- end Set_Private_Declarations;
-
- procedure Set_Private_Present
- (N : Node_Id; Val : Boolean := True) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Compilation_Unit
- or else NT (N).Nkind = N_Formal_Derived_Type_Definition
- or else NT (N).Nkind = N_With_Clause);
- Set_Flag15 (N, Val);
- end Set_Private_Present;
-
- procedure Set_Procedure_To_Call
- (N : Node_Id; Val : Node_Id) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Allocator
- or else NT (N).Nkind = N_Extended_Return_Statement
- or else NT (N).Nkind = N_Free_Statement
- or else NT (N).Nkind = N_Simple_Return_Statement);
- Set_Node2 (N, Val); -- semantic field, no parent set
- end Set_Procedure_To_Call;
-
- procedure Set_Proper_Body
- (N : Node_Id; Val : Node_Id) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Subunit);
- Set_Node1_With_Parent (N, Val);
- end Set_Proper_Body;
-
- procedure Set_Protected_Definition
- (N : Node_Id; Val : Node_Id) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Protected_Type_Declaration
- or else NT (N).Nkind = N_Single_Protected_Declaration);
- Set_Node3_With_Parent (N, Val);
- end Set_Protected_Definition;
-
- procedure Set_Protected_Present
- (N : Node_Id; Val : Boolean := True) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Access_Function_Definition
- or else NT (N).Nkind = N_Access_Procedure_Definition
- or else NT (N).Nkind = N_Derived_Type_Definition
- or else NT (N).Nkind = N_Record_Definition);
- Set_Flag6 (N, Val);
- end Set_Protected_Present;
-
- procedure Set_Raises_Constraint_Error
- (N : Node_Id; Val : Boolean := True) is
- begin
- pragma Assert (False
- or else NT (N).Nkind in N_Subexpr);
- Set_Flag7 (N, Val);
- end Set_Raises_Constraint_Error;
-
- procedure Set_Range_Constraint
- (N : Node_Id; Val : Node_Id) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Delta_Constraint
- or else NT (N).Nkind = N_Digits_Constraint);
- Set_Node4_With_Parent (N, Val);
- end Set_Range_Constraint;
-
- procedure Set_Range_Expression
- (N : Node_Id; Val : Node_Id) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Range_Constraint);
- Set_Node4_With_Parent (N, Val);
- end Set_Range_Expression;
-
- procedure Set_Real_Range_Specification
- (N : Node_Id; Val : Node_Id) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Decimal_Fixed_Point_Definition
- or else NT (N).Nkind = N_Floating_Point_Definition
- or else NT (N).Nkind = N_Ordinary_Fixed_Point_Definition);
- Set_Node4_With_Parent (N, Val);
- end Set_Real_Range_Specification;
-
- procedure Set_Realval
- (N : Node_Id; Val : Ureal) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Real_Literal);
- Set_Ureal3 (N, Val);
- end Set_Realval;
-
- procedure Set_Reason
- (N : Node_Id; Val : Uint) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Raise_Constraint_Error
- or else NT (N).Nkind = N_Raise_Program_Error
- or else NT (N).Nkind = N_Raise_Storage_Error);
- Set_Uint3 (N, Val);
- end Set_Reason;
-
- procedure Set_Record_Extension_Part
- (N : Node_Id; Val : Node_Id) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Derived_Type_Definition);
- Set_Node3_With_Parent (N, Val);
- end Set_Record_Extension_Part;
-
- procedure Set_Redundant_Use
- (N : Node_Id; Val : Boolean := True) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Attribute_Reference
- or else NT (N).Nkind = N_Expanded_Name
- or else NT (N).Nkind = N_Identifier);
- Set_Flag13 (N, Val);
- end Set_Redundant_Use;
-
- procedure Set_Renaming_Exception
- (N : Node_Id; Val : Node_Id) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Exception_Declaration);
- Set_Node2 (N, Val);
- end Set_Renaming_Exception;
-
- procedure Set_Result_Definition
- (N : Node_Id; Val : Node_Id) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Access_Function_Definition
- or else NT (N).Nkind = N_Function_Specification);
- Set_Node4_With_Parent (N, Val);
- end Set_Result_Definition;
-
- procedure Set_Return_Object_Declarations
- (N : Node_Id; Val : List_Id) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Extended_Return_Statement);
- Set_List3_With_Parent (N, Val);
- end Set_Return_Object_Declarations;
-
- procedure Set_Return_Statement_Entity
- (N : Node_Id; Val : Node_Id) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Extended_Return_Statement
- or else NT (N).Nkind = N_Simple_Return_Statement);
- Set_Node5 (N, Val); -- semantic field, no parent set
- end Set_Return_Statement_Entity;
-
- procedure Set_Reverse_Present
- (N : Node_Id; Val : Boolean := True) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Iterator_Specification
- or else NT (N).Nkind = N_Loop_Parameter_Specification);
- Set_Flag15 (N, Val);
- end Set_Reverse_Present;
-
- procedure Set_Right_Opnd
- (N : Node_Id; Val : Node_Id) is
- begin
- pragma Assert (False
- or else NT (N).Nkind in N_Op
- or else NT (N).Nkind = N_And_Then
- or else NT (N).Nkind = N_In
- or else NT (N).Nkind = N_Not_In
- or else NT (N).Nkind = N_Or_Else);
- Set_Node3_With_Parent (N, Val);
- end Set_Right_Opnd;
-
- procedure Set_Rounded_Result
- (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_Multiply
- or else NT (N).Nkind = N_Type_Conversion);
- Set_Flag18 (N, Val);
- end Set_Rounded_Result;
-
- procedure Set_Save_Invocation_Graph_Of_Body
- (N : Node_Id; Val : Boolean := True) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Compilation_Unit);
- Set_Flag1 (N, Val);
- end Set_Save_Invocation_Graph_Of_Body;
-
- procedure Set_SCIL_Controlling_Tag
- (N : Node_Id; Val : Node_Id) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_SCIL_Dispatching_Call);
- Set_Node5 (N, Val); -- semantic field, no parent set
- end Set_SCIL_Controlling_Tag;
-
- procedure Set_SCIL_Entity
- (N : Node_Id; Val : Node_Id) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_SCIL_Dispatch_Table_Tag_Init
- or else NT (N).Nkind = N_SCIL_Dispatching_Call
- or else NT (N).Nkind = N_SCIL_Membership_Test);
- Set_Node4 (N, Val); -- semantic field, no parent set
- end Set_SCIL_Entity;
-
- procedure Set_SCIL_Tag_Value
- (N : Node_Id; Val : Node_Id) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_SCIL_Membership_Test);
- Set_Node5 (N, Val); -- semantic field, no parent set
- end Set_SCIL_Tag_Value;
-
- procedure Set_SCIL_Target_Prim
- (N : Node_Id; Val : Node_Id) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_SCIL_Dispatching_Call);
- Set_Node2 (N, Val); -- semantic field, no parent set
- end Set_SCIL_Target_Prim;
-
- procedure Set_Scope
- (N : Node_Id; Val : Node_Id) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Defining_Character_Literal
- or else NT (N).Nkind = N_Defining_Identifier
- or else NT (N).Nkind = N_Defining_Operator_Symbol);
- Set_Node3 (N, Val); -- semantic field, no parent set
- end Set_Scope;
-
- procedure Set_Select_Alternatives
- (N : Node_Id; Val : List_Id) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Selective_Accept);
- Set_List1_With_Parent (N, Val);
- end Set_Select_Alternatives;
-
- procedure Set_Selector_Name
- (N : Node_Id; Val : Node_Id) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Expanded_Name
- or else NT (N).Nkind = N_Generic_Association
- or else NT (N).Nkind = N_Parameter_Association
- or else NT (N).Nkind = N_Selected_Component);
- Set_Node2_With_Parent (N, Val);
- end Set_Selector_Name;
-
- procedure Set_Selector_Names
- (N : Node_Id; Val : List_Id) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Discriminant_Association);
- Set_List1_With_Parent (N, Val);
- end Set_Selector_Names;
-
- procedure Set_Shift_Count_OK
- (N : Node_Id; Val : Boolean := True) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Op_Rotate_Left
- or else NT (N).Nkind = N_Op_Rotate_Right
- or else NT (N).Nkind = N_Op_Shift_Left
- or else NT (N).Nkind = N_Op_Shift_Right
- or else NT (N).Nkind = N_Op_Shift_Right_Arithmetic);
- Set_Flag4 (N, Val);
- end Set_Shift_Count_OK;
-
- procedure Set_Source_Type
- (N : Node_Id; Val : Entity_Id) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Validate_Unchecked_Conversion);
- Set_Node1 (N, Val); -- semantic field, no parent set
- end Set_Source_Type;
-
- procedure Set_Specification
- (N : Node_Id; Val : Node_Id) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Abstract_Subprogram_Declaration
- or else NT (N).Nkind = N_Expression_Function
- or else NT (N).Nkind = N_Formal_Abstract_Subprogram_Declaration
- or else NT (N).Nkind = N_Formal_Concrete_Subprogram_Declaration
- or else NT (N).Nkind = N_Generic_Package_Declaration
- or else NT (N).Nkind = N_Generic_Subprogram_Declaration
- or else NT (N).Nkind = N_Package_Declaration
- or else NT (N).Nkind = N_Subprogram_Body
- or else NT (N).Nkind = N_Subprogram_Body_Stub
- or else NT (N).Nkind = N_Subprogram_Declaration
- or else NT (N).Nkind = N_Subprogram_Renaming_Declaration);
- Set_Node1_With_Parent (N, Val);
- end Set_Specification;
-
- procedure Set_Split_PPC
- (N : Node_Id; Val : Boolean) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Aspect_Specification
- or else NT (N).Nkind = N_Pragma);
- Set_Flag17 (N, Val);
- end Set_Split_PPC;
-
- procedure Set_Statements
- (N : Node_Id; Val : List_Id) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Abortable_Part
- or else NT (N).Nkind = N_Accept_Alternative
- or else NT (N).Nkind = N_Case_Statement_Alternative
- or else NT (N).Nkind = N_Delay_Alternative
- or else NT (N).Nkind = N_Entry_Call_Alternative
- or else NT (N).Nkind = N_Exception_Handler
- or else NT (N).Nkind = N_Handled_Sequence_Of_Statements
- or else NT (N).Nkind = N_Loop_Statement
- or else NT (N).Nkind = N_Triggering_Alternative);
- Set_List3_With_Parent (N, Val);
- end Set_Statements;
-
- procedure Set_Storage_Pool
- (N : Node_Id; Val : Node_Id) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Allocator
- or else NT (N).Nkind = N_Extended_Return_Statement
- or else NT (N).Nkind = N_Free_Statement
- or else NT (N).Nkind = N_Simple_Return_Statement);
- Set_Node1 (N, Val); -- semantic field, no parent set
- end Set_Storage_Pool;
-
- procedure Set_Subpool_Handle_Name
- (N : Node_Id; Val : Node_Id) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Allocator);
- Set_Node4_With_Parent (N, Val);
- end Set_Subpool_Handle_Name;
-
- procedure Set_Strval
- (N : Node_Id; Val : String_Id) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Operator_Symbol
- or else NT (N).Nkind = N_String_Literal);
- Set_Str3 (N, Val);
- end Set_Strval;
-
- procedure Set_Subtype_Indication
- (N : Node_Id; Val : Node_Id) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Access_To_Object_Definition
- or else NT (N).Nkind = N_Component_Definition
- or else NT (N).Nkind = N_Derived_Type_Definition
- or else NT (N).Nkind = N_Iterator_Specification
- or else NT (N).Nkind = N_Private_Extension_Declaration
- or else NT (N).Nkind = N_Subtype_Declaration);
- Set_Node5_With_Parent (N, Val);
- end Set_Subtype_Indication;
-
- procedure Set_Subtype_Mark
- (N : Node_Id; Val : Node_Id) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Access_Definition
- or else NT (N).Nkind = N_Formal_Derived_Type_Definition
- or else NT (N).Nkind = N_Formal_Object_Declaration
- or else NT (N).Nkind = N_Object_Renaming_Declaration
- or else NT (N).Nkind = N_Qualified_Expression
- or else NT (N).Nkind = N_Subtype_Indication
- or else NT (N).Nkind = N_Type_Conversion
- or else NT (N).Nkind = N_Unchecked_Type_Conversion
- or else NT (N).Nkind = N_Use_Type_Clause);
- Set_Node4_With_Parent (N, Val);
- end Set_Subtype_Mark;
-
- procedure Set_Subtype_Marks
- (N : Node_Id; Val : List_Id) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Unconstrained_Array_Definition);
- Set_List2_With_Parent (N, Val);
- end Set_Subtype_Marks;
-
- procedure Set_Suppress_Assignment_Checks
- (N : Node_Id; Val : Boolean := True) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Assignment_Statement
- or else NT (N).Nkind = N_Object_Declaration);
- Set_Flag18 (N, Val);
- end Set_Suppress_Assignment_Checks;
-
- procedure Set_Suppress_Loop_Warnings
- (N : Node_Id; Val : Boolean := True) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Loop_Statement);
- Set_Flag17 (N, Val);
- end Set_Suppress_Loop_Warnings;
-
- procedure Set_Synchronized_Present
- (N : Node_Id; Val : Boolean := True) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Derived_Type_Definition
- or else NT (N).Nkind = N_Formal_Derived_Type_Definition
- or else NT (N).Nkind = N_Private_Extension_Declaration
- or else NT (N).Nkind = N_Record_Definition);
- Set_Flag7 (N, Val);
- end Set_Synchronized_Present;
-
- procedure Set_Tagged_Present
- (N : Node_Id; Val : Boolean := True) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Formal_Incomplete_Type_Definition
- or else NT (N).Nkind = N_Formal_Private_Type_Definition
- or else NT (N).Nkind = N_Incomplete_Type_Declaration
- or else NT (N).Nkind = N_Private_Type_Declaration
- or else NT (N).Nkind = N_Record_Definition);
- Set_Flag15 (N, Val);
- end Set_Tagged_Present;
-
- procedure Set_Target
- (N : Node_Id; Val : Entity_Id) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Call_Marker
- or else NT (N).Nkind = N_Variable_Reference_Marker);
- Set_Node1 (N, Val); -- semantic field, no parent set
- end Set_Target;
-
- procedure Set_Target_Type
- (N : Node_Id; Val : Entity_Id) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Validate_Unchecked_Conversion);
- Set_Node2 (N, Val); -- semantic field, no parent set
- end Set_Target_Type;
-
- procedure Set_Task_Definition
- (N : Node_Id; Val : Node_Id) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Single_Task_Declaration
- or else NT (N).Nkind = N_Task_Type_Declaration);
- Set_Node3_With_Parent (N, Val);
- end Set_Task_Definition;
-
- procedure Set_Task_Present
- (N : Node_Id; Val : Boolean := True) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Derived_Type_Definition
- or else NT (N).Nkind = N_Record_Definition);
- Set_Flag5 (N, Val);
- end Set_Task_Present;
-
- procedure Set_Then_Actions
- (N : Node_Id; Val : List_Id) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_If_Expression);
- Set_List2_With_Parent (N, Val); -- semantic field, but needs parents
- end Set_Then_Actions;
-
- procedure Set_Then_Statements
- (N : Node_Id; Val : List_Id) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Elsif_Part
- or else NT (N).Nkind = N_If_Statement);
- Set_List2_With_Parent (N, Val);
- end Set_Then_Statements;
-
- procedure Set_Triggering_Alternative
- (N : Node_Id; Val : Node_Id) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Asynchronous_Select);
- Set_Node1_With_Parent (N, Val);
- end Set_Triggering_Alternative;
-
- procedure Set_Triggering_Statement
- (N : Node_Id; Val : Node_Id) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Triggering_Alternative);
- Set_Node1_With_Parent (N, Val);
- end Set_Triggering_Statement;
-
- procedure Set_TSS_Elist
- (N : Node_Id; Val : Elist_Id) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Freeze_Entity);
- Set_Elist3 (N, Val); -- semantic field, no parent set
- end Set_TSS_Elist;
-
- procedure Set_Uneval_Old_Accept
- (N : Node_Id; Val : Boolean := True) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Pragma);
- Set_Flag7 (N, Val);
- end Set_Uneval_Old_Accept;
-
- procedure Set_Uneval_Old_Warn
- (N : Node_Id; Val : Boolean := True) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Pragma);
- Set_Flag18 (N, Val);
- end Set_Uneval_Old_Warn;
-
- procedure Set_Type_Definition
- (N : Node_Id; Val : Node_Id) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Full_Type_Declaration);
- Set_Node3_With_Parent (N, Val);
- end Set_Type_Definition;
-
- procedure Set_Unit
- (N : Node_Id; Val : Node_Id) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Compilation_Unit);
- Set_Node2_With_Parent (N, Val);
- end Set_Unit;
-
- procedure Set_Unknown_Discriminants_Present
- (N : Node_Id; Val : Boolean := True) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Formal_Type_Declaration
- or else NT (N).Nkind = N_Incomplete_Type_Declaration
- or else NT (N).Nkind = N_Private_Extension_Declaration
- or else NT (N).Nkind = N_Private_Type_Declaration);
- Set_Flag13 (N, Val);
- end Set_Unknown_Discriminants_Present;
-
- procedure Set_Unreferenced_In_Spec
- (N : Node_Id; Val : Boolean := True) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_With_Clause);
- Set_Flag7 (N, Val);
- end Set_Unreferenced_In_Spec;
-
- procedure Set_Variant_Part
- (N : Node_Id; Val : Node_Id) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Component_List);
- Set_Node4_With_Parent (N, Val);
- end Set_Variant_Part;
-
- procedure Set_Variants
- (N : Node_Id; Val : List_Id) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Variant_Part);
- Set_List1_With_Parent (N, Val);
- end Set_Variants;
-
- procedure Set_Visible_Declarations
- (N : Node_Id; Val : List_Id) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Package_Specification
- or else NT (N).Nkind = N_Protected_Definition
- or else NT (N).Nkind = N_Task_Definition);
- Set_List2_With_Parent (N, Val);
- end Set_Visible_Declarations;
-
- procedure Set_Uninitialized_Variable
- (N : Node_Id; Val : Node_Id) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Formal_Private_Type_Definition
- or else NT (N).Nkind = N_Private_Extension_Declaration);
- Set_Node3 (N, Val);
- end Set_Uninitialized_Variable;
-
- procedure Set_Used_Operations
- (N : Node_Id; Val : Elist_Id) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Use_Type_Clause);
- Set_Elist2 (N, Val);
- end Set_Used_Operations;
-
- procedure Set_Was_Attribute_Reference
- (N : Node_Id; Val : Boolean := True) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Subprogram_Body);
- Set_Flag2 (N, Val);
- end Set_Was_Attribute_Reference;
-
- procedure Set_Was_Default_Init_Box_Association
- (N : Node_Id; Val : Boolean := True) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Component_Association);
- Set_Flag14 (N, Val);
- end Set_Was_Default_Init_Box_Association;
-
- procedure Set_Was_Expression_Function
- (N : Node_Id; Val : Boolean := True) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Subprogram_Body);
- Set_Flag18 (N, Val);
- end Set_Was_Expression_Function;
-
- procedure Set_Was_Originally_Stub
- (N : Node_Id; Val : Boolean := True) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Package_Body
- or else NT (N).Nkind = N_Protected_Body
- or else NT (N).Nkind = N_Subprogram_Body
- or else NT (N).Nkind = N_Task_Body);
- Set_Flag13 (N, Val);
- end Set_Was_Originally_Stub;
-
- -------------------------
- -- Iterator Procedures --
- -------------------------
-
- procedure Next_Entity (N : in out Node_Id) is
- begin
- N := Next_Entity (N);
- end Next_Entity;
-
- procedure Next_Named_Actual (N : in out Node_Id) is
- begin
- N := Next_Named_Actual (N);
- end Next_Named_Actual;
-
- procedure Next_Rep_Item (N : in out Node_Id) is
- begin
- N := Next_Rep_Item (N);
- end Next_Rep_Item;
-
- procedure Next_Use_Clause (N : in out Node_Id) is
- begin
- N := Next_Use_Clause (N);
- end Next_Use_Clause;
-
- ------------------
- -- End_Location --
- ------------------
-
- function End_Location (N : Node_Id) return Source_Ptr is
- L : constant Uint := End_Span (N);
- begin
- if L = No_Uint then
- return No_Location;
- else
- return Source_Ptr (Int (Sloc (N)) + UI_To_Int (L));
- end if;
- end End_Location;
-
- --------------------
- -- Get_Pragma_Arg --
- --------------------
-
- function Get_Pragma_Arg (Arg : Node_Id) return Node_Id is
- begin
- if Nkind (Arg) = N_Pragma_Argument_Association then
- return Expression (Arg);
- else
- return Arg;
- end if;
- end Get_Pragma_Arg;
-
- ----------------------
- -- Set_End_Location --
- ----------------------
-
- procedure Set_End_Location (N : Node_Id; S : Source_Ptr) is
- begin
- Set_End_Span (N,
- UI_From_Int (Int (S) - Int (Sloc (N))));
- end Set_End_Location;
-
- --------------------------
- -- Pragma_Name_Unmapped --
- --------------------------
-
- function Pragma_Name_Unmapped (N : Node_Id) return Name_Id is
- begin
- return Chars (Pragma_Identifier (N));
- end Pragma_Name_Unmapped;
-
- ---------------------
- -- Map_Pragma_Name --
- ---------------------
-
- -- We don't want to introduce a dependence on some hash table package or
- -- similar, so we use a simple array of Key => Value pairs, and do a linear
- -- search. Linear search is plenty efficient, given that we don't expect
- -- more than a couple of entries in the mapping.
-
- type Name_Pair is record
- Key : Name_Id;
- Value : Name_Id;
- end record;
-
- type Pragma_Map_Index is range 1 .. 100;
- Pragma_Map : array (Pragma_Map_Index) of Name_Pair;
- Last_Pair : Pragma_Map_Index'Base range 0 .. Pragma_Map_Index'Last := 0;
-
- procedure Map_Pragma_Name (From, To : Name_Id) is
- begin
- if Last_Pair = Pragma_Map'Last then
- raise Too_Many_Pragma_Mappings;
- end if;
-
- Last_Pair := Last_Pair + 1;
- Pragma_Map (Last_Pair) := (Key => From, Value => To);
- end Map_Pragma_Name;
-
- -----------------
- -- Pragma_Name --
- -----------------
-
- function Pragma_Name (N : Node_Id) return Name_Id is
- Result : constant Name_Id := Pragma_Name_Unmapped (N);
- begin
- for J in Pragma_Map'First .. Last_Pair loop
- if Result = Pragma_Map (J).Key then
- return Pragma_Map (J).Value;
- end if;
- end loop;
-
- return Result;
- end Pragma_Name;
-
-end Sinfo;
+pragma No_Body;
diff --git a/gcc/ada/sinfo.ads b/gcc/ada/sinfo.ads
index f9b0667..20a6125 100644
--- a/gcc/ada/sinfo.ads
+++ b/gcc/ada/sinfo.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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,7 @@
-- --
------------------------------------------------------------------------------
--- This package defines the structure of the abstract syntax tree. The Tree
+-- This package documents the structure of the abstract syntax tree. The Atree
-- package provides a basic tree structure. Sinfo describes how this structure
-- is used to represent the syntax of an Ada program.
@@ -37,92 +37,81 @@
-- would normally be regarded as the symbol table information. In addition a
-- number of the tree nodes contain semantic information.
--- WARNING: Several files are automatically generated from this package.
--- See below for details.
+-- See the spec of Gen_IL.Gen for instructions on making changes to this file.
+-- Note that the official definition of what nodes have what fields is in
+-- Gen_IL.Gen.Gen_Nodes; if there is a discrepancy between that and the
+-- comments here, Gen_IL.Gen.Gen_Nodes wins.
+pragma Warnings (Off); -- with/use clauses for children
with Namet; use Namet;
with Types; use Types;
with Uintp; use Uintp;
with Urealp; use Urealp;
+pragma Warnings (On);
package Sinfo is
- ---------------------------------
- -- Making Changes to This File --
- ---------------------------------
-
- -- If changes are made to this file, a number of related steps must be
- -- carried out to ensure consistency. First, if a field access function is
- -- added, it appears in these places:
-
- -- In sinfo.ads:
- -- The documentation associated with the field (if semantic)
- -- The documentation associated with the node
- -- The spec of the access function
- -- The spec of the set procedure
- -- The entries in Is_Syntactic_Field
- -- The pragma Inline for the access function
- -- The pragma Inline for the set procedure
- -- In sinfo.adb:
- -- The body of the access function
- -- The body of the set procedure
-
- -- The field chosen must be consistent in all places, and, for a node that
- -- is a subexpression, must not overlap any of the standard expression
- -- fields.
-
- -- In addition, if any of the standard expression fields is changed, then
- -- the utility program which creates the Treeprs spec (in file treeprs.ads)
- -- must be updated appropriately, since it special cases expression fields.
-
- -- If a new tree node is added, then the following changes are made:
-
- -- Add it to the documentation in the appropriate place
- -- Add its fields to this documentation section
- -- Define it in the appropriate classification in Node_Kind
- -- Add an entry in Is_Syntactic_Field
- -- In the body (sinfo), add entries to the access functions for all
- -- its fields (except standard expression fields) to include the new
- -- node in the checks.
- -- Add an appropriate section to the case statement in sprint.adb
- -- Add an appropriate section to the case statement in sem.adb
- -- Add an appropriate section to the case statement in exp_util.adb
- -- (Insert_Actions procedure)
- -- For a subexpression, add an appropriate section to the case
- -- statement in sem_eval.adb
- -- For a subexpression, add an appropriate section to the case
- -- statement in sem_res.adb
-
- -- All back ends must be made aware of the new node kind.
-
- -- Finally, four utility programs must be run:
-
- -- (Optional.) Run CSinfo to check that you have made the changes
- -- consistently. It checks most of the rules given above. This utility
- -- reads sinfo.ads and sinfo.adb and generates a report to standard
- -- output. This step is optional because XSinfo runs CSinfo.
-
- -- Run XSinfo to create sinfo.h, the corresponding C header. This
- -- utility reads sinfo.ads and generates sinfo.h. Note that it does
- -- not need to read sinfo.adb, since the contents of the body are
- -- algorithmically determinable from the spec.
-
- -- Run XTreeprs to create treeprs.ads, an updated version of the module
- -- that is used to drive the tree print routine. This utility reads (but
- -- does not modify) treeprs.adt, the template that provides the basic
- -- structure of the file, and then fills in the data from the comments
- -- in sinfo.ads.
-
- -- Run XNmake to create nmake.ads and nmake.adb, the package body and
- -- spec of the Nmake package which contains functions for constructing
- -- nodes.
-
- -- The above steps are done automatically by the build scripts when you do
- -- a full bootstrap.
-
- -- Note: sometime we could write a utility that actually generated the body
- -- of sinfo from the spec instead of simply checking it, since, as noted
- -- above, the contents of the body can be determined from the spec.
+ ----------------------------------------
+ -- Definitions of fields in tree node --
+ ----------------------------------------
+
+ -- The following fields are common to all nodes:
+
+ -- Nkind Indicates the kind of the node. This field is present
+ -- in all nodes.
+
+ -- Sloc Location (Source_Ptr) of the corresponding token
+ -- in the Source buffer. The individual node definitions
+ -- show which token is referenced by this pointer.
+
+ -- In_List A flag used to indicate if the node is a member
+ -- of a node list (see package Nlists).
+
+ -- Rewrite_Ins A flag set if a node is marked as a rewrite inserted
+ -- node as a result of a call to Mark_Rewrite_Insertion.
+
+ -- Small_Paren_Count
+ -- A 2-bit count used in subexpression nodes to indicate
+ -- the level of parentheses. The settings are 0,1,2 and
+ -- 3 for many. If the value is 3, then an auxiliary table
+ -- is used to indicate the real value, which is computed by
+ -- Paren_Count. Set to zero for nonsubexpression nodes.
+
+ -- Note: the required parentheses surrounding conditional
+ -- and quantified expressions count as a level of parens
+ -- for this purpose, so e.g. in X := (if A then B else C);
+ -- Paren_Count for the right side will be 1.
+
+ -- Comes_From_Source
+ -- This flag is present in all nodes. It is set if the
+ -- node is built by the scanner or parser, and clear if
+ -- the node is built by the analyzer or expander. It
+ -- indicates that the node corresponds to a construct
+ -- that appears in the original source program.
+
+ -- Analyzed This flag is present in all nodes. It is set when
+ -- a node is analyzed, and is used to avoid analyzing
+ -- the same node twice. Analysis includes expansion if
+ -- expansion is active, so in this case if the flag is
+ -- set it means the node has been analyzed and expanded.
+
+ -- Error_Posted This flag is present in all nodes. It is set when
+ -- an error message is posted which is associated with
+ -- the flagged node. This is used to avoid posting more
+ -- than one message on the same node.
+
+ -- Link For a node, points to the Parent. For a list, points
+ -- to the list header. Note that in the latter case, a
+ -- client cannot modify the link field. This field is
+ -- private to the Atree package (but is also modified
+ -- by the Nlists package).
+
+ -- The following additional fields are common to all entities (that is,
+ -- nodes whose Nkind is in N_Entity):
+
+ -- Ekind Entity type.
+
+ -- Convention Entity convention (Convention_Id value)
--------------------------------
-- Implicit Nodes in the Tree --
@@ -394,33 +383,33 @@ package Sinfo is
-- abbreviations are used:
-- "plus fields for binary operator"
- -- Chars (Name1) Name_Id for the operator
- -- Left_Opnd (Node2) left operand expression
- -- Right_Opnd (Node3) right operand expression
- -- Entity (Node4-Sem) defining entity for operator
- -- Associated_Node (Node4-Sem) for generic processing
- -- Do_Overflow_Check (Flag17-Sem) set if overflow check needed
- -- Has_Private_View (Flag11-Sem) set in generic units.
+ -- Chars Name_Id for the operator
+ -- Left_Opnd left operand expression
+ -- Right_Opnd right operand expression
+ -- Entity defining entity for operator
+ -- Associated_Node for generic processing
+ -- Do_Overflow_Check set if overflow check needed
+ -- Has_Private_View set in generic units.
-- "plus fields for unary operator"
- -- Chars (Name1) Name_Id for the operator
- -- Right_Opnd (Node3) right operand expression
- -- Entity (Node4-Sem) defining entity for operator
- -- Associated_Node (Node4-Sem) for generic processing
- -- Do_Overflow_Check (Flag17-Sem) set if overflow check needed
- -- Has_Private_View (Flag11-Sem) set in generic units.
+ -- Chars Name_Id for the operator
+ -- Right_Opnd right operand expression
+ -- Entity defining entity for operator
+ -- Associated_Node for generic processing
+ -- Do_Overflow_Check set if overflow check needed
+ -- Has_Private_View set in generic units.
-- "plus fields for expression"
- -- Paren_Count number of parentheses levels
- -- Etype (Node5-Sem) type of the expression
- -- Is_Overloaded (Flag5-Sem) >1 type interpretation exists
- -- Is_Static_Expression (Flag6-Sem) set for static expression
- -- Raises_Constraint_Error (Flag7-Sem) evaluation raises CE
- -- 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
- -- Assignment_OK (Flag15-Sem) set if modification is OK
- -- Is_Controlling_Actual (Flag16-Sem) set for controlling argument
+ -- Paren_Count number of parentheses levels
+ -- Etype type of the expression
+ -- Is_Overloaded >1 type interpretation exists
+ -- Is_Static_Expression set for static expression
+ -- Raises_Constraint_Error evaluation raises CE
+ -- Must_Not_Freeze set if must not freeze
+ -- Do_Range_Check set if a range check needed
+ -- Has_Dynamic_Length_Check set if length check inserted
+ -- Assignment_OK set if modification is OK
+ -- Is_Controlling_Actual 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
@@ -700,11 +689,9 @@ package Sinfo is
-- The following flag fields appear in various nodes:
- -- Do_Accessibility_Check
-- Do_Discriminant_Check
-- Do_Length_Check
-- Do_Storage_Check
- -- Do_Tag_Check
-- These flags are used in some specific cases by the front end, either
-- during semantic analysis or during expansion, and cannot be expected
@@ -792,7 +779,7 @@ package Sinfo is
-- section describes the usage of the semantic fields, which are used to
-- contain additional information determined during semantic analysis.
- -- Accept_Handler_Records (List5-Sem)
+ -- Accept_Handler_Records
-- This field is present only in an N_Accept_Alternative node. It is used
-- to temporarily hold the exception handler records from an accept
-- statement in a selective accept. These exception handlers will
@@ -800,19 +787,19 @@ package Sinfo is
-- built for this accept (see Expand_N_Selective_Accept procedure in
-- Exp_Ch9 for further details).
- -- Access_Types_To_Process (Elist2-Sem)
+ -- Access_Types_To_Process
-- Present in N_Freeze_Entity nodes for Incomplete or private types.
-- Contains the list of access types which may require specific treatment
-- when the nature of the type completion is completely known. An example
-- of such treatment is the generation of the associated_final_chain.
- -- Actions (List1-Sem)
+ -- Actions
-- This field contains a sequence of actions that are associated with the
-- node holding the field. See the individual node types for details of
-- how this field is used, as well as the description of the specific use
-- for a particular node type.
- -- Activation_Chain_Entity (Node3-Sem)
+ -- Activation_Chain_Entity
-- This is used in tree nodes representing task activators (blocks,
-- subprogram bodies, package declarations, and task bodies). It is
-- initially Empty, and then gets set to point to the entity for the
@@ -826,12 +813,12 @@ package Sinfo is
-- statement, the tasks are moved to the caller's chain, and the caller
-- activates them.
- -- Acts_As_Spec (Flag4-Sem)
+ -- Acts_As_Spec
-- A flag set in the N_Subprogram_Body node for a subprogram body which
-- is acting as its own spec. In the case of a library-level subprogram
-- the flag is set as well on the parent compilation unit node.
- -- Actual_Designated_Subtype (Node4-Sem)
+ -- Actual_Designated_Subtype
-- Present in N_Free_Statement and N_Explicit_Dereference nodes. If gigi
-- needs to known the dynamic constrained subtype of the designated
-- object, this attribute is set to that type. This is done for
@@ -840,38 +827,38 @@ package Sinfo is
-- the designated type is an unconstrained packed array and the
-- dereference is the prefix of a 'Size attribute reference.
- -- Address_Warning_Posted (Flag18-Sem)
+ -- Address_Warning_Posted
-- Present in N_Attribute_Definition nodes. Set to indicate that we have
-- posted a warning for the address clause regarding size or alignment
-- issues. Used to inhibit multiple redundant messages.
- -- Aggregate_Bounds (Node3-Sem)
+ -- Aggregate_Bounds
-- Present in array N_Aggregate nodes. If the bounds of the aggregate are
-- known at compile time, this field points to an N_Range node with those
-- bounds. Otherwise Empty.
- -- Alloc_For_BIP_Return (Flag1-Sem)
+ -- Alloc_For_BIP_Return
-- Present in N_Allocator nodes. True if the allocator is one of those
-- generated for a build-in-place return statement.
- -- All_Others (Flag11-Sem)
+ -- All_Others
-- Present in an N_Others_Choice node. This flag is set for an others
-- exception where all exceptions are to be caught, even those that are
-- not normally handled (in particular the tasking abort signal). This
-- is used for translation of the at end handler into a normal exception
-- handler.
- -- Aspect_On_Partial_View (Flag18)
+ -- Aspect_On_Partial_View
-- Present on an N_Aspect_Specification node. For an aspect that applies
-- to a type entity, indicates whether the specification appears on the
-- partial view of a private type or extension. Undefined for aspects
-- that apply to other entities.
- -- Aspect_Rep_Item (Node2-Sem)
+ -- Aspect_Rep_Item
-- Present in N_Aspect_Specification nodes. Points to the corresponding
-- pragma/attribute definition node used to process the aspect.
- -- Assignment_OK (Flag15-Sem)
+ -- Assignment_OK
-- This flag is set in a subexpression node for an object, indicating
-- that the associated object can be modified, even if this would not
-- normally be permissible (either by direct assignment, or by being
@@ -885,7 +872,7 @@ package Sinfo is
-- a Force_Evaluation call for an unchecked conversion, but this usage
-- is unclear and not documented ???
- -- Associated_Node (Node4-Sem)
+ -- Associated_Node
-- Present in nodes that can denote an entity: identifiers, character
-- literals, operator symbols, expanded names, operator nodes, and
-- attribute reference nodes (all these nodes have an Entity field).
@@ -900,16 +887,16 @@ package Sinfo is
-- Since the back end is expected to ignore generic templates, this is
-- harmless.
- -- Atomic_Sync_Required (Flag14-Sem)
+ -- Atomic_Sync_Required
-- This flag is set on a node for which atomic synchronization is
-- required for the corresponding reference or modification.
- -- At_End_Proc (Node1)
+ -- At_End_Proc
-- This field is present in an N_Handled_Sequence_Of_Statements node.
-- It contains an identifier reference for the cleanup procedure to be
-- called. See description of this node for further details.
- -- Backwards_OK (Flag6-Sem)
+ -- Backwards_OK
-- A flag present in the N_Assignment_Statement node. It is used only
-- if the type being assigned is an array type, and is set if analysis
-- determines that it is definitely safe to do the copy backwards, i.e.
@@ -923,7 +910,7 @@ package Sinfo is
-- cannot figure it out. If both flags Forwards_OK and Backwards_OK are
-- set, it means that the front end can assure no overlap of operands.
- -- Body_To_Inline (Node3-Sem)
+ -- Body_To_Inline
-- Present in subprogram declarations. Denotes analyzed but unexpanded
-- body of subprogram, to be used when inlining calls. Present when the
-- subprogram has an Inline pragma and inlining is enabled. If the
@@ -931,7 +918,7 @@ package Sinfo is
-- is a subprogram, the Body_To_Inline is the name of that entity, which
-- is used directly in later calls to the original subprogram.
- -- Body_Required (Flag13-Sem)
+ -- Body_Required
-- A flag that appears in the N_Compilation_Unit node indicating that
-- the corresponding unit requires a body. For the package case, this
-- indicates that a completion is required. In Ada 95, if the flag is not
@@ -941,17 +928,17 @@ package Sinfo is
-- a pragma Import or Interface applies, in which case no body is
-- permitted (in Ada 83 or Ada 95).
- -- By_Ref (Flag5-Sem)
+ -- By_Ref
-- Present in N_Simple_Return_Statement and N_Extended_Return_Statement,
-- this flag is set when the returned expression is already allocated on
-- the secondary stack and thus the result is passed by reference rather
-- than copied another time.
- -- Cleanup_Actions (List5-Sem)
+ -- Cleanup_Actions
-- Present in block statements created for transient blocks, contains
-- additional cleanup actions carried over from the transient scope.
- -- Check_Address_Alignment (Flag11-Sem)
+ -- Check_Address_Alignment
-- A flag present in N_Attribute_Definition clause for a 'Address
-- attribute definition. This flag is set if a dynamic check should be
-- generated at the freeze point for the entity to which this address
@@ -960,17 +947,17 @@ package Sinfo is
-- attribute definition clause is given, rather than testing this at the
-- freeze point.
- -- Comes_From_Extended_Return_Statement (Flag18-Sem)
+ -- Comes_From_Extended_Return_Statement
-- Present in N_Simple_Return_Statement nodes. True if this node was
-- constructed as part of the N_Extended_Return_Statement expansion.
- -- Compile_Time_Known_Aggregate (Flag18-Sem)
+ -- Compile_Time_Known_Aggregate
-- Present in N_Aggregate nodes. Set for aggregates which can be fully
-- evaluated at compile time without raising constraint error. Such
-- aggregates can be passed as is to the back end without any expansion.
-- See Exp_Aggr for specific conditions under which this flag gets set.
- -- Componentwise_Assignment (Flag14-Sem)
+ -- Componentwise_Assignment
-- Present in N_Assignment_Statement nodes. Set for a record assignment
-- where all that needs doing is to expand it into component-by-component
-- assignments. This is used internally for the case of tagged types with
@@ -980,7 +967,7 @@ package Sinfo is
-- expanding component assignments in this case, we never assign the _tag
-- field, but we recursively assign components of the parent type.
- -- Condition_Actions (List3-Sem)
+ -- Condition_Actions
-- This field appears in else-if nodes and in the iteration scheme node
-- for while loops. This field is only used during semantic processing to
-- temporarily hold actions inserted into the tree. In the tree passed
@@ -989,14 +976,14 @@ package Sinfo is
-- package Exp_Util, and also the expansion routines for the relevant
-- nodes.
- -- Context_Pending (Flag16-Sem)
+ -- Context_Pending
-- This field appears in Compilation_Unit nodes, to indicate that the
-- context of the unit is being compiled. Used to detect circularities
-- that are not otherwise detected by the loading mechanism. Such
-- circularities can occur in the presence of limited and non-limited
-- with_clauses that mention the same units.
- -- Controlling_Argument (Node1-Sem)
+ -- Controlling_Argument
-- This field is set in procedure and function call nodes if the call
-- is a dispatching call (it is Empty for a non-dispatching call). It
-- indicates the source of the call's controlling tag. For procedure
@@ -1007,7 +994,7 @@ package Sinfo is
-- tagged object. The latter is needed by the implementations of AI-239
-- and AI-260.
- -- Conversion_OK (Flag14-Sem)
+ -- Conversion_OK
-- 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,
@@ -1019,30 +1006,34 @@ package Sinfo is
-- direct conversion of the underlying integer result, with no regard to
-- the small operand.
- -- Convert_To_Return_False (Flag13-Sem)
+ -- Convert_To_Return_False
-- 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.???obsolete flag
+ -- value of False rather than raising an exception.
- -- Corresponding_Aspect (Node3-Sem)
+ -- Corresponding_Aspect
-- Present in N_Pragma node. Used to point back to the source aspect from
-- the corresponding pragma. This field is Empty for source pragmas.
- -- Corresponding_Body (Node5-Sem)
+ -- Corresponding_Body
-- This field is set in subprogram declarations, package declarations,
-- entry declarations of protected types, and in generic units. It points
-- to the defining entity for the corresponding body (NOT the node for
-- the body itself).
- -- Corresponding_Formal_Spec (Node3-Sem)
+ -- Corresponding_Entry_Body
+ -- Defined in N_Subprogram_Body. Set for subprogram bodies that implement
+ -- a protected type entry; points to the body for the entry.
+
+ -- Corresponding_Formal_Spec
-- This field is set in subprogram renaming declarations, where it points
-- to the defining entity for a formal subprogram in the case where the
-- renaming corresponds to a generic formal subprogram association in an
-- instantiation. The field is Empty if the renaming does not correspond
-- to such a formal association.
- -- Corresponding_Generic_Association (Node5-Sem)
+ -- Corresponding_Generic_Association
-- This field is defined for object declarations and object renaming
-- declarations. It is set for the declarations within an instance that
-- map generic formals to their actuals. If set, the field points either
@@ -1050,14 +1041,14 @@ package Sinfo is
-- generic_association which is the original parent of the expression or
-- name appearing in the declaration. This simplifies GNATprove queries.
- -- Corresponding_Integer_Value (Uint4-Sem)
+ -- Corresponding_Integer_Value
-- This field is set in real literals of fixed-point types (it is not
-- used for floating-point types). It contains the integer value used
-- to represent the fixed-point value. It is also set on the universal
-- real literals used to represent bounds of fixed-point base types
-- and their first named subtypes.
- -- Corresponding_Spec (Node5-Sem)
+ -- Corresponding_Spec
-- This field is set in subprogram, package, task, and protected body
-- nodes, where it points to the defining entity in the corresponding
-- spec. The attribute is also set in N_With_Clause nodes where it points
@@ -1069,46 +1060,41 @@ package Sinfo is
-- In Ada 2012, Corresponding_Spec is set on expression functions that
-- complete a subprogram declaration.
- -- Corresponding_Spec_Of_Stub (Node2-Sem)
+ -- Corresponding_Spec_Of_Stub
-- This field is present in subprogram, package, task, and protected body
-- stubs where it points to the corresponding spec of the stub. Due to
-- clashes in the structure of nodes, we cannot use Corresponding_Spec.
- -- Corresponding_Stub (Node3-Sem)
+ -- Corresponding_Stub
-- This field is present in an N_Subunit node. It holds the node in
-- the parent unit that is the stub declaration for the subunit. It is
-- set when analysis of the stub forces loading of the proper body. If
-- expansion of the proper body creates new declarative nodes, they are
-- inserted at the point of the corresponding_stub.
- -- Dcheck_Function (Node5-Sem)
+ -- Dcheck_Function
-- This field is present in an N_Variant node, It references the entity
-- for the discriminant checking function for the variant.
- -- Default_Expression (Node5-Sem)
+ -- Default_Expression
-- This field is Empty if there is no default expression. If there is a
-- simple default expression (one with no side effects), then this field
-- simply contains a copy of the Expression field (both point to the tree
-- for the default expression). Default_Expression is used for
-- conformance checking.
- -- Default_Storage_Pool (Node3-Sem)
+ -- Default_Storage_Pool
-- This field is present in N_Compilation_Unit_Aux nodes. It is set to a
-- copy of Opt.Default_Pool at the end of the compilation unit. See
-- package Opt for details. This is used for inheriting the
-- Default_Storage_Pool in child units.
- -- Discr_Check_Funcs_Built (Flag11-Sem)
+ -- Discr_Check_Funcs_Built
-- This flag is present in N_Full_Type_Declaration nodes. It is set when
-- discriminant checking functions are constructed. The purpose is to
-- avoid attempting to set these functions more than once.
- -- Do_Accessibility_Check (Flag13-Sem)
- -- This flag is set on N_Parameter_Specification nodes to indicate
- -- that an accessibility check is required for the parameter. It is
- -- not yet decided who takes care of this check (TBD ???).
-
- -- Do_Discriminant_Check (Flag3-Sem)
+ -- Do_Discriminant_Check
-- This flag is set on N_Selected_Component nodes to indicate that a
-- discriminant check is required using the discriminant check routine
-- associated with the selector. The actual check is generated by the
@@ -1119,18 +1105,18 @@ package Sinfo is
-- (and set if the assignment requires a discriminant check), and in type
-- conversion nodes (and set if the conversion requires a check).
- -- Do_Division_Check (Flag13-Sem)
+ -- Do_Division_Check
-- This flag is set on a division operator (/ mod rem) to indicate that
-- a zero divide check is required. The actual check is either dealt with
-- by the back end if Backend_Divide_Checks is set to true, or by the
-- front end itself if it is set to false.
- -- Do_Length_Check (Flag4-Sem)
+ -- Do_Length_Check
-- This flag is set in an N_Assignment_Statement, N_Op_And, N_Op_Or,
-- N_Op_Xor, or N_Type_Conversion node to indicate that a length check
-- is required. It is not determined who deals with this flag (???).
- -- Do_Overflow_Check (Flag17-Sem)
+ -- Do_Overflow_Check
-- This flag is set on an operator where an overflow check is required on
-- the operation. The actual check is either dealt with by the back end
-- if Backend_Overflow_Checks is set to true, or by the front end itself
@@ -1143,7 +1129,7 @@ package Sinfo is
-- MINIMIZED or ELIMINATED overflow checking mode (to make sure that we
-- properly process overflow checking for dependent expressions).
- -- Do_Range_Check (Flag9-Sem)
+ -- Do_Range_Check
-- This flag is set on an expression which appears in a context where a
-- range check is required. The target type is clear from the context.
-- The contexts in which this flag can appear are the following:
@@ -1184,7 +1170,7 @@ package Sinfo is
-- listed above (e.g. in a return statement), an additional type
-- conversion node is introduced to represent the required check.
- -- Do_Storage_Check (Flag17-Sem)
+ -- Do_Storage_Check
-- This flag is set in an N_Allocator node to indicate that a storage
-- check is required for the allocation, or in an N_Subprogram_Body node
-- to indicate that a stack check is required in the subprogram prologue.
@@ -1192,32 +1178,25 @@ package Sinfo is
-- to the runtime routine. The N_Subprogram_Body case is handled by the
-- backend, and all the semantics does is set the flag.
- -- Do_Tag_Check (Flag13-Sem)
- -- This flag is set on an N_Assignment_Statement, N_Function_Call,
- -- N_Procedure_Call_Statement, N_Type_Conversion,
- -- N_Simple_Return_Statement, or N_Extended_Return_Statement
- -- node to indicate that the tag check can be suppressed. It is not
- -- yet decided how this flag is used (TBD ???).
-
- -- Elaborate_Present (Flag4-Sem)
+ -- Elaborate_Present
-- This flag is set in the N_With_Clause node to indicate that pragma
-- Elaborate pragma appears for the with'ed units.
- -- Elaborate_All_Desirable (Flag9-Sem)
+ -- Elaborate_All_Desirable
-- This flag is set in the N_With_Clause mode to indicate that the static
-- elaboration processing has determined that an Elaborate_All pragma is
-- desirable for correct elaboration for this unit.
- -- Elaborate_All_Present (Flag14-Sem)
+ -- Elaborate_All_Present
-- This flag is set in the N_With_Clause node to indicate that a
-- pragma Elaborate_All pragma appears for the with'ed units.
- -- Elaborate_Desirable (Flag11-Sem)
+ -- Elaborate_Desirable
-- This flag is set in the N_With_Clause mode to indicate that the static
-- elaboration processing has determined that an Elaborate pragma is
-- desirable for correct elaboration for this unit.
- -- Else_Actions (List3-Sem)
+ -- Else_Actions
-- This field is present in if expression nodes. During code
-- expansion we use the Insert_Actions procedure (in Exp_Util) to insert
-- actions at an appropriate place in the tree to get elaborated at the
@@ -1228,13 +1207,13 @@ package Sinfo is
-- need for this field, so in the tree passed to Gigi, this field is
-- always set to No_List.
- -- Enclosing_Variant (Node2-Sem)
+ -- Enclosing_Variant
-- This field is present in the N_Variant node and identifies the Node_Id
-- corresponding to the immediately enclosing variant when the variant is
-- nested, and N_Empty otherwise. Set during semantic processing of the
-- variant part of a record type.
- -- Entity (Node4-Sem)
+ -- Entity
-- Appears in all direct names (identifiers, character literals, and
-- operator symbols), as well as expanded names, and attributes that
-- denote entities, such as 'Class. Points to entity for corresponding
@@ -1272,12 +1251,12 @@ package Sinfo is
-- aspects must be used to store arbitrary expressions for later semantic
-- checks. See section on aspect specifications for details.
- -- Entity_Or_Associated_Node (Node4-Sem)
+ -- Entity_Or_Associated_Node
-- A synonym for both Entity and Associated_Node. Used by convention in
-- the code when referencing this field in cases where it is not known
-- whether the field contains an Entity or an Associated_Node.
- -- Etype (Node5-Sem)
+ -- Etype
-- Appears in all expression nodes, all direct names, and all entities.
-- Points to the entity for the related type. Set after type resolution.
-- Normally this is the actual subtype of the expression. However, in
@@ -1289,14 +1268,14 @@ package Sinfo is
-- points to an essentially arbitrary choice from the possible set of
-- types.
- -- Exception_Junk (Flag8-Sem)
+ -- Exception_Junk
-- This flag is set in a various nodes appearing in a statement sequence
-- to indicate that the corresponding node is an artifact of the
-- generated code for exception handling, and should be ignored when
-- analyzing the control flow of the relevant sequence of statements
-- (e.g. to check that it does not end with a bad return statement).
- -- Exception_Label (Node5-Sem)
+ -- Exception_Label
-- Appears in N_Push_xxx_Label nodes. Points to the entity of the label
-- to be used for transforming the corresponding exception into a goto,
-- or contains Empty, if this exception is not to be transformed. Also
@@ -1305,7 +1284,7 @@ package Sinfo is
-- to allow a goto is required (and this field contains the label for
-- this goto). See Exp_Ch11.Expand_Local_Exception_Handlers for details.
- -- Expansion_Delayed (Flag11-Sem)
+ -- Expansion_Delayed
-- Set on aggregates and extension aggregates that need a top-down rather
-- than bottom-up expansion. Typically aggregate expansion happens bottom
-- up. For nested aggregates the expansion is delayed until the enclosing
@@ -1313,27 +1292,27 @@ package Sinfo is
-- delay it we set this flag. This is done to avoid creating a temporary
-- for each level of a nested aggregate, and also to prevent the
-- premature generation of constraint checks. This is also a requirement
- -- if we want to generate the proper attachment to the internal????
+ -- if we want to generate the proper attachment to the internal
-- finalization lists (for record with controlled components). Top down
-- expansion of aggregates is also used for in-place array aggregate
-- assignment or initialization. When the full context is known, the
-- target of the assignment or initialization is used to generate the
- -- left-hand side of individual assignment to each sub-component.
+ -- left-hand side of individual assignment to each subcomponent.
- -- Expression_Copy (Node2-Sem)
+ -- Expression_Copy
-- Present in N_Pragma_Argument_Association nodes. Contains a copy of the
-- original expression. This field is best used to store pragma-dependent
-- modifications performed on the original expression such as replacement
-- of the current type instance or substitutions of primitives.
- -- First_Inlined_Subprogram (Node3-Sem)
+ -- First_Inlined_Subprogram
-- Present in the N_Compilation_Unit node for the main program. Points
-- to a chain of entities for subprograms that are to be inlined. The
-- Next_Inlined_Subprogram field of these entities is used as a link
-- pointer with Empty marking the end of the list. This field is Empty
-- if there are no inlined subprograms or inlining is not active.
- -- First_Named_Actual (Node4-Sem)
+ -- First_Named_Actual
-- Present in procedure call statement and function call nodes, and also
-- in Intrinsic nodes. Set during semantic analysis to point to the first
-- named parameter where parameters are ordered by declaration order (as
@@ -1341,7 +1320,7 @@ package Sinfo is
-- named associations). Note: this field points to the explicit actual
-- parameter itself, not the N_Parameter_Association node (its parent).
- -- First_Real_Statement (Node2-Sem)
+ -- First_Real_Statement
-- Present in N_Handled_Sequence_Of_Statements node. Normally set to
-- Empty. Used only when declarations are moved into the statement part
-- of a construct as a result of wrapping an AT END handler that is
@@ -1350,16 +1329,16 @@ package Sinfo is
-- statement, i.e. the statement that used to be first in the statement
-- list before the declarations were prepended.
- -- First_Subtype_Link (Node5-Sem)
+ -- First_Subtype_Link
-- Present in N_Freeze_Entity node for an anonymous base type that is
-- implicitly created by the declaration of a first subtype. It points
-- to the entity for the first subtype.
- -- Float_Truncate (Flag11-Sem)
+ -- Float_Truncate
-- A flag present in type conversion nodes. This is used for float to
-- integer conversions where truncation is required rather than rounding.
- -- Forwards_OK (Flag5-Sem)
+ -- Forwards_OK
-- A flag present in the N_Assignment_Statement node. It is used only
-- if the type being assigned is an array type, and is set if analysis
-- determines that it is definitely safe to do the copy forwards, i.e.
@@ -1373,20 +1352,20 @@ package Sinfo is
-- cannot figure it out. If both flags Forwards_OK and Backwards_OK are
-- set, it means that the front end can assure no overlap of operands.
- -- From_Aspect_Specification (Flag13-Sem)
+ -- From_Aspect_Specification
-- Processing of aspect specifications typically results in insertion in
-- the tree of corresponding pragma or attribute definition clause nodes.
-- These generated nodes have the From_Aspect_Specification flag set to
-- indicate that they came from aspect specifications originally.
- -- From_At_End (Flag4-Sem)
+ -- From_At_End
-- This flag is set on an N_Raise_Statement node if it corresponds to
-- the reraise statement generated as the last statement of an AT END
-- handler when SJLJ exception handling is active. It is used to stop
-- a bogus violation of restriction (No_Exception_Propagation), bogus
-- because if the restriction is set, the reraise is not generated.
- -- From_At_Mod (Flag4-Sem)
+ -- From_At_Mod
-- This flag is set on the attribute definition clause node that is
-- generated by a transformation of an at mod phrase in a record
-- representation clause. This is used to give slightly different (Ada 83
@@ -1396,19 +1375,19 @@ package Sinfo is
-- must be a multiple of the given value, and the representation clause
-- is considered to be type specific instead of subtype specific.
- -- From_Conditional_Expression (Flag1-Sem)
+ -- From_Conditional_Expression
-- This flag is set on if and case statements generated by the expansion
-- of if and case expressions respectively. The flag is used to suppress
-- any finalization of controlled objects found within these statements.
- -- From_Default (Flag6-Sem)
+ -- From_Default
-- This flag is set on the subprogram renaming declaration created in an
-- instance for a formal subprogram, when the formal is declared with a
-- box, and there is no explicit actual. If the flag is present, the
-- declaration is treated as an implicit reference to the formal in the
-- ali file.
- -- Generalized_Indexing (Node4-Sem)
+ -- Generalized_Indexing
-- Present in N_Indexed_Component nodes. Set for Indexed_Component nodes
-- that are Ada 2012 container indexing operations. The value of the
-- attribute is a function call (possibly dereferenced) that corresponds
@@ -1416,12 +1395,12 @@ package Sinfo is
-- expansion, the source node is rewritten as the resolved generalized
-- indexing.
- -- Generic_Parent (Node5-Sem)
+ -- Generic_Parent
-- Generic_Parent is defined on declaration nodes that are instances. The
-- value of Generic_Parent is the generic entity from which the instance
-- is obtained.
- -- Generic_Parent_Type (Node4-Sem)
+ -- Generic_Parent_Type
-- Generic_Parent_Type is defined on Subtype_Declaration nodes for the
-- actuals of formal private and derived types. Within the instance, the
-- operations on the actual are those inherited from the parent. For a
@@ -1429,7 +1408,7 @@ package Sinfo is
-- Generic_Parent_Type is also used in an instance to determine whether a
-- private operation overrides an inherited one.
- -- Handler_List_Entry (Node2-Sem)
+ -- Handler_List_Entry
-- This field is present in N_Object_Declaration nodes. It is set only
-- for the Handler_Record entry generated for an exception in zero cost
-- exception handling mode. It references the corresponding item in the
@@ -1437,26 +1416,26 @@ package Sinfo is
-- handler is deleted during optimization. For further details on why
-- this is required, see Exp_Ch11.Remove_Handler_Entries.
- -- Has_Dereference_Action (Flag13-Sem)
+ -- Has_Dereference_Action
-- This flag is present in N_Explicit_Dereference nodes. It is set to
-- indicate that the expansion has aready produced a call to primitive
-- Dereference of a System.Checked_Pools.Checked_Pool implementation.
-- Such dereference actions are produced for debugging purposes.
- -- Has_Dynamic_Length_Check (Flag10-Sem)
+ -- Has_Dynamic_Length_Check
-- This flag is present in all expression nodes. It is set to indicate
-- that one of the routines in unit Checks has generated a length check
-- action which has been inserted at the flagged node. This is used to
-- avoid the generation of duplicate checks.
- -- Has_Local_Raise (Flag8-Sem)
+ -- Has_Local_Raise
-- 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
-- always be set if Local_Raise_Statements is non-empty, but can also be
-- set as a result of generation of N_Raise_xxx nodes, or flags set in
-- nodes requiring generation of back end checks.
- -- Has_No_Elaboration_Code (Flag17-Sem)
+ -- Has_No_Elaboration_Code
-- A flag that appears in the N_Compilation_Unit node to indicate whether
-- or not elaboration code is present for this unit. It is initially set
-- true for subprogram specs and bodies and for all generic units and
@@ -1467,7 +1446,7 @@ package Sinfo is
-- generate elaboration code, and non-preelaborated packages which do
-- not generate elaboration code.
- -- Has_Pragma_Suppress_All (Flag14-Sem)
+ -- Has_Pragma_Suppress_All
-- This flag is set in an N_Compilation_Unit node if the Suppress_All
-- pragma appears anywhere in the unit. This accommodates the rather
-- strange placement rules of other compilers (DEC permits it at the
@@ -1476,60 +1455,60 @@ package Sinfo is
-- Suppress (All_Checks) appearing at the start of the configuration
-- pragmas for the unit.
- -- Has_Private_View (Flag11-Sem)
+ -- Has_Private_View
-- A flag present in generic nodes that have an entity, to indicate that
-- the node has a private type. Used to exchange private and full
-- declarations if the visibility at instantiation is different from the
-- visibility at generic definition.
- -- Has_Relative_Deadline_Pragma (Flag9-Sem)
+ -- Has_Relative_Deadline_Pragma
-- A flag present in N_Subprogram_Body and N_Task_Definition nodes to
-- flag the presence of a pragma Relative_Deadline.
- -- Has_Self_Reference (Flag13-Sem)
+ -- Has_Self_Reference
-- Present in N_Aggregate and N_Extension_Aggregate. Indicates that one
-- of the expressions contains an access attribute reference to the
-- enclosing type. Such a self-reference can only appear in default-
-- initialized aggregate for a record type.
- -- Has_SP_Choice (Flag15-Sem)
+ -- Has_SP_Choice
-- Present in all nodes containing a Discrete_Choices field (N_Variant,
-- N_Case_Expression_Alternative, N_Case_Statement_Alternative). Set to
-- True if the Discrete_Choices list has at least one occurrence of a
-- statically predicated subtype.
- -- Has_Storage_Size_Pragma (Flag5-Sem)
+ -- Has_Storage_Size_Pragma
-- A flag present in an N_Task_Definition node to flag the presence of a
-- Storage_Size pragma.
- -- Has_Target_Names (Flag8-Sem)
+ -- Has_Target_Names
-- Present in assignment statements. Indicates that the RHS contains
-- target names (see AI12-0125-3) and must be expanded accordingly.
- -- Has_Wide_Character (Flag11-Sem)
+ -- Has_Wide_Character
-- Present in string literals, set if any wide character (i.e. character
-- code outside the Character range but within Wide_Character range)
-- appears in the string. Used to implement pragma preference rules.
- -- Has_Wide_Wide_Character (Flag13-Sem)
+ -- Has_Wide_Wide_Character
-- Present in string literals, set if any wide character (i.e. character
-- code outside the Wide_Character range) appears in the string. Used to
-- implement pragma preference rules.
- -- Header_Size_Added (Flag11-Sem)
+ -- Header_Size_Added
-- Present in N_Attribute_Reference nodes, set only for attribute
-- Max_Size_In_Storage_Elements. The flag indicates that the size of the
-- hidden list header used by the runtime finalization support has been
-- added to the size of the prefix. The flag also prevents the infinite
-- expansion of the same attribute in the said context.
- -- Hidden_By_Use_Clause (Elist5-Sem)
+ -- Hidden_By_Use_Clause
-- An entity list present in use clauses that appear within
-- instantiations. For the resolution of local entities, entities
-- introduced by these use clauses have priority over global ones,
-- and outer entities must be explicitly hidden/restored on exit.
- -- Implicit_With (Flag16-Sem)
+ -- Implicit_With
-- Present in N_With_Clause nodes. The flag indicates that the clause
-- does not comes from source and introduces an implicit dependency on
-- a particular unit. Such implicit with clauses are generated by:
@@ -1546,12 +1525,12 @@ package Sinfo is
-- * RTSfind - The compiler generates code which references entities
-- from the runtime.
- -- Import_Interface_Present (Flag16-Sem)
+ -- Import_Interface_Present
-- This flag is set in an Interface or Import pragma if a matching
-- pragma of the other kind is also present. This is used to avoid
-- generating some unwanted error messages.
- -- Includes_Infinities (Flag11-Sem)
+ -- Includes_Infinities
-- This flag is present in N_Range nodes. It is set for the range of
-- unconstrained float types defined in Standard, which include not only
-- the given range of values, but also legitimately can include infinite
@@ -1559,54 +1538,54 @@ package Sinfo is
-- range is given by the programmer, even if that range is identical to
-- the range for Float.
- -- Incomplete_View (Node2-Sem)
+ -- Incomplete_View
-- Present in full type declarations that are completions of incomplete
-- type declarations. Denotes the corresponding incomplete type
-- declaration. Used to simplify the retrieval of primitive operations
-- that may be declared between the partial and the full view of an
-- untagged type.
- -- Inherited_Discriminant (Flag13-Sem)
+ -- Inherited_Discriminant
-- This flag is present in N_Component_Association nodes. It indicates
-- that a given component association in an extension aggregate is the
-- value obtained from a constraint on an ancestor. Used to prevent
-- double expansion when the aggregate has expansion delayed.
- -- Instance_Spec (Node5-Sem)
+ -- Instance_Spec
-- This field is present in generic instantiation nodes, and also in
-- formal package declaration nodes (formal package declarations are
-- treated in a manner very similar to package instantiations). It points
-- to the node for the spec of the instance, inserted as part of the
-- semantic processing for instantiations in Sem_Ch12.
- -- Is_Abort_Block (Flag4-Sem)
+ -- Is_Abort_Block
-- Present in N_Block_Statement nodes. True if the block protects a list
-- of statements with an Abort_Defer / Abort_Undefer_Direct pair.
- -- Is_Accessibility_Actual (Flag13-Sem)
+ -- Is_Accessibility_Actual
-- Present in N_Parameter_Association nodes. True if the parameter is
-- an extra actual that carries the accessibility level of the actual
-- for an access parameter, in a function that dispatches on result and
-- is called in a dispatching context. Used to prevent a formal/actual
-- mismatch when the call is rewritten as a dispatching call.
- -- Is_Analyzed_Pragma (Flag5-Sem)
+ -- Is_Analyzed_Pragma
-- Present in N_Pragma nodes. Set for delayed pragmas that require a two
-- step analysis. The initial step is peformed by routine Analyze_Pragma
-- and verifies the overall legality of the pragma. The second step takes
-- place in the various Analyze_xxx_In_Decl_Part routines which perform
-- full analysis. The flag prevents the reanalysis of a delayed pragma.
- -- Is_Asynchronous_Call_Block (Flag7-Sem)
+ -- Is_Asynchronous_Call_Block
-- A flag set in a Block_Statement node to indicate that it is the
-- expansion of an asynchronous entry call. Such a block needs cleanup
-- handler to assure that the call is cancelled.
- -- Is_Boolean_Aspect (Flag16-Sem)
+ -- Is_Boolean_Aspect
-- Present in N_Aspect_Specification node. Set if the aspect is for a
-- boolean aspect (i.e. Aspect_Id is in Boolean_Aspect subtype).
- -- Is_Checked (Flag11-Sem)
+ -- Is_Checked
-- Present in N_Aspect_Specification and N_Pragma nodes. Set for an
-- assertion aspect or pragma, or check pragma for an assertion, that
-- is to be checked at run time. If either Is_Checked or Is_Ignored
@@ -1615,35 +1594,35 @@ package Sinfo is
-- be further modified (in some cases these flags are copied when a
-- pragma is rewritten).
- -- Is_Checked_Ghost_Pragma (Flag3-Sem)
+ -- Is_Checked_Ghost_Pragma
-- This flag is present in N_Pragma nodes. It is set when the pragma is
-- related to a checked Ghost entity or encloses a checked Ghost entity.
-- This flag has no relation to Is_Checked.
- -- Is_Component_Left_Opnd (Flag13-Sem)
- -- Is_Component_Right_Opnd (Flag14-Sem)
+ -- Is_Component_Left_Opnd
+ -- Is_Component_Right_Opnd
-- Present in concatenation nodes, to indicate that the corresponding
-- operand is of the component type of the result. Used in resolving
-- concatenation nodes in instances.
- -- Is_Controlling_Actual (Flag16-Sem)
+ -- Is_Controlling_Actual
-- This flag is set on an expression that is a controlling argument in
-- a dispatching call. It is off in all other cases. See Sem_Disp for
-- details of its use.
- -- Is_Declaration_Level_Node (Flag5-Sem)
+ -- Is_Declaration_Level_Node
-- Present in call marker and instantiation nodes. Set when the constuct
-- appears within the declarations of a block statement, an entry body,
-- a subprogram body, or a task body. The flag aids the ABE Processing
-- phase to catch certain forms of guaranteed ABEs.
- -- Is_Delayed_Aspect (Flag14-Sem)
+ -- Is_Delayed_Aspect
-- Present in N_Pragma and N_Attribute_Definition_Clause nodes which
-- come from aspect specifications, where the evaluation of the aspect
-- must be delayed to the freeze point. This flag is also set True in
-- the corresponding N_Aspect_Specification node.
- -- Is_Disabled (Flag15-Sem)
+ -- Is_Disabled
-- A flag set in an N_Aspect_Specification or N_Pragma node if there was
-- a Check_Policy or Assertion_Policy (or in the case of a Debug_Pragma)
-- a Debug_Policy pragma that resulted in totally disabling the flagged
@@ -1651,22 +1630,22 @@ package Sinfo is
-- If this flag is set, the aspect or policy is not analyzed for semantic
-- correctness, so any expressions etc will not be marked as analyzed.
- -- Is_Dispatching_Call (Flag6-Sem)
+ -- Is_Dispatching_Call
-- Present in call marker nodes. Set when the related call which prompted
-- the creation of the marker is dispatching.
- -- Is_Dynamic_Coextension (Flag18-Sem)
+ -- Is_Dynamic_Coextension
-- Present in allocator nodes, to indicate that this is an allocator
-- for an access discriminant of a dynamically allocated object. The
-- coextension must be deallocated and finalized at the same time as
-- the enclosing object. The partner flag Is_Static_Coextension must
-- be cleared before setting this flag to True.
- -- Is_Effective_Use_Clause (Flag1-Sem)
+ -- Is_Effective_Use_Clause
-- Present in both N_Use_Type_Clause and N_Use_Package_Clause to indicate
-- a use clause is "used" in the current source.
- -- Is_Elaboration_Checks_OK_Node (Flag1-Sem)
+ -- Is_Elaboration_Checks_OK_Node
-- Present in the following nodes:
--
-- assignment statement
@@ -1687,12 +1666,12 @@ package Sinfo is
-- of run-time ABE checks. This flag detemines whether the ABE Processing
-- phase generates conditional ABE checks and guaranteed ABE failures.
- -- Is_Elaboration_Code (Flag9-Sem)
+ -- Is_Elaboration_Code
-- Present in assignment statements. Set for an assignment which updates
-- the elaboration flag of a package or subprogram when the corresponding
-- body is successfully elaborated.
- -- Is_Elaboration_Warnings_OK_Node (Flag3-Sem)
+ -- Is_Elaboration_Warnings_OK_Node
-- Present in the following nodes:
--
-- attribute reference
@@ -1712,27 +1691,27 @@ package Sinfo is
-- are enabled. This flag determines whether the ABE processing phase
-- generates diagnostics on various elaboration issues.
- -- Is_Entry_Barrier_Function (Flag8-Sem)
+ -- Is_Entry_Barrier_Function
-- This flag is set on N_Subprogram_Declaration and N_Subprogram_Body
-- nodes which emulate the barrier function of a protected entry body.
-- The flag is used when checking for incorrect use of Current_Task.
- -- Is_Expanded_Build_In_Place_Call (Flag11-Sem)
+ -- Is_Expanded_Build_In_Place_Call
-- This flag is set in an N_Function_Call node to indicate that the extra
-- actuals to support a build-in-place style of call have been added to
-- the call.
- -- Is_Expanded_Contract (Flag1-Sem)
+ -- Is_Expanded_Contract
-- Present in N_Contract nodes. Set if the contract has already undergone
-- expansion activities.
- -- Is_Finalization_Wrapper (Flag9-Sem)
+ -- Is_Finalization_Wrapper
-- This flag is present in N_Block_Statement nodes. It is set when the
-- block acts as a wrapper of a handled construct which has controlled
-- objects. The wrapper prevents interference between exception handlers
-- and At_End handlers.
- -- Is_Generic_Contract_Pragma (Flag2-Sem)
+ -- Is_Generic_Contract_Pragma
-- This flag is present in N_Pragma nodes. It is set when the pragma is
-- a source construct, applies to a generic unit or its body, and denotes
-- one of the following contract-related annotations:
@@ -1755,12 +1734,12 @@ package Sinfo is
-- Refined_State
-- Test_Case
- -- Is_Homogeneous_Aggregate (Flag14)
- -- A flag set on an Ada 2020 aggregate that uses square brackets as
+ -- Is_Homogeneous_Aggregate
+ -- A flag set on an Ada 2022 aggregate that uses square brackets as
-- delimiters, and thus denotes an array or container aggregate, or
-- the prefix of a reduction attribute.
- -- Is_Ignored (Flag9-Sem)
+ -- Is_Ignored
-- A flag set in an N_Aspect_Specification or N_Pragma node if there was
-- a Check_Policy or Assertion_Policy (or in the case of a Debug_Pragma)
-- a Debug_Policy pragma that specified a policy of IGNORE, DISABLE, or
@@ -1774,29 +1753,29 @@ package Sinfo is
-- aspect/pragma is fully analyzed and checked for other syntactic
-- and semantic errors, but it does not have any semantic effect.
- -- Is_Ignored_Ghost_Pragma (Flag8-Sem)
+ -- Is_Ignored_Ghost_Pragma
-- This flag is present in N_Pragma nodes. It is set when the pragma is
-- related to an ignored Ghost entity or encloses ignored Ghost entity.
-- This flag has no relation to Is_Ignored.
- -- Is_In_Discriminant_Check (Flag11-Sem)
+ -- Is_In_Discriminant_Check
-- This flag is present in a selected component, and is used to indicate
-- that the reference occurs within a discriminant check. The
-- significance is that optimizations based on assuming that the
-- discriminant check has a correct value cannot be performed in this
-- case (or the discriminant check may be optimized away).
- -- Is_Inherited_Pragma (Flag4-Sem)
+ -- Is_Inherited_Pragma
-- This flag is set in an N_Pragma node that appears in a N_Contract node
-- to indicate that the pragma has been inherited from a parent context.
- -- Is_Initialization_Block (Flag1-Sem)
+ -- Is_Initialization_Block
-- Defined in block nodes. Set when the block statement was created by
-- the finalization machinery to wrap initialization statements. This
-- flag aids the ABE Processing phase to suppress the diagnostics of
-- finalization actions in initialization contexts.
- -- Is_Known_Guaranteed_ABE (Flag18-Sem)
+ -- Is_Known_Guaranteed_ABE
-- NOTE: this flag is shared between the legacy ABE mechanism and the
-- default ABE mechanism.
--
@@ -1816,22 +1795,22 @@ package Sinfo is
-- instantiation, as well as to prevent the reexamination of the node by
-- the ABE Processing phase.
- -- Is_Machine_Number (Flag11-Sem)
+ -- Is_Machine_Number
-- This flag is set in an N_Real_Literal node to indicate that the value
-- is a machine number. This avoids some unnecessary cases of converting
-- real literals to machine numbers.
- -- Is_Null_Loop (Flag16-Sem)
+ -- Is_Null_Loop
-- This flag is set in an N_Loop_Statement node if the corresponding loop
-- can be determined to be null at compile time. This is used to remove
-- the loop entirely at expansion time.
- -- Is_Overloaded (Flag5-Sem)
+ -- Is_Overloaded
-- A flag present in all expression nodes. Used temporarily during
-- overloading determination. The setting of this flag is not relevant
-- once overloading analysis is complete.
- -- Is_Power_Of_2_For_Shift (Flag13-Sem)
+ -- Is_Power_Of_2_For_Shift
-- A flag present only in N_Op_Expon nodes. It is set when the
-- exponentiation is of the form 2 ** N, where the type of N is an
-- unsigned integral subtype whose size does not exceed the size of
@@ -1843,37 +1822,37 @@ 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)
+ -- Is_Preelaborable_Call
-- Present in call marker nodes. Set when the related call is non-static
-- but preelaborable.
- -- Is_Prefixed_Call (Flag17-Sem)
+ -- Is_Prefixed_Call
-- 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
-- is used to prevent accidental overloadings in an instance, when a
-- primitive operation and a private record component may be homographs.
- -- Is_Protected_Subprogram_Body (Flag7-Sem)
+ -- Is_Protected_Subprogram_Body
-- A flag set in a Subprogram_Body block to indicate that it is the
-- implementation of a protected subprogram. Such a body needs cleanup
-- handler to make sure that the associated protected object is unlocked
-- when the subprogram completes.
- -- Is_Qualified_Universal_Literal (Flag4-Sem)
+ -- Is_Qualified_Universal_Literal
-- Present in N_Qualified_Expression nodes. Set when the qualification is
-- converting a universal literal to a specific type. Such qualifiers aid
-- the resolution of accidental overloading of binary or unary operators
-- which may occur in instances.
- -- Is_Read (Flag4-Sem)
+ -- Is_Read
-- Present in variable reference markers. Set when the original variable
-- reference constitues a read of the variable.
- -- Is_Source_Call (Flag4-Sem)
+ -- Is_Source_Call
-- Present in call marker nodes. Set when the related call came from
-- source.
- -- Is_SPARK_Mode_On_Node (Flag2-Sem)
+ -- Is_SPARK_Mode_On_Node
-- Present in the following nodes:
--
-- assignment statement
@@ -1894,59 +1873,59 @@ package Sinfo is
-- This flag determines when the SPARK model of elaboration be activated
-- by the ABE Processing phase.
- -- Is_Static_Coextension (Flag14-Sem)
+ -- Is_Static_Coextension
-- Present in N_Allocator nodes. Set if the allocator is a coextension
-- of an object allocated on the stack rather than the heap. The partner
-- flag Is_Dynamic_Coextension must be cleared before setting this flag
-- to True.
- -- Is_Static_Expression (Flag6-Sem)
+ -- Is_Static_Expression
-- Indicates that an expression is a static expression according to the
-- rules in RM-4.9. See Sem_Eval for details.
- -- Is_Subprogram_Descriptor (Flag16-Sem)
+ -- Is_Subprogram_Descriptor
-- Present in N_Object_Declaration, and set only for the object
-- declaration generated for a subprogram descriptor in fast exception
-- mode. See Exp_Ch11 for details of use.
- -- Is_Task_Allocation_Block (Flag6-Sem)
+ -- Is_Task_Allocation_Block
-- A flag set in a Block_Statement node to indicate that it is the
-- expansion of a task allocator, or the allocator of an object
-- containing tasks. Such a block requires a cleanup handler to call
-- Expunge_Unactivated_Tasks to complete any tasks that have been
-- allocated but not activated when the allocator completes abnormally.
- -- Is_Task_Body_Procedure (Flag1-Sem)
+ -- Is_Task_Body_Procedure
-- This flag is set on N_Subprogram_Declaration and N_Subprogram_Body
-- nodes which emulate the body of a task unit.
- -- Is_Task_Master (Flag5-Sem)
+ -- Is_Task_Master
-- A flag set in a Subprogram_Body, Block_Statement, or Task_Body node to
-- indicate that the construct is a task master (i.e. has declared tasks
-- or declares an access to a task type).
- -- Is_Write (Flag5-Sem)
+ -- Is_Write
-- Present in variable reference markers. Set when the original variable
-- reference constitues a write of the variable.
- -- Itype (Node1-Sem)
+ -- Itype
-- Used in N_Itype_Reference node to reference an itype for which it is
-- important to ensure that it is defined. See description of this node
-- for further details.
- -- Kill_Range_Check (Flag11-Sem)
+ -- Kill_Range_Check
-- Used in an N_Unchecked_Type_Conversion node to indicate that the
-- result should not be subjected to range checks. This is used for the
-- implementation of Normalize_Scalars.
- -- Label_Construct (Node2-Sem)
+ -- Label_Construct
-- 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. 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)
+ -- Library_Unit
-- In a stub node, Library_Unit points to the compilation unit node of
-- the corresponding subunit.
--
@@ -1976,7 +1955,7 @@ package Sinfo is
-- described above). Instead for a child unit, implicit with's are
-- generated for all parents.
- -- Local_Raise_Statements (Elist1)
+ -- Local_Raise_Statements
-- This field is present in exception handler nodes. It is set to
-- No_Elist in the normal case. If there is at least one raise statement
-- which can potentially be handled as a local raise, then this field
@@ -1987,12 +1966,12 @@ 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 (List5-Sem)
+ -- Loop_Actions
-- 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.
- -- Limited_View_Installed (Flag18-Sem)
+ -- Limited_View_Installed
-- Present in With_Clauses and in package specifications. If set on
-- with_clause, it indicates that this clause has created the current
-- limited view of the designated package. On a package specification, it
@@ -2000,13 +1979,13 @@ package Sinfo is
-- package is mentioned in a limited_with_clause in the closure of the
-- unit being compiled.
- -- Local_Raise_Not_OK (Flag7-Sem)
+ -- Local_Raise_Not_OK
-- Present in N_Exception_Handler nodes. Set if the handler contains
-- a construct (reraise statement, or call to subprogram in package
-- GNAT.Current_Exception) that makes the handler unsuitable as a target
-- for a local raise (one that could otherwise be converted to a goto).
- -- Must_Be_Byte_Aligned (Flag14-Sem)
+ -- Must_Be_Byte_Aligned
-- This flag is present in N_Attribute_Reference nodes. It can be set
-- only for the Address and Unrestricted_Access attributes. If set it
-- means that the object for which the address/access is given must be on
@@ -2019,7 +1998,7 @@ package Sinfo is
-- has more information about type layout and may be able to (but is not
-- guaranteed to) prevent making unnecessary copies.
- -- Must_Not_Freeze (Flag8-Sem)
+ -- Must_Not_Freeze
-- A flag present in all expression nodes. Normally expressions cause
-- freezing as described in the RM. If this flag is set, then this is
-- inhibited. This is used by the analyzer and expander to label nodes
@@ -2028,19 +2007,19 @@ package Sinfo is
-- present in an N_Subtype_Indication node, since we also use these in
-- calls to Freeze_Expression.
- -- Next_Entity (Node2-Sem)
+ -- Next_Entity
-- Present in defining identifiers, defining character literals, and
-- defining operator symbols (i.e. in all entities). The entities of a
-- scope are chained, and this field is used as the forward pointer for
-- this list. See Einfo for further details.
- -- Next_Exit_Statement (Node3-Sem)
+ -- Next_Exit_Statement
-- Present in N_Exit_Statement nodes. The exit statements for a loop are
-- chained (in reverse order of appearance) from the First_Exit_Statement
-- field of the E_Loop entity for the loop. Next_Exit_Statement points to
-- the next entry on this chain (Empty = end of list).
- -- Next_Implicit_With (Node3-Sem)
+ -- Next_Implicit_With
-- Present in N_With_Clause. Part of a chain of with_clauses generated
-- in rtsfind to indicate implicit dependencies on predefined units. Used
-- to prevent multiple with_clauses for the same unit in a given context.
@@ -2050,7 +2029,7 @@ package Sinfo is
-- that any subprogram call is examined after the subprogram declaration
-- has been seen.
- -- Next_Named_Actual (Node4-Sem)
+ -- Next_Named_Actual
-- Present in parameter association nodes. Set during semantic analysis
-- to point to the next named parameter, where parameters are ordered by
-- declaration order (as opposed to the actual order in the call, which
@@ -2058,7 +2037,7 @@ package Sinfo is
-- points to the explicit actual parameter itself, not to the
-- N_Parameter_Association node (its parent).
- -- Next_Pragma (Node1-Sem)
+ -- Next_Pragma
-- Present in N_Pragma nodes. Used to create a linked list of pragma
-- nodes. Currently used for two purposes:
--
@@ -2073,13 +2052,13 @@ package Sinfo is
-- the apply to the same construct. These are visible/private mode for
-- a package spec and declarative/statement mode for package body.
- -- Next_Rep_Item (Node5-Sem)
+ -- Next_Rep_Item
-- Present in pragma nodes, attribute definition nodes, enumeration rep
-- 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)
+ -- Next_Use_Clause
-- While use clauses are active during semantic processing, they are
-- chained from the scope stack entry, using Next_Use_Clause as a link
-- pointer, with Empty marking the end of the list. The head pointer is
@@ -2087,7 +2066,7 @@ package Sinfo is
-- processing (i.e. when Gigi sees the tree, the contents of this field
-- is undefined and should not be read).
- -- No_Ctrl_Actions (Flag7-Sem)
+ -- No_Ctrl_Actions
-- Present in N_Assignment_Statement to indicate that no Finalize nor
-- Adjust should take place on this assignment even though the RHS is
-- controlled. Also indicates that the primitive _assign should not be
@@ -2095,7 +2074,7 @@ package Sinfo is
-- expansions where the generated assignments are initializations, not
-- real assignments.
- -- No_Elaboration_Check (Flag4-Sem)
+ -- No_Elaboration_Check
-- NOTE: this flag is relevant only for the legacy ABE mechanism and
-- should not be used outside of that context.
--
@@ -2103,9 +2082,9 @@ package Sinfo is
-- that no elaboration check is needed on the call, because it appears in
-- the context of a local Suppress pragma. This is used on calls within
-- task bodies, where the actual elaboration checks are applied after
- -- analysis, when the local scope stack is not present
+ -- analysis, when the local scope stack is not present.
- -- No_Entities_Ref_In_Spec (Flag8-Sem)
+ -- No_Entities_Ref_In_Spec
-- Present in N_With_Clause nodes. Set if the with clause is on the
-- package or subprogram spec where the main unit is the corresponding
-- body, and no entities of the with'ed unit are referenced by the spec
@@ -2113,7 +2092,7 @@ package Sinfo is
-- to generate the proper message (see Sem_Util.Check_Unused_Withs for
-- full details).
- -- No_Initialization (Flag13-Sem)
+ -- No_Initialization
-- Present in N_Object_Declaration and N_Allocator to indicate that the
-- object must not be initialized (by Initialize or call to an init
-- proc). This is needed for controlled aggregates. When the Object
@@ -2122,18 +2101,18 @@ package Sinfo is
-- with aggregates, and for object with an address clause, which are
-- initialized with an assignment at freeze time).
- -- No_Minimize_Eliminate (Flag17-Sem)
+ -- No_Minimize_Eliminate
-- This flag is present in membership operator nodes (N_In/N_Not_In).
-- It is used to indicate that processing for extended overflow checking
-- modes is not required (this is used to prevent infinite recursion).
- -- No_Side_Effect_Removal (Flag17-Sem)
+ -- No_Side_Effect_Removal
-- Present in N_Function_Call nodes. Set when a function call does not
-- require side effect removal. This attribute suppresses the generation
-- of a temporary to capture the result of the function which eventually
-- replaces the function call.
- -- No_Truncation (Flag17-Sem)
+ -- No_Truncation
-- Present in N_Unchecked_Type_Conversion node. This flag has an effect
-- only if the RM_Size of the source is greater than the RM_Size of the
-- target for scalar operands. Normally in such a case we truncate some
@@ -2145,19 +2124,19 @@ package Sinfo is
-- is used for properly setting out of range values for use by pragmas
-- Initialize_Scalars and Normalize_Scalars.
- -- Null_Excluding_Subtype (Flag16)
+ -- Null_Excluding_Subtype
-- Present in N_Access_To_Object_Definition. Indicates that the subtype
-- indication carries a null-exclusion indicator, which is distinct from
-- the null-exclusion indicator that may precede the access keyword.
- -- Original_Discriminant (Node2-Sem)
+ -- Original_Discriminant
-- Present in identifiers. Used in references to discriminants that
-- appear in generic units. Because the names of the discriminants may be
-- different in an instance, we use this field to recover the position of
-- the discriminant in the original type, and replace it with the
-- discriminant at the same position in the instantiated type.
- -- Original_Entity (Node2-Sem)
+ -- Original_Entity
-- Present in numeric literals. Used to denote the named number that has
-- been constant-folded into the given literal. If literal is from
-- source, or the result of some other constant-folding operation, then
@@ -2166,7 +2145,7 @@ package Sinfo is
-- interferes with the Entity field, making it impossible to preserve the
-- original entity at the point of instantiation.
- -- Others_Discrete_Choices (List1-Sem)
+ -- Others_Discrete_Choices
-- When a case statement or variant is analyzed, the semantic checks
-- determine the actual list of choices that correspond to an others
-- choice. This list is materialized for later use by the expander and
@@ -2175,48 +2154,48 @@ package Sinfo is
-- list of discrete choices, except that of course it cannot contain an
-- N_Others_Choice entry.
- -- Parent_Spec (Node4-Sem)
+ -- Parent_Spec
-- For a library unit that is a child unit spec (package or subprogram
-- declaration, generic declaration or instantiation, or library level
-- rename) this field points to the compilation unit node for the parent
-- package specification. This field is Empty for library bodies (the
-- parent spec in this case can be found from the corresponding spec).
- -- Parent_With (Flag1-Sem)
+ -- Parent_With
-- Present in N_With_Clause nodes. The flag indicates that the clause
-- was generated for an ancestor unit to provide proper visibility. A
-- with clause for child unit A.B.C produces two implicit parent with
-- clauses for A and A.B.
- -- Premature_Use (Node5-Sem)
+ -- Premature_Use
-- Present in N_Incomplete_Type_Declaration node. Used for improved
-- error diagnostics: if there is a premature usage of an incomplete
-- type, a subsequently generated error message indicates the position
-- of its full declaration.
- -- Present_Expr (Uint3-Sem)
+ -- Present_Expr
-- Present in an N_Variant node. This has a meaningful value only after
-- Gigi has back annotated the tree with representation information. At
-- this point, it contains a reference to a gcc expression that depends
- -- on the values of one or more discriminants. Give a set of discriminant
- -- 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
- -- back-annotation processing (for -gnatR -gnatc) to determine if a field
- -- is present or not.
-
- -- Prev_Use_Clause (Node1-Sem)
+ -- on the values of one or more discriminants. Given a set of
+ -- discriminant 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 back-annotation processing (for -gnatR -gnatc) to
+ -- determine if a field is present or not.
+
+ -- Prev_Use_Clause
-- Present in both N_Use_Package_Clause and N_Use_Type_Clause. Used in
-- detection of ineffective use clauses by allowing a chain of related
-- clauses together to avoid traversing the current scope stack.
- -- Print_In_Hex (Flag13-Sem)
+ -- Print_In_Hex
-- Set on an N_Integer_Literal node to indicate that the value should be
-- printed in hexadecimal in the sprint listing. Has no effect on
-- legality or semantics of program, only on the displayed output. This
-- is used to clarify output from the packed array cases.
- -- Procedure_To_Call (Node2-Sem)
+ -- Procedure_To_Call
-- Present in N_Allocator, N_Free_Statement, N_Simple_Return_Statement,
-- and N_Extended_Return_Statement nodes. References the entity for the
-- declaration of the procedure to be called to accomplish the required
@@ -2225,17 +2204,17 @@ package Sinfo is
-- allocating the return value), and for the Deallocate procedure in the
-- case of N_Free_Statement.
- -- Raises_Constraint_Error (Flag7-Sem)
+ -- Raises_Constraint_Error
-- Set on an expression whose evaluation will definitely fail constraint
-- error check. See Sem_Eval for details.
- -- Redundant_Use (Flag13-Sem)
+ -- Redundant_Use
-- Present in nodes that can appear as an operand in a use clause or use
-- type clause (identifiers, expanded names, attribute references). Set
-- to indicate that a use is redundant (and therefore need not be undone
-- on scope exit).
- -- Renaming_Exception (Node2-Sem)
+ -- Renaming_Exception
-- Present in N_Exception_Declaration node. Used to point back to the
-- exception renaming for an exception declared within a subprogram.
-- What happens is that an exception declared in a subprogram is moved
@@ -2243,18 +2222,18 @@ package Sinfo is
-- becomes a renaming. This link from the library level exception to the
-- renaming declaration allows registering of the proper exception name.
- -- Return_Statement_Entity (Node5-Sem)
+ -- Return_Statement_Entity
-- Present in N_Simple_Return_Statement and N_Extended_Return_Statement.
-- Points to an E_Return_Statement representing the return statement.
- -- Return_Object_Declarations (List3)
+ -- Return_Object_Declarations
-- Present in N_Extended_Return_Statement. Points to a list initially
-- containing a single N_Object_Declaration representing the return
-- object. We use a list (instead of just a pointer to the object decl)
-- because Analyze wants to insert extra actions on this list, before the
-- N_Object_Declaration, which always remains last on the list.
- -- Rounded_Result (Flag18-Sem)
+ -- Rounded_Result
-- Present in N_Type_Conversion, N_Op_Divide, and N_Op_Multiply nodes.
-- Used in the fixed-point cases to indicate that the result must be
-- rounded as a result of the use of the 'Round attribute. Also used for
@@ -2264,19 +2243,19 @@ package Sinfo is
-- are the result of expansion of rounded fixed-point divide, conversion
-- and multiplication operations.
- -- Save_Invocation_Graph_Of_Body (Flag1-Sem)
+ -- Save_Invocation_Graph_Of_Body
-- Present in compilation unit nodes. Set when the elaboration mechanism
-- must record all invocation constructs and invocation relations within
-- the body of the compilation unit.
--
- -- SCIL_Entity (Node4-Sem)
+ -- SCIL_Entity
-- Present in SCIL nodes. References the specific tagged type associated
-- with the SCIL node (for an N_SCIL_Dispatching_Call node, this is
-- the controlling type of the call; for an N_SCIL_Membership_Test node
-- generated as part of testing membership in T'Class, this is T; for an
-- N_SCIL_Dispatch_Table_Tag_Init node, this is the type being declared).
- -- SCIL_Controlling_Tag (Node5-Sem)
+ -- SCIL_Controlling_Tag
-- Present in N_SCIL_Dispatching_Call nodes. References the controlling
-- tag of a dispatching call. This is usually an N_Selected_Component
-- node (for a _tag component), but may be an N_Object_Declaration or
@@ -2284,33 +2263,33 @@ package Sinfo is
-- a classwide streaming operation or a call to an instance of
-- Ada.Tags.Generic_Dispatching_Constructor).
- -- SCIL_Tag_Value (Node5-Sem)
+ -- SCIL_Tag_Value
-- Present in N_SCIL_Membership_Test nodes. Used to reference the tag
-- of the value that is being tested.
- -- SCIL_Target_Prim (Node2-Sem)
+ -- SCIL_Target_Prim
-- Present in N_SCIL_Dispatching_Call nodes. References the primitive
-- operation named (statically) in a dispatching call.
- -- Scope (Node3-Sem)
+ -- Scope
-- Present in defining identifiers, defining character literals, and
-- defining operator symbols (i.e. in all entities). The entities of a
-- scope all use this field to reference the corresponding scope entity.
-- See Einfo for further details.
- -- Shift_Count_OK (Flag4-Sem)
+ -- Shift_Count_OK
-- A flag present in shift nodes to indicate that the shift count is
-- known to be in range, i.e. is in the range from zero to word length
-- minus one. If this flag is not set, then the shift count may be
-- outside this range, i.e. larger than the word length, and the code
-- must ensure that such shift counts give the appropriate result.
- -- Source_Type (Node1-Sem)
+ -- Source_Type
-- Used in an N_Validate_Unchecked_Conversion node to point to the
-- source type entity for the unchecked conversion instantiation
-- which gigi must do size validation for.
- -- Split_PPC (Flag17)
+ -- Split_PPC
-- When a Pre or Post aspect specification is processed, it is broken
-- into AND THEN sections. The leftmost section has Split_PPC set to
-- False, indicating that it is the original specification (e.g. for
@@ -2318,7 +2297,7 @@ package Sinfo is
-- This flag is set in both the N_Aspect_Specification node itself,
-- and in the pragma which is generated from this node.
- -- Storage_Pool (Node1-Sem)
+ -- Storage_Pool
-- Present in N_Allocator, N_Free_Statement, N_Simple_Return_Statement,
-- and N_Extended_Return_Statement nodes. References the entity for the
-- storage pool to be used for the allocate or free call or for the
@@ -2328,7 +2307,7 @@ package Sinfo is
-- value of a type whose size is not known at compile time on the
-- secondary stack.
- -- Suppress_Assignment_Checks (Flag18-Sem)
+ -- Suppress_Assignment_Checks
-- Used in generated N_Assignment_Statement nodes to suppress predicate
-- and range checks in cases where the generated code knows that the
-- value being assigned is in range and satisfies any predicate. Also
@@ -2337,23 +2316,23 @@ package Sinfo is
-- suppresses access checks in the generated code for out- and in-out
-- parameters in entry calls.
- -- Suppress_Loop_Warnings (Flag17-Sem)
+ -- Suppress_Loop_Warnings
-- Used in N_Loop_Statement node to indicate that warnings within the
-- body of the loop should be suppressed. This is set when the range
-- of a FOR loop is known to be null, or is probably null (loop would
-- only execute if invalid values are present).
- -- Target (Node1-Sem)
+ -- Target
-- Present in call and variable reference marker nodes. References the
-- entity of the original entity, operator, or subprogram being invoked,
-- or the original variable being read or written.
- -- Target_Type (Node2-Sem)
+ -- Target_Type
-- Used in an N_Validate_Unchecked_Conversion node to point to the target
-- type entity for the unchecked conversion instantiation which gigi must
-- do size validation for.
- -- Then_Actions (List3-Sem)
+ -- Then_Actions
-- This field is present in if expression nodes. During code expansion
-- we use the Insert_Actions procedure (in Exp_Util) to insert actions
-- at an appropriate place in the tree to get elaborated at the right
@@ -2364,7 +2343,7 @@ package Sinfo is
-- need for this field, so in the tree passed to Gigi, this field is
-- always set to No_List.
- -- TSS_Elist (Elist3-Sem)
+ -- TSS_Elist
-- Present in N_Freeze_Entity nodes. Holds an element list containing
-- entries for each TSS (type support subprogram) associated with the
-- frozen type. The elements of the list are the entities for the
@@ -2372,57 +2351,52 @@ package Sinfo is
-- if there are no type support subprograms for the type or if the freeze
-- node is not for a type.
- -- Uneval_Old_Accept (Flag7-Sem)
+ -- Uneval_Old_Accept
-- Present in N_Pragma nodes. Set True if Opt.Uneval_Old is set to 'A'
-- (accept) at the point where the pragma is encountered (including the
-- case of a pragma generated from an aspect specification). It is this
-- setting that is relevant, rather than the setting at the point where
-- a contract is finally analyzed after the delay till the freeze point.
- -- Uneval_Old_Warn (Flag18-Sem)
+ -- Uneval_Old_Warn
-- Present in N_Pragma nodes. Set True if Opt.Uneval_Old is set to 'W'
-- (warn) at the point where the pragma is encountered (including the
-- case of a pragma generated from an aspect specification). It is this
-- setting that is relevant, rather than the setting at the point where
-- a contract is finally analyzed after the delay till the freeze point.
- -- Unreferenced_In_Spec (Flag7-Sem)
+ -- Unreferenced_In_Spec
-- Present in N_With_Clause nodes. Set if the with clause is on the
-- package or subprogram spec where the main unit is the corresponding
-- body, and is not referenced by the spec (it may still be referenced by
-- the body, so this flag is used to generate the proper message (see
-- Sem_Util.Check_Unused_Withs for details)
- -- Uninitialized_Variable (Node3-Sem)
+ -- Uninitialized_Variable
-- Present in N_Formal_Private_Type_Definition and in N_Private_
-- Extension_Declarations. Indicates that a variable in a generic unit
-- whose type is a formal private or derived type is read without being
-- initialized. Used to warn if the corresponding actual type is not
-- a fully initialized type.
- -- Used_Operations (Elist2-Sem)
+ -- Used_Operations
-- Present in N_Use_Type_Clause nodes. Holds the list of operations that
-- are made potentially use-visible by the clause. Simplifies processing
-- on exit from the scope of the use_type_clause, in particular in the
-- case of Use_All_Type, when those operations several scopes.
- -- Was_Attribute_Reference (Flag2-Sem)
+ -- Was_Attribute_Reference
-- Present in N_Subprogram_Body. Set to True if the original source is an
-- attribute reference which is an actual in a generic instantiation. The
-- instantiation prologue renames these attributes, and expansion later
-- converts them into subprogram bodies.
- -- Was_Default_Init_Box_Association (Flag14-Sem)
- -- Present in N_Component_Association. Set to True if the original source
- -- is an aggregate component association with a box (<>) for a component
- -- that is initialized by default.
-
- -- Was_Expression_Function (Flag18-Sem)
+ -- Was_Expression_Function
-- 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.
- -- Was_Originally_Stub (Flag13-Sem)
+ -- Was_Originally_Stub
-- This flag is set in the node for a proper body that replaces stub.
-- During the analysis procedure, stubs in some situations get rewritten
-- by the corresponding bodies, and we set this flag to remember that
@@ -2529,16 +2503,16 @@ package Sinfo is
-- N_Identifier
-- Sloc points to identifier
- -- Chars (Name1) contains the Name_Id for the identifier
- -- Entity (Node4-Sem)
- -- Associated_Node (Node4-Sem)
- -- Original_Discriminant (Node2-Sem)
- -- Is_Elaboration_Checks_OK_Node (Flag1-Sem)
- -- Is_SPARK_Mode_On_Node (Flag2-Sem)
- -- Is_Elaboration_Warnings_OK_Node (Flag3-Sem)
- -- Has_Private_View (Flag11-Sem) (set in generic units)
- -- Redundant_Use (Flag13-Sem)
- -- Atomic_Sync_Required (Flag14-Sem)
+ -- Chars contains the Name_Id for the identifier
+ -- Entity
+ -- Associated_Node
+ -- Original_Discriminant
+ -- Is_Elaboration_Checks_OK_Node
+ -- Is_SPARK_Mode_On_Node
+ -- Is_Elaboration_Warnings_OK_Node
+ -- Has_Private_View (set in generic units)
+ -- Redundant_Use
+ -- Atomic_Sync_Required
-- plus fields for expression
--------------------------
@@ -2575,19 +2549,19 @@ package Sinfo is
-- N_Integer_Literal
-- Sloc points to literal
- -- Original_Entity (Node2-Sem) If not Empty, holds Named_Number that
+ -- Original_Entity If not Empty, holds Named_Number that
-- has been constant-folded into its literal value.
- -- Intval (Uint3) contains integer value of literal
- -- Print_In_Hex (Flag13-Sem)
+ -- Intval contains integer value of literal
+ -- Print_In_Hex
-- plus fields for expression
-- N_Real_Literal
-- Sloc points to literal
- -- Original_Entity (Node2-Sem) If not Empty, holds Named_Number that
+ -- Original_Entity If not Empty, holds Named_Number that
-- has been constant-folded into its literal value.
- -- Realval (Ureal3) contains real value of literal
- -- Corresponding_Integer_Value (Uint4-Sem)
- -- Is_Machine_Number (Flag11-Sem)
+ -- Realval contains real value of literal
+ -- Corresponding_Integer_Value
+ -- Is_Machine_Number
-- plus fields for expression
--------------------------
@@ -2615,11 +2589,11 @@ package Sinfo is
-- N_Character_Literal
-- Sloc points to literal
- -- Chars (Name1) contains the Name_Id for the identifier
- -- Char_Literal_Value (Uint2) contains the literal value
- -- Entity (Node4-Sem)
- -- Associated_Node (Node4-Sem)
- -- Has_Private_View (Flag11-Sem) set in generic units.
+ -- Chars contains the Name_Id for the identifier
+ -- Char_Literal_Value contains the literal value
+ -- Entity
+ -- Associated_Node
+ -- Has_Private_View (set in generic units)
-- plus fields for expression
-- Note: the Entity field will be missing (set to Empty) for character
@@ -2647,10 +2621,10 @@ package Sinfo is
-- N_String_Literal
-- Sloc points to literal
- -- Strval (Str3) contains Id of string value
- -- Has_Wide_Character (Flag11-Sem)
- -- Has_Wide_Wide_Character (Flag13-Sem)
- -- Is_Folded_In_Parser (Flag4)
+ -- Strval contains Id of string value
+ -- Has_Wide_Character
+ -- Has_Wide_Wide_Character
+ -- Is_Folded_In_Parser
-- plus fields for expression
------------------
@@ -2678,26 +2652,26 @@ package Sinfo is
-- N_Pragma
-- Sloc points to PRAGMA
- -- Next_Pragma (Node1-Sem)
- -- Pragma_Argument_Associations (List2) (set to No_List if none)
- -- Corresponding_Aspect (Node3-Sem) (set to Empty if not present)
- -- Pragma_Identifier (Node4)
- -- Next_Rep_Item (Node5-Sem)
- -- Is_Generic_Contract_Pragma (Flag2-Sem)
- -- Is_Checked_Ghost_Pragma (Flag3-Sem)
- -- Is_Inherited_Pragma (Flag4-Sem)
- -- Is_Analyzed_Pragma (Flag5-Sem)
- -- Class_Present (Flag6) set if from Aspect with 'Class
- -- Uneval_Old_Accept (Flag7-Sem)
- -- Is_Ignored_Ghost_Pragma (Flag8-Sem)
- -- Is_Ignored (Flag9-Sem)
- -- Is_Checked (Flag11-Sem)
- -- From_Aspect_Specification (Flag13-Sem)
- -- Is_Delayed_Aspect (Flag14-Sem)
- -- Is_Disabled (Flag15-Sem)
- -- Import_Interface_Present (Flag16-Sem)
- -- Split_PPC (Flag17) set if corresponding aspect had Split_PPC set
- -- Uneval_Old_Warn (Flag18-Sem)
+ -- Next_Pragma
+ -- Pragma_Argument_Associations (set to No_List if none)
+ -- Corresponding_Aspect (set to Empty if not present)
+ -- Pragma_Identifier
+ -- Next_Rep_Item
+ -- Is_Generic_Contract_Pragma
+ -- Is_Checked_Ghost_Pragma
+ -- Is_Inherited_Pragma
+ -- Is_Analyzed_Pragma
+ -- Class_Present set if from Aspect with 'Class
+ -- Uneval_Old_Accept
+ -- Is_Ignored_Ghost_Pragma
+ -- Is_Ignored
+ -- Is_Checked
+ -- From_Aspect_Specification
+ -- Is_Delayed_Aspect
+ -- Is_Disabled
+ -- Import_Interface_Present
+ -- Split_PPC set if corresponding aspect had Split_PPC set
+ -- Uneval_Old_Warn
-- Note: we should have a section on what pragmas are passed on to
-- the back end to be processed. This section should note that pragma
@@ -2746,9 +2720,9 @@ package Sinfo is
-- N_Pragma_Argument_Association
-- Sloc points to first token in association
- -- Chars (Name1) (set to No_Name if no pragma argument identifier)
- -- Expression_Copy (Node2-Sem)
- -- Expression (Node3)
+ -- Chars (set to No_Name if no pragma argument identifier)
+ -- Expression_Copy
+ -- Expression
------------------------
-- 2.9 Reserved Word --
@@ -2794,10 +2768,10 @@ package Sinfo is
-- N_Defining_Identifier
-- Sloc points to identifier
- -- Chars (Name1) contains the Name_Id for the identifier
- -- Next_Entity (Node2-Sem)
- -- Scope (Node3-Sem)
- -- Etype (Node5-Sem)
+ -- Chars contains the Name_Id for the identifier
+ -- Next_Entity
+ -- Scope
+ -- Etype
-----------------------------
-- 3.2.1 Type Declaration --
@@ -2826,11 +2800,11 @@ package Sinfo is
-- N_Full_Type_Declaration
-- Sloc points to TYPE
- -- Defining_Identifier (Node1)
- -- Incomplete_View (Node2-Sem)
- -- Discriminant_Specifications (List4) (set to No_List if none)
- -- Type_Definition (Node3)
- -- Discr_Check_Funcs_Built (Flag11-Sem)
+ -- Defining_Identifier
+ -- Incomplete_View
+ -- Discriminant_Specifications (set to No_List if none)
+ -- Type_Definition
+ -- Discr_Check_Funcs_Built
----------------------------
-- 3.2.1 Type Definition --
@@ -2855,11 +2829,11 @@ package Sinfo is
-- N_Subtype_Declaration
-- Sloc points to SUBTYPE
- -- Defining_Identifier (Node1)
- -- Null_Exclusion_Present (Flag11)
- -- Subtype_Indication (Node5)
- -- Generic_Parent_Type (Node4-Sem) (set for an actual derived type).
- -- Exception_Junk (Flag8-Sem)
+ -- Defining_Identifier
+ -- Null_Exclusion_Present
+ -- Subtype_Indication
+ -- Generic_Parent_Type (set for an actual derived type).
+ -- Exception_Junk
-------------------------------
-- 3.2.2 Subtype Indication --
@@ -2881,10 +2855,10 @@ package Sinfo is
-- N_Subtype_Indication
-- Sloc points to first token of subtype mark
- -- Subtype_Mark (Node4)
- -- Constraint (Node3)
- -- Etype (Node5-Sem)
- -- Must_Not_Freeze (Flag8-Sem)
+ -- Subtype_Mark
+ -- Constraint
+ -- Etype
+ -- Must_Not_Freeze
-- Note: Depending on context, the Etype is either the entity of the
-- Subtype_Mark field, or it is an itype constructed to reify the
@@ -2980,22 +2954,22 @@ package Sinfo is
-- N_Object_Declaration
-- Sloc points to first identifier
- -- Defining_Identifier (Node1)
- -- Aliased_Present (Flag4)
- -- Constant_Present (Flag17) set if CONSTANT appears
- -- Null_Exclusion_Present (Flag11)
- -- Object_Definition (Node4) subtype indic./array type def./access def.
- -- Expression (Node3) (set to Empty if not present)
- -- Handler_List_Entry (Node2-Sem)
- -- Corresponding_Generic_Association (Node5-Sem)
- -- More_Ids (Flag5) (set to False if no more identifiers in list)
- -- Prev_Ids (Flag6) (set to False if no previous identifiers in list)
- -- No_Initialization (Flag13-Sem)
- -- Assignment_OK (Flag15-Sem)
- -- Exception_Junk (Flag8-Sem)
- -- Is_Subprogram_Descriptor (Flag16-Sem)
- -- Has_Init_Expression (Flag14)
- -- Suppress_Assignment_Checks (Flag18-Sem)
+ -- Defining_Identifier
+ -- Aliased_Present
+ -- Constant_Present set if CONSTANT appears
+ -- Null_Exclusion_Present
+ -- Object_Definition subtype indic./array type def./access def.
+ -- Expression (set to Empty if not present)
+ -- Handler_List_Entry
+ -- Corresponding_Generic_Association
+ -- More_Ids (set to False if no more identifiers in list)
+ -- Prev_Ids (set to False if no previous identifiers in list)
+ -- No_Initialization
+ -- Assignment_OK
+ -- Exception_Junk
+ -- Is_Subprogram_Descriptor
+ -- Has_Init_Expression
+ -- Suppress_Assignment_Checks
-------------------------------------
-- 3.3.1 Defining Identifier List --
@@ -3021,10 +2995,10 @@ package Sinfo is
-- N_Number_Declaration
-- Sloc points to first identifier
- -- Defining_Identifier (Node1)
- -- Expression (Node3)
- -- More_Ids (Flag5) (set to False if no more identifiers in list)
- -- Prev_Ids (Flag6) (set to False if no previous identifiers in list)
+ -- Defining_Identifier
+ -- Expression
+ -- More_Ids (set to False if no more identifiers in list)
+ -- Prev_Ids (set to False if no previous identifiers in list)
----------------------------------
-- 3.4 Derived Type Definition --
@@ -3041,16 +3015,16 @@ package Sinfo is
-- N_Derived_Type_Definition
-- Sloc points to NEW
- -- Abstract_Present (Flag4)
- -- Null_Exclusion_Present (Flag11) (set to False if not present)
- -- Subtype_Indication (Node5)
- -- Record_Extension_Part (Node3) (set to Empty if not present)
- -- Limited_Present (Flag17)
- -- Task_Present (Flag5) set in task interfaces
- -- Protected_Present (Flag6) set in protected interfaces
- -- Synchronized_Present (Flag7) set in interfaces
- -- Interface_List (List2) (set to No_List if none)
- -- Interface_Present (Flag16) set in abstract interfaces
+ -- Abstract_Present
+ -- Null_Exclusion_Present (set to False if not present)
+ -- Subtype_Indication
+ -- Record_Extension_Part (set to Empty if not present)
+ -- Limited_Present
+ -- Task_Present set in task interfaces
+ -- Protected_Present set in protected interfaces
+ -- Synchronized_Present set in interfaces
+ -- Interface_List (set to No_List if none)
+ -- Interface_Present set in abstract interfaces
-- Note: Task_Present, Protected_Present, Synchronized_Present,
-- Interface_List, and Interface_Present are used for abstract
@@ -3064,7 +3038,7 @@ package Sinfo is
-- N_Range_Constraint
-- Sloc points to RANGE
- -- Range_Expression (Node4)
+ -- Range_Expression
----------------
-- 3.5 Range --
@@ -3087,9 +3061,9 @@ package Sinfo is
-- N_Range
-- Sloc points to ..
- -- Low_Bound (Node1)
- -- High_Bound (Node2)
- -- Includes_Infinities (Flag11)
+ -- Low_Bound
+ -- High_Bound
+ -- Includes_Infinities
-- plus fields for expression
-- Note: if the range appears in a context, such as a subtype
@@ -3111,8 +3085,8 @@ package Sinfo is
-- N_Enumeration_Type_Definition
-- Sloc points to left parenthesis
- -- Literals (List1) (Empty for CHARACTER or WIDE_CHARACTER)
- -- End_Label (Node4) (set to Empty if internally generated record)
+ -- Literals (Empty for CHARACTER or WIDE_CHARACTER)
+ -- End_Label (set to Empty if internally generated record)
----------------------------------------------
-- 3.5.1 Enumeration Literal Specification --
@@ -3140,10 +3114,10 @@ package Sinfo is
-- N_Defining_Character_Literal
-- Sloc points to literal
- -- Chars (Name1) contains the Name_Id for the identifier
- -- Next_Entity (Node2-Sem)
- -- Scope (Node3-Sem)
- -- Etype (Node5-Sem)
+ -- Chars contains the Name_Id for the identifier
+ -- Next_Entity
+ -- Scope
+ -- Etype
------------------------------------
-- 3.5.4 Integer Type Definition --
@@ -3168,8 +3142,8 @@ package Sinfo is
-- N_Signed_Integer_Type_Definition
-- Sloc points to RANGE
- -- Low_Bound (Node1)
- -- High_Bound (Node2)
+ -- Low_Bound
+ -- High_Bound
------------------------------------
-- 3.5.4 Modular Type Definition --
@@ -3179,7 +3153,7 @@ package Sinfo is
-- N_Modular_Type_Definition
-- Sloc points to MOD
- -- Expression (Node3)
+ -- Expression
---------------------------------
-- 3.5.6 Real Type Definition --
@@ -3200,8 +3174,8 @@ package Sinfo is
-- N_Floating_Point_Definition
-- Sloc points to DIGITS
- -- Digits_Expression (Node2)
- -- Real_Range_Specification (Node4) (set to Empty if not present)
+ -- Digits_Expression
+ -- Real_Range_Specification (set to Empty if not present)
-------------------------------------
-- 3.5.7 Real Range Specification --
@@ -3212,8 +3186,8 @@ package Sinfo is
-- N_Real_Range_Specification
-- Sloc points to RANGE
- -- Low_Bound (Node1)
- -- High_Bound (Node2)
+ -- Low_Bound
+ -- High_Bound
-----------------------------------
-- 3.5.9 Fixed Point Definition --
@@ -3233,8 +3207,8 @@ package Sinfo is
-- N_Ordinary_Fixed_Point_Definition
-- Sloc points to DELTA
- -- Delta_Expression (Node3)
- -- Real_Range_Specification (Node4)
+ -- Delta_Expression
+ -- Real_Range_Specification
-------------------------------------------
-- 3.5.9 Decimal Fixed Point Definition --
@@ -3248,9 +3222,9 @@ package Sinfo is
-- N_Decimal_Fixed_Point_Definition
-- Sloc points to DELTA
- -- Delta_Expression (Node3)
- -- Digits_Expression (Node2)
- -- Real_Range_Specification (Node4) (set to Empty if not present)
+ -- Delta_Expression
+ -- Digits_Expression
+ -- Real_Range_Specification (set to Empty if not present)
------------------------------
-- 3.5.9 Digits Constraint --
@@ -3264,8 +3238,8 @@ package Sinfo is
-- N_Digits_Constraint
-- Sloc points to DIGITS
- -- Digits_Expression (Node2)
- -- Range_Constraint (Node4) (set to Empty if not present)
+ -- Digits_Expression
+ -- Range_Constraint (set to Empty if not present)
--------------------------------
-- 3.6 Array Type Definition --
@@ -3287,8 +3261,8 @@ package Sinfo is
-- N_Unconstrained_Array_Definition
-- Sloc points to ARRAY
- -- Subtype_Marks (List2)
- -- Component_Definition (Node4)
+ -- Subtype_Marks
+ -- Component_Definition
-----------------------------------
-- 3.6 Index Subtype Definition --
@@ -3315,8 +3289,8 @@ package Sinfo is
-- N_Constrained_Array_Definition
-- Sloc points to ARRAY
- -- Discrete_Subtype_Definitions (List2)
- -- Component_Definition (Node4)
+ -- Discrete_Subtype_Definitions
+ -- Component_Definition
-- Note: although the language allows the full syntax for discrete
-- subtype definitions (i.e. a discrete subtype indication or a range),
@@ -3347,10 +3321,10 @@ package Sinfo is
-- N_Component_Definition
-- Sloc points to ALIASED, ACCESS, or to first token of subtype mark
- -- Aliased_Present (Flag4)
- -- Null_Exclusion_Present (Flag11)
- -- Subtype_Indication (Node5) (set to Empty if not present)
- -- Access_Definition (Node3) (set to Empty if not present)
+ -- Aliased_Present
+ -- Null_Exclusion_Present
+ -- Subtype_Indication (set to Empty if not present)
+ -- Access_Definition (set to Empty if not present)
-----------------------------
-- 3.6.1 Index Constraint --
@@ -3420,12 +3394,12 @@ package Sinfo is
-- N_Discriminant_Specification
-- Sloc points to first identifier
- -- Defining_Identifier (Node1)
- -- Null_Exclusion_Present (Flag11)
- -- Discriminant_Type (Node5) subtype mark or access parameter definition
- -- Expression (Node3) (set to Empty if no default expression)
- -- More_Ids (Flag5) (set to False if no more identifiers in list)
- -- Prev_Ids (Flag6) (set to False if no previous identifiers in list)
+ -- Defining_Identifier
+ -- Null_Exclusion_Present
+ -- Discriminant_Type subtype mark or access parameter definition
+ -- Expression (set to Empty if no default expression)
+ -- More_Ids (set to False if no more identifiers in list)
+ -- Prev_Ids (set to False if no previous identifiers in list)
-----------------------------
-- 3.7 Default Expression --
@@ -3450,7 +3424,7 @@ package Sinfo is
-- N_Index_Or_Discriminant_Constraint
-- Sloc points to left paren
- -- Constraints (List1) points to list of discrete ranges or
+ -- Constraints points to list of discrete ranges or
-- discriminant associations
-------------------------------------
@@ -3466,9 +3440,9 @@ package Sinfo is
-- N_Discriminant_Association
-- Sloc points to first token of discriminant association
- -- Selector_Names (List1) (always non-empty, since if no selector
+ -- Selector_Names (always non-empty, since if no selector
-- names are present, this node is not used, see comment above)
- -- Expression (Node3)
+ -- Expression
---------------------------------
-- 3.8 Record Type Definition --
@@ -3502,17 +3476,17 @@ package Sinfo is
-- N_Record_Definition
-- Sloc points to RECORD or NULL
- -- End_Label (Node4) (set to Empty if internally generated record)
- -- Abstract_Present (Flag4)
- -- Tagged_Present (Flag15)
- -- Limited_Present (Flag17)
- -- Component_List (Node1) empty in null record case
- -- Null_Present (Flag13) set in null record case
- -- Task_Present (Flag5) set in task interfaces
- -- Protected_Present (Flag6) set in protected interfaces
- -- Synchronized_Present (Flag7) set in interfaces
- -- Interface_Present (Flag16) set in abstract interfaces
- -- Interface_List (List2) (set to No_List if none)
+ -- End_Label (set to Empty if internally generated record)
+ -- Abstract_Present
+ -- Tagged_Present
+ -- Limited_Present
+ -- Component_List empty in null record case
+ -- Null_Present set in null record case
+ -- Task_Present set in task interfaces
+ -- Protected_Present set in protected interfaces
+ -- Synchronized_Present set in interfaces
+ -- Interface_Present set in abstract interfaces
+ -- Interface_List (set to No_List if none)
-- Note: Task_Present, Protected_Present, Synchronized _Present,
-- Interface_List and Interface_Present are used for abstract
@@ -3529,9 +3503,9 @@ package Sinfo is
-- N_Component_List
-- Sloc points to first token of component list
- -- Component_Items (List3)
- -- Variant_Part (Node4) (set to Empty if no variant part)
- -- Null_Present (Flag13)
+ -- Component_Items
+ -- Variant_Part (set to Empty if no variant part)
+ -- Null_Present
-------------------------
-- 3.8 Component Item --
@@ -3568,11 +3542,11 @@ package Sinfo is
-- N_Component_Declaration
-- Sloc points to first identifier
- -- Defining_Identifier (Node1)
- -- Component_Definition (Node4)
- -- Expression (Node3) (set to Empty if no default expression)
- -- More_Ids (Flag5) (set to False if no more identifiers in list)
- -- Prev_Ids (Flag6) (set to False if no previous identifiers in list)
+ -- Defining_Identifier
+ -- Component_Definition
+ -- Expression (set to Empty if no default expression)
+ -- More_Ids (set to False if no more identifiers in list)
+ -- Prev_Ids (set to False if no previous identifiers in list)
-------------------------
-- 3.8.1 Variant Part --
@@ -3588,8 +3562,8 @@ package Sinfo is
-- N_Variant_Part
-- Sloc points to CASE
- -- Name (Node2)
- -- Variants (List1)
+ -- Name
+ -- Variants
--------------------
-- 3.8.1 Variant --
@@ -3601,12 +3575,12 @@ package Sinfo is
-- N_Variant
-- Sloc points to WHEN
- -- Discrete_Choices (List4)
- -- Component_List (Node1)
- -- Enclosing_Variant (Node2-Sem)
- -- Present_Expr (Uint3-Sem)
- -- Dcheck_Function (Node5-Sem)
- -- Has_SP_Choice (Flag15-Sem)
+ -- Discrete_Choices
+ -- Component_List
+ -- Enclosing_Variant
+ -- Present_Expr
+ -- Dcheck_Function
+ -- Has_SP_Choice
-- Note: in the list of Discrete_Choices, the tree passed to the back
-- end does not have choice entries corresponding to names of statically
@@ -3638,8 +3612,8 @@ package Sinfo is
-- N_Others_Choice
-- Sloc points to OTHERS
- -- Others_Discrete_Choices (List1-Sem)
- -- All_Others (Flag11-Sem)
+ -- Others_Discrete_Choices
+ -- All_Others
----------------------------------
-- 3.9.1 Record Extension Part --
@@ -3686,11 +3660,11 @@ package Sinfo is
-- N_Access_To_Object_Definition
-- Sloc points to ACCESS
- -- All_Present (Flag15)
- -- Null_Exclusion_Present (Flag11)
- -- Null_Excluding_Subtype (Flag16)
- -- Subtype_Indication (Node5)
- -- Constant_Present (Flag17)
+ -- All_Present
+ -- Null_Exclusion_Present
+ -- Null_Excluding_Subtype
+ -- Subtype_Indication
+ -- Constant_Present
-----------------------------------
-- 3.10 General Access Modifier --
@@ -3717,17 +3691,17 @@ package Sinfo is
-- N_Access_Function_Definition
-- Sloc points to ACCESS
- -- Null_Exclusion_Present (Flag11)
- -- Null_Exclusion_In_Return_Present (Flag14)
- -- Protected_Present (Flag6)
- -- Parameter_Specifications (List3) (set to No_List if no formal part)
- -- Result_Definition (Node4) result subtype (subtype mark or access def)
+ -- Null_Exclusion_Present
+ -- Null_Exclusion_In_Return_Present
+ -- Protected_Present
+ -- Parameter_Specifications (set to No_List if no formal part)
+ -- Result_Definition result subtype (subtype mark or access def)
-- N_Access_Procedure_Definition
-- Sloc points to ACCESS
- -- Null_Exclusion_Present (Flag11)
- -- Protected_Present (Flag6)
- -- Parameter_Specifications (List3) (set to No_List if no formal part)
+ -- Null_Exclusion_Present
+ -- Protected_Present
+ -- Parameter_Specifications (set to No_List if no formal part)
-----------------------------
-- 3.10 Access Definition --
@@ -3741,11 +3715,11 @@ package Sinfo is
-- N_Access_Definition
-- Sloc points to ACCESS
- -- Null_Exclusion_Present (Flag11)
- -- All_Present (Flag15)
- -- Constant_Present (Flag17)
- -- Subtype_Mark (Node4)
- -- Access_To_Subprogram_Definition (Node3) (set to Empty if not present)
+ -- Null_Exclusion_Present
+ -- All_Present
+ -- Constant_Present
+ -- Subtype_Mark
+ -- Access_To_Subprogram_Definition (set to Empty if not present)
-----------------------------------------
-- 3.10.1 Incomplete Type Declaration --
@@ -3756,13 +3730,13 @@ package Sinfo is
-- N_Incomplete_Type_Declaration
-- Sloc points to TYPE
- -- Defining_Identifier (Node1)
- -- Discriminant_Specifications (List4) (set to No_List if no
+ -- Defining_Identifier
+ -- Discriminant_Specifications (set to No_List if no
-- discriminant part, or if the discriminant part is an
-- unknown discriminant part)
- -- Premature_Use (Node5-Sem) used for improved diagnostics.
- -- Unknown_Discriminants_Present (Flag13) set if (<>) discriminant
- -- Tagged_Present (Flag15)
+ -- Premature_Use used for improved diagnostics.
+ -- Unknown_Discriminants_Present set if (<>) discriminant
+ -- Tagged_Present
----------------------------
-- 3.11 Declarative Part --
@@ -3833,10 +3807,10 @@ package Sinfo is
-- N_Explicit_Dereference
-- Sloc points to ALL
- -- Prefix (Node3)
- -- Actual_Designated_Subtype (Node4-Sem)
- -- Has_Dereference_Action (Flag13-Sem)
- -- Atomic_Sync_Required (Flag14-Sem)
+ -- Prefix
+ -- Actual_Designated_Subtype
+ -- Has_Dereference_Action
+ -- Atomic_Sync_Required
-- plus fields for expression
-------------------------------
@@ -3857,10 +3831,10 @@ package Sinfo is
-- N_Indexed_Component
-- Sloc contains a copy of the Sloc value of the Prefix
- -- Prefix (Node3)
- -- Expressions (List1)
- -- Generalized_Indexing (Node4-Sem)
- -- Atomic_Sync_Required (Flag14-Sem)
+ -- Prefix
+ -- Expressions
+ -- Generalized_Indexing
+ -- Atomic_Sync_Required
-- plus fields for expression
-- Note: if any of the subscripts requires a range check, then the
@@ -3883,8 +3857,8 @@ package Sinfo is
-- N_Slice
-- Sloc points to first token of prefix
- -- Prefix (Node3)
- -- Discrete_Range (Node4)
+ -- Prefix
+ -- Discrete_Range
-- plus fields for expression
-------------------------------
@@ -3899,13 +3873,13 @@ package Sinfo is
-- N_Selected_Component
-- Sloc points to the period
- -- Prefix (Node3)
- -- Selector_Name (Node2)
- -- Associated_Node (Node4-Sem)
- -- Do_Discriminant_Check (Flag3-Sem)
- -- Is_In_Discriminant_Check (Flag11-Sem)
- -- Atomic_Sync_Required (Flag14-Sem)
- -- Is_Prefixed_Call (Flag17-Sem)
+ -- Prefix
+ -- Selector_Name
+ -- Associated_Node
+ -- Do_Discriminant_Check
+ -- Is_In_Discriminant_Check
+ -- Atomic_Sync_Required
+ -- Is_Prefixed_Call
-- plus fields for expression
--------------------------
@@ -3993,17 +3967,17 @@ package Sinfo is
-- N_Attribute_Reference
-- Sloc points to apostrophe
- -- Prefix (Node3) (general expression, see note above)
- -- Attribute_Name (Name2) identifier name from attribute designator
- -- Expressions (List1) (set to No_List if no associated expressions)
- -- Entity (Node4-Sem) used if the attribute yields a type
- -- Associated_Node (Node4-Sem)
- -- Is_Elaboration_Checks_OK_Node (Flag1-Sem)
- -- Is_SPARK_Mode_On_Node (Flag2-Sem)
- -- Is_Elaboration_Warnings_OK_Node (Flag3-Sem)
- -- Header_Size_Added (Flag11-Sem)
- -- Redundant_Use (Flag13-Sem)
- -- Must_Be_Byte_Aligned (Flag14-Sem)
+ -- Prefix (general expression, see note above)
+ -- Attribute_Name identifier name from attribute designator
+ -- Expressions (set to No_List if no associated expressions)
+ -- Entity used if the attribute yields a type
+ -- Associated_Node
+ -- Is_Elaboration_Checks_OK_Node
+ -- Is_SPARK_Mode_On_Node
+ -- Is_Elaboration_Warnings_OK_Node
+ -- Header_Size_Added
+ -- Redundant_Use
+ -- Must_Be_Byte_Aligned
-- plus fields for expression
-- Note: in Modify_Tree_For_C mode, Max and Min attributes are expanded
@@ -4058,15 +4032,15 @@ package Sinfo is
-- N_Aggregate
-- Sloc points to left parenthesis
- -- Expressions (List1) (set to No_List if none or null record case)
- -- Component_Associations (List2) (set to No_List if none)
- -- Null_Record_Present (Flag17)
- -- Aggregate_Bounds (Node3-Sem)
- -- Associated_Node (Node4-Sem)
- -- Compile_Time_Known_Aggregate (Flag18-Sem)
- -- Expansion_Delayed (Flag11-Sem)
- -- Has_Self_Reference (Flag13-Sem)
- -- Is_Homogeneous_Aggregate (Flag14)
+ -- Expressions (set to No_List if none or null record case)
+ -- Component_Associations (set to No_List if none)
+ -- Null_Record_Present
+ -- Aggregate_Bounds
+ -- Associated_Node
+ -- Compile_Time_Known_Aggregate
+ -- Expansion_Delayed
+ -- Has_Self_Reference
+ -- Is_Homogeneous_Aggregate
-- plus fields for expression
-- Note: this structure is used for both record and array aggregates
@@ -4121,12 +4095,12 @@ package Sinfo is
-- N_Component_Association
-- Sloc points to first selector name
- -- Choices (List1)
- -- Expression (Node3) (empty if Box_Present)
- -- Loop_Actions (List5-Sem)
- -- Box_Present (Flag15)
- -- Was_Default_Init_Box_Association (Flag14)
- -- Inherited_Discriminant (Flag13)
+ -- Choices
+ -- Expression (empty if Box_Present)
+ -- Loop_Actions
+ -- Box_Present
+ -- Inherited_Discriminant
+ -- Binding_Chars
-- Note: this structure is used for both record component associations
-- and array component associations, since the two cases aren't always
@@ -4134,9 +4108,11 @@ package Sinfo is
-- list of selector names in the record aggregate case, or a list of
-- discrete choices in the array aggregate case or an N_Others_Choice
-- node (which appears as a singleton list). Box_Present gives support
- -- to Ada 2005 (AI-287). Was_Default_Init_Box_Association is used for
- -- determining the need for Default_Initial_Condition check on component
- -- associations with a box.
+ -- to Ada 2005 (AI-287). Binding_Chars is only set if GNAT extensions
+ -- are enabled and the given component association occurs within a
+ -- choice_expression; in this case, it is the Name_Id, if any, specified
+ -- via either of two syntactic forms: "Foo => Bar is Abc" or
+ -- "Foo => <Abc>".
----------------------------------
-- 4.3.1 Component Choice List --
@@ -4161,13 +4137,13 @@ package Sinfo is
-- N_Extension_Aggregate
-- Sloc points to left parenthesis
- -- Ancestor_Part (Node3)
- -- Associated_Node (Node4-Sem)
- -- Expressions (List1) (set to No_List if none or null record case)
- -- Component_Associations (List2) (set to No_List if none)
- -- Null_Record_Present (Flag17)
- -- Expansion_Delayed (Flag11-Sem)
- -- Has_Self_Reference (Flag13-Sem)
+ -- Ancestor_Part
+ -- Associated_Node
+ -- Expressions (set to No_List if none or null record case)
+ -- Component_Associations (set to No_List if none)
+ -- Null_Record_Present
+ -- Expansion_Delayed
+ -- Has_Self_Reference
-- plus fields for expression
--------------------------
@@ -4223,12 +4199,12 @@ package Sinfo is
-- N_Iterated_Component_Association
-- Sloc points to FOR
- -- Defining_Identifier (Node1)
- -- Iterator_Specification (Node2) (set to Empty if no Iterator_Spec)
- -- Expression (Node3)
- -- Discrete_Choices (List4)
- -- Loop_Actions (List5-Sem)
- -- Box_Present (Flag15)
+ -- Defining_Identifier
+ -- Iterator_Specification (set to Empty if no Iterator_Spec)
+ -- Expression
+ -- Discrete_Choices
+ -- Loop_Actions
+ -- Box_Present
-- Note that Box_Present is always False, but it is intentionally added
-- for completeness.
@@ -4239,28 +4215,28 @@ package Sinfo is
-- N_Delta_Aggregate
-- Sloc points to left parenthesis
- -- Expression (Node3)
- -- Component_Associations (List2)
- -- Etype (Node5-Sem)
+ -- Expression
+ -- Component_Associations
+ -- Etype
---------------------------------
-- 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)
- -- Box_Present (Flag15)
+ -- Key_Expression
+ -- Iterator_Specification
+ -- Expression
+ -- Loop_Parameter_Specification
+ -- Loop_Actions
+ -- Box_Present
-- 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
+ -- Both iterated associations are Ada 2022 features that are
-- expanded during aggregate construction, and do not appear in
-- expanded code.
@@ -4373,16 +4349,16 @@ package Sinfo is
-- N_And_Then
-- Sloc points to AND of AND THEN
- -- Left_Opnd (Node2)
- -- Right_Opnd (Node3)
- -- Actions (List1-Sem)
+ -- Left_Opnd
+ -- Right_Opnd
+ -- Actions
-- plus fields for expression
-- N_Or_Else
-- Sloc points to OR of OR ELSE
- -- Left_Opnd (Node2)
- -- Right_Opnd (Node3)
- -- Actions (List1-Sem)
+ -- Left_Opnd
+ -- Right_Opnd
+ -- Actions
-- plus fields for expression
-- Note: The Actions field is used to hold actions associated with
@@ -4421,18 +4397,18 @@ package Sinfo is
-- N_In
-- Sloc points to IN
- -- Left_Opnd (Node2)
- -- Right_Opnd (Node3)
- -- Alternatives (List4) (set to No_List if only one set alternative)
- -- No_Minimize_Eliminate (Flag17)
+ -- Left_Opnd
+ -- Right_Opnd
+ -- Alternatives (set to No_List if only one set alternative)
+ -- No_Minimize_Eliminate
-- plus fields for expression
-- N_Not_In
-- Sloc points to NOT of NOT IN
- -- Left_Opnd (Node2)
- -- Right_Opnd (Node3)
- -- Alternatives (List4) (set to No_List if only one set alternative)
- -- No_Minimize_Eliminate (Flag17)
+ -- Left_Opnd
+ -- Right_Opnd
+ -- Alternatives (set to No_List if only one set alternative)
+ -- No_Minimize_Eliminate
-- plus fields for expression
--------------------
@@ -4465,19 +4441,19 @@ package Sinfo is
-- N_Op_And
-- Sloc points to AND
- -- Do_Length_Check (Flag4-Sem)
+ -- Do_Length_Check
-- plus fields for binary operator
-- plus fields for expression
-- N_Op_Or
-- Sloc points to OR
- -- Do_Length_Check (Flag4-Sem)
+ -- Do_Length_Check
-- plus fields for binary operator
-- plus fields for expression
-- N_Op_Xor
-- Sloc points to XOR
- -- Do_Length_Check (Flag4-Sem)
+ -- Do_Length_Check
-- plus fields for binary operator
-- plus fields for expression
@@ -4523,39 +4499,39 @@ package Sinfo is
-- N_Op_Concat
-- Sloc points to &
- -- Is_Component_Left_Opnd (Flag13-Sem)
- -- Is_Component_Right_Opnd (Flag14-Sem)
+ -- Is_Component_Left_Opnd
+ -- Is_Component_Right_Opnd
-- plus fields for binary operator
-- plus fields for expression
-- N_Op_Multiply
-- Sloc points to *
- -- Rounded_Result (Flag18-Sem)
+ -- Rounded_Result
-- plus fields for binary operator
-- plus fields for expression
-- N_Op_Divide
-- Sloc points to /
- -- Do_Division_Check (Flag13-Sem)
- -- Rounded_Result (Flag18-Sem)
+ -- Do_Division_Check
+ -- Rounded_Result
-- plus fields for binary operator
-- plus fields for expression
-- N_Op_Mod
-- Sloc points to MOD
- -- Do_Division_Check (Flag13-Sem)
+ -- Do_Division_Check
-- plus fields for binary operator
-- plus fields for expression
-- N_Op_Rem
-- Sloc points to REM
- -- Do_Division_Check (Flag13-Sem)
+ -- Do_Division_Check
-- plus fields for binary operator
-- plus fields for expression
-- N_Op_Expon
-- Sloc points to **
- -- Is_Power_Of_2_For_Shift (Flag13-Sem)
+ -- Is_Power_Of_2_For_Shift
-- plus fields for binary operator
-- plus fields for expression
@@ -4627,11 +4603,11 @@ package Sinfo is
-- N_If_Expression
-- Sloc points to IF or ELSIF keyword
- -- Expressions (List1)
- -- Then_Actions (List2-Sem)
- -- Else_Actions (List3-Sem)
- -- Is_Elsif (Flag13) (set if comes from ELSIF)
- -- Do_Overflow_Check (Flag17-Sem)
+ -- Expressions
+ -- Then_Actions
+ -- Else_Actions
+ -- Is_Elsif (set if comes from ELSIF)
+ -- Do_Overflow_Check
-- plus fields for expression
-- Expressions here is a three-element list, whose first element is the
@@ -4666,10 +4642,10 @@ package Sinfo is
-- N_Case_Expression
-- Sloc points to CASE
- -- Expression (Node3) (the selecting expression)
- -- Alternatives (List4) (the case expression alternatives)
- -- Etype (Node5-Sem)
- -- Do_Overflow_Check (Flag17-Sem)
+ -- Expression (the selecting expression)
+ -- Alternatives (the case expression alternatives)
+ -- Etype
+ -- Do_Overflow_Check
----------------------------------------
-- 4.5.7 Case Expression Alternative --
@@ -4681,10 +4657,10 @@ package Sinfo is
-- N_Case_Expression_Alternative
-- Sloc points to WHEN
- -- Actions (List1)
- -- Discrete_Choices (List4)
- -- Expression (Node3)
- -- Has_SP_Choice (Flag15-Sem)
+ -- Actions
+ -- Discrete_Choices
+ -- Expression
+ -- Has_SP_Choice
-- Note: The Actions field temporarily holds any actions associated with
-- evaluation of the Expression. During expansion of the case expression
@@ -4709,10 +4685,10 @@ package Sinfo is
-- N_Quantified_Expression
-- Sloc points to FOR
- -- Iterator_Specification (Node2)
- -- Loop_Parameter_Specification (Node4)
- -- Condition (Node1)
- -- All_Present (Flag15)
+ -- Iterator_Specification
+ -- Loop_Parameter_Specification
+ -- Condition
+ -- All_Present
--------------------------
-- 4.6 Type Conversion --
@@ -4732,7 +4708,8 @@ package Sinfo is
-- Conversions from floating-point to integer are only handled in
-- the case where Float_Truncate flag set. Other conversions from
-- floating-point to integer (involving rounding) and all conversions
- -- involving fixed-point types are handled by the expander.
+ -- involving fixed-point types are handled by the expander, unless the
+ -- Conversion_OK flag is set.
-- Sprint syntax if Float_Truncate set: X^(Y)
-- Sprint syntax if Conversion_OK set X?(Y)
@@ -4744,15 +4721,14 @@ package Sinfo is
-- N_Type_Conversion
-- Sloc points to first token of subtype mark
- -- Subtype_Mark (Node4)
- -- Expression (Node3)
- -- Do_Discriminant_Check (Flag3-Sem)
- -- Do_Length_Check (Flag4-Sem)
- -- Float_Truncate (Flag11-Sem)
- -- Do_Tag_Check (Flag13-Sem)
- -- Conversion_OK (Flag14-Sem)
- -- Do_Overflow_Check (Flag17-Sem)
- -- Rounded_Result (Flag18-Sem)
+ -- Subtype_Mark
+ -- Expression
+ -- Do_Discriminant_Check
+ -- Do_Length_Check
+ -- Float_Truncate
+ -- Conversion_OK
+ -- Do_Overflow_Check
+ -- Rounded_Result
-- plus fields for expression
-- Note: if a range check is required, then the Do_Range_Check flag
@@ -4774,9 +4750,9 @@ package Sinfo is
-- N_Qualified_Expression
-- Sloc points to apostrophe
- -- Subtype_Mark (Node4)
- -- Expression (Node3) expression or aggregate
- -- Is_Qualified_Universal_Literal (Flag4-Sem)
+ -- Subtype_Mark
+ -- Expression expression or aggregate
+ -- Is_Qualified_Universal_Literal
-- plus fields for expression
--------------------
@@ -4796,16 +4772,16 @@ package Sinfo is
-- N_Allocator
-- Sloc points to NEW
- -- Expression (Node3) subtype indication or qualified expression
- -- Subpool_Handle_Name (Node4) (set to Empty if not present)
- -- Storage_Pool (Node1-Sem)
- -- Procedure_To_Call (Node2-Sem)
- -- Alloc_For_BIP_Return (Flag1-Sem)
- -- Null_Exclusion_Present (Flag11)
- -- No_Initialization (Flag13-Sem)
- -- Is_Static_Coextension (Flag14-Sem)
- -- Do_Storage_Check (Flag17-Sem)
- -- Is_Dynamic_Coextension (Flag18-Sem)
+ -- Expression subtype indication or qualified expression
+ -- Subpool_Handle_Name (set to Empty if not present)
+ -- Storage_Pool
+ -- Procedure_To_Call
+ -- Alloc_For_BIP_Return
+ -- Null_Exclusion_Present
+ -- No_Initialization
+ -- Is_Static_Coextension
+ -- Do_Storage_Check
+ -- Is_Dynamic_Coextension
-- plus fields for expression
-- Note: like all nodes, the N_Allocator has the Comes_From_Source flag.
@@ -4871,7 +4847,7 @@ package Sinfo is
-- N_Null_Statement
-- Sloc points to NULL
- -- Next_Rep_Item (Node5-Sem)
+ -- Next_Rep_Item
----------------
-- 5.1 Label --
@@ -4886,8 +4862,8 @@ package Sinfo is
-- N_Label
-- Sloc points to <<
- -- Identifier (Node1) direct name of statement identifier
- -- Exception_Junk (Flag8-Sem)
+ -- Identifier direct name of statement identifier
+ -- Exception_Junk
-- Note: Before Ada 2012, a label is always followed by a statement,
-- and this is true in the tree even in Ada 2012 mode (the parser
@@ -4911,20 +4887,19 @@ package Sinfo is
-- N_Assignment_Statement
-- Sloc points to :=
- -- Name (Node2)
- -- Expression (Node3)
- -- Is_Elaboration_Checks_OK_Node (Flag1-Sem)
- -- Is_SPARK_Mode_On_Node (Flag2-Sem)
- -- Do_Discriminant_Check (Flag3-Sem)
- -- Do_Length_Check (Flag4-Sem)
- -- Forwards_OK (Flag5-Sem)
- -- Backwards_OK (Flag6-Sem)
- -- No_Ctrl_Actions (Flag7-Sem)
- -- Has_Target_Names (Flag8-Sem)
- -- Is_Elaboration_Code (Flag9-Sem)
- -- Do_Tag_Check (Flag13-Sem)
- -- Componentwise_Assignment (Flag14-Sem)
- -- Suppress_Assignment_Checks (Flag18-Sem)
+ -- Name
+ -- Expression
+ -- Is_Elaboration_Checks_OK_Node
+ -- Is_SPARK_Mode_On_Node
+ -- Do_Discriminant_Check
+ -- Do_Length_Check
+ -- Forwards_OK
+ -- Backwards_OK
+ -- No_Ctrl_Actions
+ -- Has_Target_Names
+ -- Is_Elaboration_Code
+ -- Componentwise_Assignment
+ -- Suppress_Assignment_Checks
-- Note: if a range check is required, then the Do_Range_Check flag
-- is set in the Expression (right hand side), with the check being
@@ -4943,9 +4918,9 @@ package Sinfo is
-- N_Target_Name
-- Sloc points to @
- -- Etype (Node5-Sem)
+ -- Etype
- -- Note (Ada 2020): node is used during analysis as a placeholder for
+ -- Note (Ada 2022): node is used during analysis as a placeholder for
-- the value of the LHS of the enclosing assignment statement. Node is
-- eventually rewritten together with enclosing assignment, and backends
-- are not aware of it.
@@ -4969,18 +4944,18 @@ package Sinfo is
-- N_If_Statement
-- Sloc points to IF
- -- Condition (Node1)
- -- Then_Statements (List2)
- -- Elsif_Parts (List3) (set to No_List if none present)
- -- Else_Statements (List4) (set to No_List if no else part present)
- -- End_Span (Uint5) (set to Uint_0 if expander generated)
- -- From_Conditional_Expression (Flag1-Sem)
+ -- Condition
+ -- Then_Statements
+ -- Elsif_Parts (set to No_List if none present)
+ -- Else_Statements (set to No_List if no else part present)
+ -- End_Span (set to Uint_0 if expander generated)
+ -- From_Conditional_Expression
-- N_Elsif_Part
-- Sloc points to ELSIF
- -- Condition (Node1)
- -- Then_Statements (List2)
- -- Condition_Actions (List3-Sem)
+ -- Condition
+ -- Then_Statements
+ -- Condition_Actions
--------------------
-- 5.3 Condition --
@@ -5004,10 +4979,10 @@ package Sinfo is
-- N_Case_Statement
-- Sloc points to CASE
- -- Expression (Node3)
- -- Alternatives (List4)
- -- End_Span (Uint5) (set to Uint_0 if expander generated)
- -- From_Conditional_Expression (Flag1-Sem)
+ -- Expression
+ -- Alternatives
+ -- End_Span (set to Uint_0 if expander generated)
+ -- From_Conditional_Expression
-- Note: Before Ada 2012, a pragma in a statement sequence is always
-- followed by a statement, and this is true in the tree even in Ada
@@ -5024,14 +4999,19 @@ package Sinfo is
-- N_Case_Statement_Alternative
-- Sloc points to WHEN
- -- Discrete_Choices (List4)
- -- Statements (List3)
- -- Has_SP_Choice (Flag15-Sem)
+ -- Discrete_Choices
+ -- Statements
+ -- Has_SP_Choice
+ -- Multidefined_Bindings
-- 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.
+ -- of equivalent values or ranges. Multidefined_Bindings is True iff
+ -- more than one choice is present and each choice contains
+ -- at least one component association having a non-null Binding_Chars
+ -- attribute; this can only occur if GNAT extensions are enabled
+ -- and the type of the case selector is composite.
-------------------------
-- 5.5 Loop Statement --
@@ -5061,13 +5041,13 @@ package Sinfo is
-- N_Loop_Statement
-- Sloc points to LOOP
- -- Identifier (Node1) loop identifier (set to Empty if no identifier)
- -- Iteration_Scheme (Node2) (set to Empty if no iteration scheme)
- -- Statements (List3)
- -- End_Label (Node4)
- -- Has_Created_Identifier (Flag15)
- -- Is_Null_Loop (Flag16)
- -- Suppress_Loop_Warnings (Flag17)
+ -- Identifier loop identifier (set to Empty if no identifier)
+ -- Iteration_Scheme (set to Empty if no iteration scheme)
+ -- Statements
+ -- End_Label
+ -- Has_Created_Identifier
+ -- Is_Null_Loop
+ -- Suppress_Loop_Warnings
-- Note: the parser fills in the Identifier field if there is an
-- explicit loop identifier. Otherwise the parser leaves this field
@@ -5095,10 +5075,10 @@ package Sinfo is
-- N_Iteration_Scheme
-- Sloc points to WHILE or FOR
- -- Condition (Node1) (set to Empty if FOR case)
- -- Condition_Actions (List3-Sem)
- -- Iterator_Specification (Node2) (set to Empty if WHILE case)
- -- Loop_Parameter_Specification (Node4) (set to Empty if WHILE case)
+ -- Condition (set to Empty if FOR case)
+ -- Condition_Actions
+ -- Iterator_Specification (set to Empty if WHILE case)
+ -- Loop_Parameter_Specification (set to Empty if WHILE case)
---------------------------------------
-- 5.5 Loop Parameter Specification --
@@ -5108,14 +5088,14 @@ package Sinfo is
-- DEFINING_IDENTIFIER in [reverse] DISCRETE_SUBTYPE_DEFINITION
-- [Iterator_Filter]
- -- Note; the optional Iterator_Filter is an Ada_2020 construct.
+ -- Note: the optional Iterator_Filter is an Ada 2022 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)
+ -- Defining_Identifier
+ -- Reverse_Present
+ -- Iterator_Filter (set to Empty if not present)
+ -- Discrete_Subtype_Definition
-----------------------------------
-- 5.5.1 Iterator Specification --
@@ -5127,12 +5107,12 @@ package Sinfo is
-- N_Iterator_Specification
-- Sloc points to defining identifier
- -- Defining_Identifier (Node1)
- -- Name (Node2)
- -- Reverse_Present (Flag15)
- -- Of_Present (Flag16)
- -- Iterator_Filter (Node3) (set to Empty if not present)
- -- Subtype_Indication (Node5)
+ -- Defining_Identifier
+ -- Name
+ -- Reverse_Present
+ -- Of_Present
+ -- Iterator_Filter (set to Empty if not present)
+ -- Subtype_Indication
-- Note: The Of_Present flag distinguishes the two forms
@@ -5179,19 +5159,19 @@ package Sinfo is
-- N_Block_Statement
-- Sloc points to DECLARE or BEGIN
- -- Identifier (Node1) block direct name (set to Empty if not present)
- -- Declarations (List2) (set to No_List if no DECLARE part)
- -- Handled_Statement_Sequence (Node4)
- -- Activation_Chain_Entity (Node3-Sem)
- -- Cleanup_Actions (List5-Sem)
- -- Has_Created_Identifier (Flag15)
- -- Is_Asynchronous_Call_Block (Flag7)
- -- Is_Task_Allocation_Block (Flag6)
- -- Exception_Junk (Flag8-Sem)
- -- Is_Abort_Block (Flag4-Sem)
- -- Is_Finalization_Wrapper (Flag9-Sem)
- -- Is_Initialization_Block (Flag1-Sem)
- -- Is_Task_Master (Flag5-Sem)
+ -- Identifier block direct name (set to Empty if not present)
+ -- Declarations (set to No_List if no DECLARE part)
+ -- Handled_Statement_Sequence
+ -- Activation_Chain_Entity
+ -- Cleanup_Actions
+ -- Has_Created_Identifier
+ -- Is_Asynchronous_Call_Block
+ -- Is_Task_Allocation_Block
+ -- Exception_Junk
+ -- Is_Abort_Block
+ -- Is_Finalization_Wrapper
+ -- Is_Initialization_Block
+ -- Is_Task_Master
-------------------------
-- 5.7 Exit Statement --
@@ -5205,9 +5185,9 @@ package Sinfo is
-- N_Exit_Statement
-- Sloc points to EXIT
- -- Name (Node2) (set to Empty if no loop name present)
- -- Condition (Node1) (set to Empty if no WHEN part present)
- -- Next_Exit_Statement (Node3-Sem): Next exit on chain
+ -- Name (set to Empty if no loop name present)
+ -- Condition (set to Empty if no WHEN part present)
+ -- Next_Exit_Statement : Next exit on chain
-------------------------
-- 5.9 Goto Statement --
@@ -5217,8 +5197,8 @@ package Sinfo is
-- N_Goto_Statement
-- Sloc points to GOTO
- -- Name (Node2)
- -- Exception_Junk (Flag8-Sem)
+ -- Name
+ -- Exception_Junk
---------------------------------
-- 6.1 Subprogram Declaration --
@@ -5230,12 +5210,12 @@ package Sinfo is
-- N_Subprogram_Declaration
-- Sloc points to FUNCTION or PROCEDURE
- -- Specification (Node1)
- -- Body_To_Inline (Node3-Sem)
- -- Corresponding_Body (Node5-Sem)
- -- Parent_Spec (Node4-Sem)
- -- Is_Entry_Barrier_Function (Flag8-Sem)
- -- Is_Task_Body_Procedure (Flag1-Sem)
+ -- Specification
+ -- Body_To_Inline
+ -- Corresponding_Body
+ -- Parent_Spec
+ -- Is_Entry_Barrier_Function
+ -- Is_Task_Body_Procedure
------------------------------------------
-- 6.1 Abstract Subprogram Declaration --
@@ -5247,7 +5227,7 @@ package Sinfo is
-- N_Abstract_Subprogram_Declaration
-- Sloc points to ABSTRACT
- -- Specification (Node1)
+ -- Specification
-----------------------------------
-- 6.1 Subprogram Specification --
@@ -5264,23 +5244,23 @@ package Sinfo is
-- N_Function_Specification
-- Sloc points to FUNCTION
- -- Defining_Unit_Name (Node1) (the designator)
- -- Parameter_Specifications (List3) (set to No_List if no formal part)
- -- Null_Exclusion_Present (Flag11)
- -- Result_Definition (Node4) for result subtype
- -- Generic_Parent (Node5-Sem)
- -- Must_Override (Flag14) set if overriding indicator present
- -- Must_Not_Override (Flag15) set if not_overriding indicator present
+ -- Defining_Unit_Name (the designator)
+ -- Parameter_Specifications (set to No_List if no formal part)
+ -- Null_Exclusion_Present
+ -- Result_Definition for result subtype
+ -- Generic_Parent
+ -- Must_Override set if overriding indicator present
+ -- Must_Not_Override set if not_overriding indicator present
-- N_Procedure_Specification
-- Sloc points to PROCEDURE
- -- Defining_Unit_Name (Node1)
- -- Null_Statement (Node2-Sem) NULL statement for body, if Null_Present
- -- Parameter_Specifications (List3) (set to No_List if no formal part)
- -- Generic_Parent (Node5-Sem)
- -- Null_Present (Flag13) set for null procedure case (Ada 2005 feature)
- -- Must_Override (Flag14) set if overriding indicator present
- -- Must_Not_Override (Flag15) set if not_overriding indicator present
+ -- Defining_Unit_Name
+ -- Null_Statement NULL statement for body, if Null_Present
+ -- Parameter_Specifications (set to No_List if no formal part)
+ -- Generic_Parent
+ -- Null_Present set for null procedure case (Ada 2005 feature)
+ -- Must_Override set if overriding indicator present
+ -- Must_Not_Override set if not_overriding indicator present
-- Note: overriding indicator is an Ada 2005 feature
@@ -5297,8 +5277,8 @@ package Sinfo is
-- N_Designator
-- Sloc points to period
- -- Name (Node2) holds the parent unit name
- -- Identifier (Node1)
+ -- Name holds the parent unit name
+ -- Identifier
-- Note: Name is always non-Empty, since this node is only used for the
-- case where a parent library unit package name is present.
@@ -5328,8 +5308,8 @@ package Sinfo is
-- N_Defining_Program_Unit_Name
-- Sloc points to period
- -- Name (Node2) holds the parent unit name
- -- Defining_Identifier (Node1)
+ -- Name holds the parent unit name
+ -- Defining_Identifier
-- Note: Name is always non-Empty, since this node is only used for the
-- case where a parent unit name is present.
@@ -5350,13 +5330,13 @@ package Sinfo is
-- N_Operator_Symbol
-- Sloc points to literal
- -- Chars (Name1) contains the Name_Id for the operator symbol
- -- Strval (Str3) Id of string value. This is used if the operator
+ -- Chars contains the Name_Id for the operator symbol
+ -- Strval Id of string value. This is used if the operator
-- symbol turns out to be a normal string after all.
- -- Entity (Node4-Sem)
- -- Associated_Node (Node4-Sem)
- -- Etype (Node5-Sem)
- -- Has_Private_View (Flag11-Sem) set in generic units
+ -- Entity
+ -- Associated_Node Note this is shared with Entity
+ -- Etype
+ -- Has_Private_View (set in generic units)
-- Note: the Strval field may be set to No_String for generated
-- operator symbols that are known not to be string literals
@@ -5382,10 +5362,10 @@ package Sinfo is
-- N_Defining_Operator_Symbol
-- Sloc points to literal
- -- Chars (Name1) contains the Name_Id for the operator symbol
- -- Next_Entity (Node2-Sem)
- -- Scope (Node3-Sem)
- -- Etype (Node5-Sem)
+ -- Chars contains the Name_Id for the operator symbol
+ -- Next_Entity
+ -- Scope
+ -- Etype
----------------------------
-- 6.1 Parameter Profile --
@@ -5433,17 +5413,16 @@ package Sinfo is
-- N_Parameter_Specification
-- Sloc points to first identifier
- -- Defining_Identifier (Node1)
- -- Aliased_Present (Flag4)
- -- In_Present (Flag15)
- -- Out_Present (Flag17)
- -- Null_Exclusion_Present (Flag11)
- -- Parameter_Type (Node2) subtype mark or access definition
- -- Expression (Node3) (set to Empty if no default expression present)
- -- Do_Accessibility_Check (Flag13-Sem)
- -- More_Ids (Flag5) (set to False if no more identifiers in list)
- -- Prev_Ids (Flag6) (set to False if no previous identifiers in list)
- -- Default_Expression (Node5-Sem)
+ -- Defining_Identifier
+ -- Aliased_Present
+ -- In_Present
+ -- Out_Present
+ -- Null_Exclusion_Present
+ -- Parameter_Type subtype mark or access definition
+ -- Expression (set to Empty if no default expression present)
+ -- More_Ids (set to False if no more identifiers in list)
+ -- Prev_Ids (set to False if no previous identifiers in list)
+ -- Default_Expression
---------------
-- 6.1 Mode --
@@ -5468,22 +5447,22 @@ package Sinfo is
-- N_Subprogram_Body
-- Sloc points to FUNCTION or PROCEDURE
- -- Specification (Node1)
- -- Declarations (List2)
- -- Handled_Statement_Sequence (Node4)
- -- Activation_Chain_Entity (Node3-Sem)
- -- Corresponding_Spec (Node5-Sem)
- -- Acts_As_Spec (Flag4-Sem)
- -- Bad_Is_Detected (Flag15) used only by parser
- -- Do_Storage_Check (Flag17-Sem)
- -- Has_Relative_Deadline_Pragma (Flag9-Sem)
- -- Is_Entry_Barrier_Function (Flag8-Sem)
- -- Is_Protected_Subprogram_Body (Flag7-Sem)
- -- Is_Task_Body_Procedure (Flag1-Sem)
- -- Is_Task_Master (Flag5-Sem)
- -- Was_Attribute_Reference (Flag2-Sem)
- -- Was_Expression_Function (Flag18-Sem)
- -- Was_Originally_Stub (Flag13-Sem)
+ -- Specification
+ -- Declarations
+ -- Handled_Statement_Sequence
+ -- Activation_Chain_Entity
+ -- Corresponding_Spec
+ -- Acts_As_Spec
+ -- Bad_Is_Detected used only by parser
+ -- Do_Storage_Check
+ -- Has_Relative_Deadline_Pragma
+ -- Is_Entry_Barrier_Function
+ -- Is_Protected_Subprogram_Body
+ -- Is_Task_Body_Procedure
+ -- Is_Task_Master
+ -- Was_Attribute_Reference
+ -- Was_Expression_Function
+ -- Was_Originally_Stub
-----------------------------------
-- 6.4 Procedure Call Statement --
@@ -5500,17 +5479,16 @@ package Sinfo is
-- N_Procedure_Call_Statement
-- Sloc points to first token of name or prefix
- -- Name (Node2) stores name or prefix
- -- Parameter_Associations (List3) (set to No_List if no
+ -- Name stores name or prefix
+ -- Parameter_Associations (set to No_List if no
-- actual parameter part)
- -- First_Named_Actual (Node4-Sem)
- -- Controlling_Argument (Node1-Sem) (set to Empty if not dispatching)
- -- Is_Elaboration_Checks_OK_Node (Flag1-Sem)
- -- Is_SPARK_Mode_On_Node (Flag2-Sem)
- -- Is_Elaboration_Warnings_OK_Node (Flag3-Sem)
- -- No_Elaboration_Check (Flag4-Sem)
- -- Do_Tag_Check (Flag13-Sem)
- -- Is_Known_Guaranteed_ABE (Flag18-Sem)
+ -- First_Named_Actual
+ -- Controlling_Argument (set to Empty if not dispatching)
+ -- Is_Elaboration_Checks_OK_Node
+ -- Is_SPARK_Mode_On_Node
+ -- Is_Elaboration_Warnings_OK_Node
+ -- No_Elaboration_Check
+ -- Is_Known_Guaranteed_ABE
-- plus fields for expression
-- If any IN parameter requires a range check, then the corresponding
@@ -5533,19 +5511,18 @@ package Sinfo is
-- N_Function_Call
-- Sloc points to first token of name or prefix
- -- Name (Node2) stores name or prefix
- -- Parameter_Associations (List3) (set to No_List if no
+ -- Name stores name or prefix
+ -- Parameter_Associations (set to No_List if no
-- actual parameter part)
- -- First_Named_Actual (Node4-Sem)
- -- Controlling_Argument (Node1-Sem) (set to Empty if not dispatching)
- -- Is_Elaboration_Checks_OK_Node (Flag1-Sem)
- -- Is_SPARK_Mode_On_Node (Flag2-Sem)
- -- Is_Elaboration_Warnings_OK_Node (Flag3-Sem)
- -- No_Elaboration_Check (Flag4-Sem)
- -- Is_Expanded_Build_In_Place_Call (Flag11-Sem)
- -- Do_Tag_Check (Flag13-Sem)
- -- No_Side_Effect_Removal (Flag17-Sem)
- -- Is_Known_Guaranteed_ABE (Flag18-Sem)
+ -- First_Named_Actual
+ -- Controlling_Argument (set to Empty if not dispatching)
+ -- Is_Elaboration_Checks_OK_Node
+ -- Is_SPARK_Mode_On_Node
+ -- Is_Elaboration_Warnings_OK_Node
+ -- No_Elaboration_Check
+ -- Is_Expanded_Build_In_Place_Call
+ -- No_Side_Effect_Removal
+ -- Is_Known_Guaranteed_ABE
-- plus fields for expression
--------------------------------
@@ -5569,10 +5546,10 @@ package Sinfo is
-- N_Parameter_Association
-- Sloc points to formal parameter
- -- Selector_Name (Node2) (always non-Empty)
- -- Explicit_Actual_Parameter (Node3)
- -- Next_Named_Actual (Node4-Sem)
- -- Is_Accessibility_Actual (Flag13-Sem)
+ -- Selector_Name (always non-Empty)
+ -- Explicit_Actual_Parameter
+ -- Next_Named_Actual
+ -- Is_Accessibility_Actual
---------------------------
-- 6.4 Actual Parameter --
@@ -5602,13 +5579,12 @@ package Sinfo is
-- N_Simple_Return_Statement
-- Sloc points to RETURN
- -- Return_Statement_Entity (Node5-Sem)
- -- Expression (Node3) (set to Empty if no expression present)
- -- Storage_Pool (Node1-Sem)
- -- Procedure_To_Call (Node2-Sem)
- -- Do_Tag_Check (Flag13-Sem)
- -- By_Ref (Flag5-Sem)
- -- Comes_From_Extended_Return_Statement (Flag18-Sem)
+ -- Return_Statement_Entity
+ -- Expression (set to Empty if no expression present)
+ -- Storage_Pool
+ -- Procedure_To_Call
+ -- By_Ref
+ -- Comes_From_Extended_Return_Statement
-- Note: Return_Statement_Entity points to an E_Return_Statement
@@ -5617,13 +5593,12 @@ package Sinfo is
-- N_Extended_Return_Statement
-- Sloc points to RETURN
- -- Return_Statement_Entity (Node5-Sem)
- -- Return_Object_Declarations (List3)
- -- Handled_Statement_Sequence (Node4) (set to Empty if not present)
- -- Storage_Pool (Node1-Sem)
- -- Procedure_To_Call (Node2-Sem)
- -- Do_Tag_Check (Flag13-Sem)
- -- By_Ref (Flag5-Sem)
+ -- Return_Statement_Entity
+ -- Return_Object_Declarations
+ -- Handled_Statement_Sequence (set to Empty if not present)
+ -- Storage_Pool
+ -- Procedure_To_Call
+ -- By_Ref
-- Note: Return_Statement_Entity points to an E_Return_Statement.
@@ -5654,9 +5629,9 @@ package Sinfo is
-- N_Expression_Function
-- Sloc points to FUNCTION
- -- Specification (Node1)
- -- Expression (Node3)
- -- Corresponding_Spec (Node5-Sem)
+ -- Specification
+ -- Expression
+ -- Corresponding_Spec
------------------------------
-- 7.1 Package Declaration --
@@ -5670,10 +5645,10 @@ package Sinfo is
-- N_Package_Declaration
-- Sloc points to PACKAGE
- -- Specification (Node1)
- -- Corresponding_Body (Node5-Sem)
- -- Parent_Spec (Node4-Sem)
- -- Activation_Chain_Entity (Node3-Sem)
+ -- Specification
+ -- Corresponding_Body
+ -- Parent_Spec
+ -- Activation_Chain_Entity
--------------------------------
-- 7.1 Package Specification --
@@ -5690,13 +5665,13 @@ package Sinfo is
-- N_Package_Specification
-- Sloc points to PACKAGE
- -- Defining_Unit_Name (Node1)
- -- Visible_Declarations (List2)
- -- Private_Declarations (List3) (set to No_List if no private
+ -- Defining_Unit_Name
+ -- Visible_Declarations
+ -- Private_Declarations (set to No_List if no private
-- part present)
- -- End_Label (Node4)
- -- Generic_Parent (Node5-Sem)
- -- Limited_View_Installed (Flag18-Sem)
+ -- End_Label
+ -- Generic_Parent
+ -- Limited_View_Installed
-----------------------
-- 7.1 Package Body --
@@ -5713,11 +5688,11 @@ package Sinfo is
-- N_Package_Body
-- Sloc points to PACKAGE
- -- Defining_Unit_Name (Node1)
- -- Declarations (List2)
- -- Handled_Statement_Sequence (Node4) (set to Empty if no HSS present)
- -- Corresponding_Spec (Node5-Sem)
- -- Was_Originally_Stub (Flag13-Sem)
+ -- Defining_Unit_Name
+ -- Declarations
+ -- Handled_Statement_Sequence (set to Empty if no HSS present)
+ -- Corresponding_Spec
+ -- Was_Originally_Stub
-- Note: if a source level package does not contain a handled sequence
-- of statements, then the parser supplies a dummy one with a null
@@ -5738,13 +5713,13 @@ package Sinfo is
-- N_Private_Type_Declaration
-- Sloc points to TYPE
- -- Defining_Identifier (Node1)
- -- Discriminant_Specifications (List4) (set to No_List if no
+ -- Defining_Identifier
+ -- Discriminant_Specifications (set to No_List if no
-- discriminant part)
- -- Unknown_Discriminants_Present (Flag13) set if (<>) discriminant
- -- Abstract_Present (Flag4)
- -- Tagged_Present (Flag15)
- -- Limited_Present (Flag17)
+ -- Unknown_Discriminants_Present set if (<>) discriminant
+ -- Abstract_Present
+ -- Tagged_Present
+ -- Limited_Present
----------------------------------------
-- 7.4 Private Extension Declaration --
@@ -5761,16 +5736,16 @@ package Sinfo is
-- N_Private_Extension_Declaration
-- Sloc points to TYPE
- -- Defining_Identifier (Node1)
- -- Uninitialized_Variable (Node3-Sem)
- -- Discriminant_Specifications (List4) (set to No_List if no
+ -- Defining_Identifier
+ -- Uninitialized_Variable
+ -- Discriminant_Specifications (set to No_List if no
-- discriminant part)
- -- Unknown_Discriminants_Present (Flag13) set if (<>) discriminant
- -- Abstract_Present (Flag4)
- -- Limited_Present (Flag17)
- -- Synchronized_Present (Flag7)
- -- Subtype_Indication (Node5)
- -- Interface_List (List2) (set to No_List if none)
+ -- Unknown_Discriminants_Present set if (<>) discriminant
+ -- Abstract_Present
+ -- Limited_Present
+ -- Synchronized_Present
+ -- Subtype_Indication
+ -- Interface_List (set to No_List if none)
---------------------
-- 8.4 Use Clause --
@@ -5786,14 +5761,14 @@ package Sinfo is
-- N_Use_Package_Clause
-- Sloc points to USE
- -- Prev_Use_Clause (Node1-Sem)
- -- Name (Node2)
- -- Next_Use_Clause (Node3-Sem)
- -- Associated_Node (Node4-Sem)
- -- Hidden_By_Use_Clause (Elist5-Sem)
- -- Is_Effective_Use_Clause (Flag1)
- -- More_Ids (Flag5) (set to False if no more identifiers in list)
- -- Prev_Ids (Flag6) (set to False if no previous identifiers in list)
+ -- Prev_Use_Clause
+ -- Name
+ -- Next_Use_Clause
+ -- Associated_Node
+ -- Hidden_By_Use_Clause
+ -- Is_Effective_Use_Clause
+ -- More_Ids (set to False if no more identifiers in list)
+ -- Prev_Ids (set to False if no previous identifiers in list)
--------------------------
-- 8.4 Use Type Clause --
@@ -5807,15 +5782,15 @@ package Sinfo is
-- N_Use_Type_Clause
-- Sloc points to USE
- -- Prev_Use_Clause (Node1-Sem)
- -- Used_Operations (Elist2-Sem)
- -- Next_Use_Clause (Node3-Sem)
- -- Subtype_Mark (Node4)
- -- Hidden_By_Use_Clause (Elist5-Sem)
- -- Is_Effective_Use_Clause (Flag1)
- -- More_Ids (Flag5) (set to False if no more identifiers in list)
- -- Prev_Ids (Flag6) (set to False if no previous identifiers in list)
- -- All_Present (Flag15)
+ -- Prev_Use_Clause
+ -- Used_Operations
+ -- Next_Use_Clause
+ -- Subtype_Mark
+ -- Hidden_By_Use_Clause
+ -- Is_Effective_Use_Clause
+ -- More_Ids (set to False if no more identifiers in list)
+ -- Prev_Ids (set to False if no previous identifiers in list)
+ -- All_Present
-------------------------------
-- 8.5 Renaming Declaration --
@@ -5846,12 +5821,12 @@ package Sinfo is
-- N_Object_Renaming_Declaration
-- Sloc points to first identifier
- -- Defining_Identifier (Node1)
- -- Null_Exclusion_Present (Flag11) (set to False if not present)
- -- Subtype_Mark (Node4) (set to Empty if not present)
- -- Access_Definition (Node3) (set to Empty if not present)
- -- Name (Node2)
- -- Corresponding_Generic_Association (Node5-Sem)
+ -- Defining_Identifier
+ -- Null_Exclusion_Present (set to False if not present)
+ -- Subtype_Mark (set to Empty if not present)
+ -- Access_Definition (set to Empty if not present)
+ -- Name
+ -- Corresponding_Generic_Association
-----------------------------------------
-- 8.5 Exception Renaming Declaration --
@@ -5863,8 +5838,8 @@ package Sinfo is
-- N_Exception_Renaming_Declaration
-- Sloc points to first identifier
- -- Defining_Identifier (Node1)
- -- Name (Node2)
+ -- Defining_Identifier
+ -- Name
---------------------------------------
-- 8.5 Package Renaming Declaration --
@@ -5876,9 +5851,9 @@ package Sinfo is
-- N_Package_Renaming_Declaration
-- Sloc points to PACKAGE
- -- Defining_Unit_Name (Node1)
- -- Name (Node2)
- -- Parent_Spec (Node4-Sem)
+ -- Defining_Unit_Name
+ -- Name
+ -- Parent_Spec
------------------------------------------
-- 8.5 Subprogram Renaming Declaration --
@@ -5890,12 +5865,12 @@ package Sinfo is
-- N_Subprogram_Renaming_Declaration
-- Sloc points to RENAMES
- -- Specification (Node1)
- -- Name (Node2)
- -- Parent_Spec (Node4-Sem)
- -- Corresponding_Spec (Node5-Sem)
- -- Corresponding_Formal_Spec (Node3-Sem)
- -- From_Default (Flag6-Sem)
+ -- Specification
+ -- Name
+ -- Parent_Spec
+ -- Corresponding_Spec
+ -- Corresponding_Formal_Spec
+ -- From_Default
-----------------------------------------
-- 8.5.5 Generic Renaming Declaration --
@@ -5914,21 +5889,21 @@ package Sinfo is
-- N_Generic_Package_Renaming_Declaration
-- Sloc points to GENERIC
- -- Defining_Unit_Name (Node1)
- -- Name (Node2)
- -- Parent_Spec (Node4-Sem)
+ -- Defining_Unit_Name
+ -- Name
+ -- Parent_Spec
-- N_Generic_Procedure_Renaming_Declaration
-- Sloc points to GENERIC
- -- Defining_Unit_Name (Node1)
- -- Name (Node2)
- -- Parent_Spec (Node4-Sem)
+ -- Defining_Unit_Name
+ -- Name
+ -- Parent_Spec
-- N_Generic_Function_Renaming_Declaration
-- Sloc points to GENERIC
- -- Defining_Unit_Name (Node1)
- -- Name (Node2)
- -- Parent_Spec (Node4-Sem)
+ -- Defining_Unit_Name
+ -- Name
+ -- Parent_Spec
--------------------------------
-- 9.1 Task Type Declaration --
@@ -5941,12 +5916,12 @@ package Sinfo is
-- N_Task_Type_Declaration
-- Sloc points to TASK
- -- Defining_Identifier (Node1)
- -- Discriminant_Specifications (List4) (set to No_List if no
+ -- Defining_Identifier
+ -- Discriminant_Specifications (set to No_List if no
-- discriminant part)
- -- Interface_List (List2) (set to No_List if none)
- -- Task_Definition (Node3) (set to Empty if not present)
- -- Corresponding_Body (Node5-Sem)
+ -- Interface_List (set to No_List if none)
+ -- Task_Definition (set to Empty if not present)
+ -- Corresponding_Body
----------------------------------
-- 9.1 Single Task Declaration --
@@ -5959,9 +5934,9 @@ package Sinfo is
-- N_Single_Task_Declaration
-- Sloc points to TASK
- -- Defining_Identifier (Node1)
- -- Interface_List (List2) (set to No_List if none)
- -- Task_Definition (Node3) (set to Empty if not present)
+ -- Defining_Identifier
+ -- Interface_List (set to No_List if none)
+ -- Task_Definition (set to Empty if not present)
--------------------------
-- 9.1 Task Definition --
@@ -5978,11 +5953,11 @@ package Sinfo is
-- N_Task_Definition
-- Sloc points to first token of task definition
- -- Visible_Declarations (List2)
- -- Private_Declarations (List3) (set to No_List if no private part)
- -- End_Label (Node4)
- -- Has_Storage_Size_Pragma (Flag5-Sem)
- -- Has_Relative_Deadline_Pragma (Flag9-Sem)
+ -- Visible_Declarations
+ -- Private_Declarations (set to No_List if no private part)
+ -- End_Label
+ -- Has_Storage_Size_Pragma
+ -- Has_Relative_Deadline_Pragma
--------------------
-- 9.1 Task Item --
@@ -6007,13 +5982,13 @@ package Sinfo is
-- N_Task_Body
-- Sloc points to TASK
- -- Defining_Identifier (Node1)
- -- Declarations (List2)
- -- Handled_Statement_Sequence (Node4)
- -- Is_Task_Master (Flag5-Sem)
- -- Activation_Chain_Entity (Node3-Sem)
- -- Corresponding_Spec (Node5-Sem)
- -- Was_Originally_Stub (Flag13-Sem)
+ -- Defining_Identifier
+ -- Declarations
+ -- Handled_Statement_Sequence
+ -- Is_Task_Master
+ -- Activation_Chain_Entity
+ -- Corresponding_Spec
+ -- Was_Originally_Stub
-------------------------------------
-- 9.4 Protected Type Declaration --
@@ -6028,12 +6003,12 @@ package Sinfo is
-- N_Protected_Type_Declaration
-- Sloc points to PROTECTED
- -- Defining_Identifier (Node1)
- -- Discriminant_Specifications (List4) (set to No_List if no
+ -- Defining_Identifier
+ -- Discriminant_Specifications (set to No_List if no
-- discriminant part)
- -- Interface_List (List2) (set to No_List if none)
- -- Protected_Definition (Node3)
- -- Corresponding_Body (Node5-Sem)
+ -- Interface_List (set to No_List if none)
+ -- Protected_Definition
+ -- Corresponding_Body
---------------------------------------
-- 9.4 Single Protected Declaration --
@@ -6048,9 +6023,9 @@ package Sinfo is
-- N_Single_Protected_Declaration
-- Sloc points to PROTECTED
- -- Defining_Identifier (Node1)
- -- Interface_List (List2) (set to No_List if none)
- -- Protected_Definition (Node3)
+ -- Defining_Identifier
+ -- Interface_List (set to No_List if none)
+ -- Protected_Definition
-------------------------------
-- 9.4 Protected Definition --
@@ -6064,9 +6039,9 @@ package Sinfo is
-- N_Protected_Definition
-- Sloc points to first token of protected definition
- -- Visible_Declarations (List2)
- -- Private_Declarations (List3) (set to No_List if no private part)
- -- End_Label (Node4)
+ -- Visible_Declarations
+ -- Private_Declarations (set to No_List if no private part)
+ -- End_Label
------------------------------------------
-- 9.4 Protected Operation Declaration --
@@ -6101,11 +6076,11 @@ package Sinfo is
-- N_Protected_Body
-- Sloc points to PROTECTED
- -- Defining_Identifier (Node1)
- -- Declarations (List2) protected operation items (and pragmas)
- -- End_Label (Node4)
- -- Corresponding_Spec (Node5-Sem)
- -- Was_Originally_Stub (Flag13-Sem)
+ -- Defining_Identifier
+ -- Declarations protected operation items (and pragmas)
+ -- End_Label
+ -- Corresponding_Spec
+ -- Was_Originally_Stub
-----------------------------------
-- 9.4 Protected Operation Item --
@@ -6129,12 +6104,12 @@ package Sinfo is
-- N_Entry_Declaration
-- Sloc points to ENTRY
- -- Defining_Identifier (Node1)
- -- Discrete_Subtype_Definition (Node4) (set to Empty if not present)
- -- Parameter_Specifications (List3) (set to No_List if no formal part)
- -- Corresponding_Body (Node5-Sem)
- -- Must_Override (Flag14) set if overriding indicator present
- -- Must_Not_Override (Flag15) set if not_overriding indicator present
+ -- Defining_Identifier
+ -- Discrete_Subtype_Definition (set to Empty if not present)
+ -- Parameter_Specifications (set to No_List if no formal part)
+ -- Corresponding_Body
+ -- Must_Override set if overriding indicator present
+ -- Must_Not_Override set if not_overriding indicator present
-- Note: overriding indicator is an Ada 2005 feature
@@ -6158,11 +6133,11 @@ package Sinfo is
-- N_Accept_Statement
-- Sloc points to ACCEPT
- -- Entry_Direct_Name (Node1)
- -- Entry_Index (Node5) (set to Empty if not present)
- -- Parameter_Specifications (List3) (set to No_List if no formal part)
- -- Handled_Statement_Sequence (Node4)
- -- Declarations (List2) (set to No_List if no declarations)
+ -- Entry_Direct_Name
+ -- Entry_Index (set to Empty if not present)
+ -- Parameter_Specifications (set to No_List if no formal part)
+ -- Handled_Statement_Sequence
+ -- Declarations (set to No_List if no declarations)
------------------------
-- 9.5.2 Entry Index --
@@ -6191,11 +6166,11 @@ package Sinfo is
-- N_Entry_Body
-- Sloc points to ENTRY
- -- Defining_Identifier (Node1)
- -- Entry_Body_Formal_Part (Node5)
- -- Declarations (List2)
- -- Handled_Statement_Sequence (Node4)
- -- Activation_Chain_Entity (Node3-Sem)
+ -- Defining_Identifier
+ -- Entry_Body_Formal_Part
+ -- Declarations
+ -- Handled_Statement_Sequence
+ -- Activation_Chain_Entity
-----------------------------------
-- 9.5.2 Entry Body Formal Part --
@@ -6214,9 +6189,9 @@ package Sinfo is
-- N_Entry_Body_Formal_Part
-- Sloc points to first token
- -- Entry_Index_Specification (Node4) (set to Empty if not present)
- -- Parameter_Specifications (List3) (set to No_List if no formal part)
- -- Condition (Node1) from entry barrier of entry body
+ -- Entry_Index_Specification (set to Empty if not present)
+ -- Parameter_Specifications (set to No_List if no formal part)
+ -- Condition from entry barrier of entry body
--------------------------
-- 9.5.2 Entry Barrier --
@@ -6235,8 +6210,8 @@ package Sinfo is
-- N_Entry_Index_Specification
-- Sloc points to FOR
- -- Defining_Identifier (Node1)
- -- Discrete_Subtype_Definition (Node4)
+ -- Defining_Identifier
+ -- Discrete_Subtype_Definition
---------------------------------
-- 9.5.3 Entry Call Statement --
@@ -6251,13 +6226,13 @@ package Sinfo is
-- N_Entry_Call_Statement
-- Sloc points to first token of name
- -- Name (Node2)
- -- Parameter_Associations (List3) (set to No_List if no
+ -- Name
+ -- Parameter_Associations (set to No_List if no
-- actual parameter part)
- -- First_Named_Actual (Node4-Sem)
- -- Is_Elaboration_Checks_OK_Node (Flag1-Sem)
- -- Is_SPARK_Mode_On_Node (Flag2-Sem)
- -- Is_Elaboration_Warnings_OK_Node (Flag3-Sem)
+ -- First_Named_Actual
+ -- Is_Elaboration_Checks_OK_Node
+ -- Is_SPARK_Mode_On_Node
+ -- Is_Elaboration_Warnings_OK_Node
------------------------------
-- 9.5.4 Requeue Statement --
@@ -6271,11 +6246,11 @@ package Sinfo is
-- N_Requeue_Statement
-- Sloc points to REQUEUE
- -- Name (Node2)
- -- Abort_Present (Flag15)
- -- Is_Elaboration_Checks_OK_Node (Flag1-Sem)
- -- Is_SPARK_Mode_On_Node (Flag2-Sem)
- -- Is_Elaboration_Warnings_OK_Node (Flag3-Sem)
+ -- Name
+ -- Abort_Present
+ -- Is_Elaboration_Checks_OK_Node
+ -- Is_SPARK_Mode_On_Node
+ -- Is_Elaboration_Warnings_OK_Node
--------------------------
-- 9.6 Delay Statement --
@@ -6297,7 +6272,7 @@ package Sinfo is
-- N_Delay_Until_Statement
-- Sloc points to DELAY
- -- Expression (Node3)
+ -- Expression
-----------------------------------
-- 9.6 Delay Relative Statement --
@@ -6309,7 +6284,7 @@ package Sinfo is
-- N_Delay_Relative_Statement
-- Sloc points to DELAY
- -- Expression (Node3)
+ -- Expression
---------------------------
-- 9.7 Select Statement --
@@ -6343,8 +6318,8 @@ package Sinfo is
-- N_Selective_Accept
-- Sloc points to SELECT
- -- Select_Alternatives (List1)
- -- Else_Statements (List4) (set to No_List if no else part)
+ -- Select_Alternatives
+ -- Else_Statements (set to No_List if no else part)
------------------
-- 9.7.1 Guard --
@@ -6375,11 +6350,11 @@ package Sinfo is
-- N_Accept_Alternative
-- Sloc points to ACCEPT
- -- Accept_Statement (Node2)
- -- Condition (Node1) from the guard (set to Empty if no guard present)
- -- Statements (List3) (set to Empty_List if no statements)
- -- Pragmas_Before (List4) pragmas before alt (set to No_List if none)
- -- Accept_Handler_Records (List5-Sem)
+ -- Accept_Statement
+ -- Condition from the guard (set to Empty if no guard present)
+ -- Statements (set to Empty_List if no statements)
+ -- Pragmas_Before pragmas before alt (set to No_List if none)
+ -- Accept_Handler_Records
------------------------------
-- 9.7.1 Delay Alternative --
@@ -6392,10 +6367,10 @@ package Sinfo is
-- N_Delay_Alternative
-- Sloc points to DELAY
- -- Delay_Statement (Node2)
- -- Condition (Node1) from the guard (set to Empty if no guard present)
- -- Statements (List3) (set to Empty_List if no statements)
- -- Pragmas_Before (List4) pragmas before alt (set to No_List if none)
+ -- Delay_Statement
+ -- Condition from the guard (set to Empty if no guard present)
+ -- Statements (set to Empty_List if no statements)
+ -- Pragmas_Before pragmas before alt (set to No_List if none)
----------------------------------
-- 9.7.1 Terminate Alternative --
@@ -6407,9 +6382,9 @@ package Sinfo is
-- N_Terminate_Alternative
-- Sloc points to TERMINATE
- -- Condition (Node1) from the guard (set to Empty if no guard present)
- -- Pragmas_Before (List4) pragmas before alt (set to No_List if none)
- -- Pragmas_After (List5) pragmas after alt (set to No_List if none)
+ -- Condition from the guard (set to Empty if no guard present)
+ -- Pragmas_Before pragmas before alt (set to No_List if none)
+ -- Pragmas_After pragmas after alt (set to No_List if none)
-----------------------------
-- 9.7.2 Timed Entry Call --
@@ -6426,8 +6401,8 @@ package Sinfo is
-- N_Timed_Entry_Call
-- Sloc points to SELECT
- -- Entry_Call_Alternative (Node1)
- -- Delay_Alternative (Node4)
+ -- Entry_Call_Alternative
+ -- Delay_Alternative
-----------------------------------
-- 9.7.2 Entry Call Alternative --
@@ -6443,9 +6418,9 @@ package Sinfo is
-- N_Entry_Call_Alternative
-- Sloc points to first token of entry call statement
- -- Entry_Call_Statement (Node1)
- -- Statements (List3) (set to Empty_List if no statements)
- -- Pragmas_Before (List4) pragmas before alt (set to No_List if none)
+ -- Entry_Call_Statement
+ -- Statements (set to Empty_List if no statements)
+ -- Pragmas_Before pragmas before alt (set to No_List if none)
-----------------------------------
-- 9.7.3 Conditional Entry Call --
@@ -6462,8 +6437,8 @@ package Sinfo is
-- N_Conditional_Entry_Call
-- Sloc points to SELECT
- -- Entry_Call_Alternative (Node1)
- -- Else_Statements (List4)
+ -- Entry_Call_Alternative
+ -- Else_Statements
--------------------------------
-- 9.7.4 Asynchronous Select --
@@ -6482,8 +6457,8 @@ package Sinfo is
-- N_Asynchronous_Select
-- Sloc points to SELECT
- -- Triggering_Alternative (Node1)
- -- Abortable_Part (Node2)
+ -- Triggering_Alternative
+ -- Abortable_Part
-----------------------------------
-- 9.7.4 Triggering Alternative --
@@ -6496,9 +6471,9 @@ package Sinfo is
-- N_Triggering_Alternative
-- Sloc points to first token of triggering statement
- -- Triggering_Statement (Node1)
- -- Statements (List3) (set to Empty_List if no statements)
- -- Pragmas_Before (List4) pragmas before alt (set to No_List if none)
+ -- Triggering_Statement
+ -- Statements (set to Empty_List if no statements)
+ -- Pragmas_Before pragmas before alt (set to No_List if none)
---------------------------------
-- 9.7.4 Triggering Statement --
@@ -6516,7 +6491,7 @@ package Sinfo is
-- N_Abortable_Part
-- Sloc points to ABORT
- -- Statements (List3)
+ -- Statements
--------------------------
-- 9.8 Abort Statement --
@@ -6528,7 +6503,7 @@ package Sinfo is
-- N_Abort_Statement
-- Sloc points to ABORT
- -- Names (List2)
+ -- Names
-------------------------
-- 10.1.1 Compilation --
@@ -6579,26 +6554,26 @@ package Sinfo is
-- N_Compilation_Unit
-- Sloc points to first token of defining unit name
- -- Context_Items (List1) context items and pragmas preceding unit
- -- Private_Present (Flag15) set if library unit has private keyword
- -- Unit (Node2) library item or subunit
- -- Aux_Decls_Node (Node5) points to the N_Compilation_Unit_Aux node
- -- First_Inlined_Subprogram (Node3-Sem)
- -- Library_Unit (Node4-Sem) corresponding/parent spec/body
- -- Save_Invocation_Graph_Of_Body (Flag1-Sem)
- -- Acts_As_Spec (Flag4-Sem) flag for subprogram body with no spec
- -- Body_Required (Flag13-Sem) set for spec if body is required
- -- Has_Pragma_Suppress_All (Flag14-Sem)
- -- Context_Pending (Flag16-Sem)
- -- Has_No_Elaboration_Code (Flag17-Sem)
+ -- Context_Items context items and pragmas preceding unit
+ -- Private_Present set if library unit has private keyword
+ -- Unit library item or subunit
+ -- Aux_Decls_Node points to the N_Compilation_Unit_Aux node
+ -- First_Inlined_Subprogram
+ -- Library_Unit corresponding/parent spec/body
+ -- Save_Invocation_Graph_Of_Body
+ -- Acts_As_Spec flag for subprogram body with no spec
+ -- Body_Required set for spec if body is required
+ -- Has_Pragma_Suppress_All
+ -- Context_Pending
+ -- Has_No_Elaboration_Code
-- N_Compilation_Unit_Aux
-- Sloc is a copy of the Sloc from the N_Compilation_Unit node
- -- Declarations (List2) (set to No_List if no global declarations)
- -- Actions (List1) (set to No_List if no actions)
- -- Pragmas_After (List5) pragmas after unit (set to No_List if none)
- -- Config_Pragmas (List4) config pragmas (set to Empty_List if none)
- -- Default_Storage_Pool (Node3-Sem)
+ -- Declarations (set to No_List if no global declarations)
+ -- Actions (set to No_List if no actions)
+ -- Pragmas_After pragmas after unit (set to No_List if none)
+ -- Config_Pragmas config pragmas (set to Empty_List if none)
+ -- Default_Storage_Pool
--------------------------
-- 10.1.1 Library Item --
@@ -6682,24 +6657,24 @@ package Sinfo is
-- N_With_Clause
-- Sloc points to first token of library unit name
- -- Name (Node2)
- -- Private_Present (Flag15) set if with_clause has private keyword
- -- Limited_Present (Flag17) set if LIMITED is present
- -- Next_Implicit_With (Node3-Sem)
- -- Library_Unit (Node4-Sem)
- -- Corresponding_Spec (Node5-Sem)
- -- First_Name (Flag5) (set to True if first name or only one name)
- -- Last_Name (Flag6) (set to True if last name or only one name)
- -- Context_Installed (Flag13-Sem)
- -- Elaborate_Present (Flag4-Sem)
- -- Elaborate_All_Present (Flag14-Sem)
- -- Elaborate_All_Desirable (Flag9-Sem)
- -- Elaborate_Desirable (Flag11-Sem)
- -- Implicit_With (Flag16-Sem)
- -- Limited_View_Installed (Flag18-Sem)
- -- Parent_With (Flag1-Sem)
- -- Unreferenced_In_Spec (Flag7-Sem)
- -- No_Entities_Ref_In_Spec (Flag8-Sem)
+ -- Name
+ -- Private_Present set if with_clause has private keyword
+ -- Limited_Present set if LIMITED is present
+ -- Next_Implicit_With
+ -- Library_Unit
+ -- Corresponding_Spec
+ -- First_Name (set to True if first name or only one name)
+ -- Last_Name (set to True if last name or only one name)
+ -- Context_Installed
+ -- Elaborate_Present
+ -- Elaborate_All_Present
+ -- Elaborate_All_Desirable
+ -- Elaborate_Desirable
+ -- Implicit_With
+ -- Limited_View_Installed
+ -- Parent_With
+ -- Unreferenced_In_Spec
+ -- No_Entities_Ref_In_Spec
-- Note: Limited_Present and Limited_View_Installed are used to support
-- the implementation of Ada 2005 (AI-50217).
@@ -6743,10 +6718,10 @@ package Sinfo is
-- N_Subprogram_Body_Stub
-- Sloc points to FUNCTION or PROCEDURE
- -- Specification (Node1)
- -- Corresponding_Spec_Of_Stub (Node2-Sem)
- -- Library_Unit (Node4-Sem) points to the subunit
- -- Corresponding_Body (Node5-Sem)
+ -- Specification
+ -- Corresponding_Spec_Of_Stub
+ -- Library_Unit points to the subunit
+ -- Corresponding_Body
-------------------------------
-- 10.1.3 Package Body Stub --
@@ -6758,10 +6733,10 @@ package Sinfo is
-- N_Package_Body_Stub
-- Sloc points to PACKAGE
- -- Defining_Identifier (Node1)
- -- Corresponding_Spec_Of_Stub (Node2-Sem)
- -- Library_Unit (Node4-Sem) points to the subunit
- -- Corresponding_Body (Node5-Sem)
+ -- Defining_Identifier
+ -- Corresponding_Spec_Of_Stub
+ -- Library_Unit points to the subunit
+ -- Corresponding_Body
----------------------------
-- 10.1.3 Task Body Stub --
@@ -6773,10 +6748,10 @@ package Sinfo is
-- N_Task_Body_Stub
-- Sloc points to TASK
- -- Defining_Identifier (Node1)
- -- Corresponding_Spec_Of_Stub (Node2-Sem)
- -- Library_Unit (Node4-Sem) points to the subunit
- -- Corresponding_Body (Node5-Sem)
+ -- Defining_Identifier
+ -- Corresponding_Spec_Of_Stub
+ -- Library_Unit points to the subunit
+ -- Corresponding_Body
---------------------------------
-- 10.1.3 Protected Body Stub --
@@ -6790,10 +6765,10 @@ package Sinfo is
-- N_Protected_Body_Stub
-- Sloc points to PROTECTED
- -- Defining_Identifier (Node1)
- -- Corresponding_Spec_Of_Stub (Node2-Sem)
- -- Library_Unit (Node4-Sem) points to the subunit
- -- Corresponding_Body (Node5-Sem)
+ -- Defining_Identifier
+ -- Corresponding_Spec_Of_Stub
+ -- Library_Unit points to the subunit
+ -- Corresponding_Body
---------------------
-- 10.1.3 Subunit --
@@ -6803,9 +6778,9 @@ package Sinfo is
-- N_Subunit
-- Sloc points to SEPARATE
- -- Name (Node2) is the name of the parent unit
- -- Proper_Body (Node1) is the subunit body
- -- Corresponding_Stub (Node3-Sem) is the stub declaration for the unit.
+ -- Name is the name of the parent unit
+ -- Proper_Body is the subunit body
+ -- Corresponding_Stub is the stub declaration for the unit.
---------------------------------
-- 11.1 Exception Declaration --
@@ -6822,11 +6797,11 @@ package Sinfo is
-- N_Exception_Declaration
-- Sloc points to EXCEPTION
- -- Defining_Identifier (Node1)
- -- Expression (Node3-Sem)
- -- Renaming_Exception (Node2-Sem)
- -- More_Ids (Flag5) (set to False if no more identifiers in list)
- -- Prev_Ids (Flag6) (set to False if no previous identifiers in list)
+ -- Defining_Identifier
+ -- Expression
+ -- Renaming_Exception
+ -- More_Ids (set to False if no more identifiers in list)
+ -- Prev_Ids (set to False if no previous identifiers in list)
------------------------------------------
-- 11.2 Handled Sequence Of Statements --
@@ -6898,11 +6873,11 @@ package Sinfo is
-- N_Handled_Sequence_Of_Statements
-- Sloc points to first token of first statement
- -- Statements (List3)
- -- End_Label (Node4) (set to Empty if expander generated)
- -- Exception_Handlers (List5) (set to No_List if none present)
- -- At_End_Proc (Node1) (set to Empty if no clean up procedure)
- -- First_Real_Statement (Node2-Sem)
+ -- Statements
+ -- End_Label (set to Empty if expander generated)
+ -- Exception_Handlers (set to No_List if none present)
+ -- At_End_Proc (set to Empty if no clean up procedure)
+ -- First_Real_Statement
-- Note: the parent always contains a Declarations field which contains
-- declarations associated with the handled sequence of statements. This
@@ -6924,13 +6899,13 @@ package Sinfo is
-- N_Exception_Handler
-- Sloc points to WHEN
- -- Choice_Parameter (Node2) (set to Empty if not present)
- -- Exception_Choices (List4)
- -- Statements (List3)
- -- Exception_Label (Node5-Sem) (set to Empty of not present)
- -- Local_Raise_Statements (Elist1-Sem) (set to No_Elist if not present)
- -- Local_Raise_Not_OK (Flag7-Sem)
- -- Has_Local_Raise (Flag8-Sem)
+ -- Choice_Parameter (set to Empty if not present)
+ -- Exception_Choices
+ -- Statements
+ -- Exception_Label (set to Empty if not present)
+ -- Local_Raise_Statements (set to No_Elist if not present)
+ -- Local_Raise_Not_OK
+ -- Has_Local_Raise
------------------------------------------
-- 11.2 Choice parameter specification --
@@ -6965,9 +6940,9 @@ package Sinfo is
-- N_Raise_Statement
-- Sloc points to RAISE
- -- Name (Node2) (set to Empty if no exception name present)
- -- Expression (Node3) (set to Empty if no expression present)
- -- From_At_End (Flag4-Sem)
+ -- Name (set to Empty if no exception name present)
+ -- Expression (set to Empty if no expression present)
+ -- From_At_End
----------------------------
-- 11.3 Raise Expression --
@@ -6977,9 +6952,9 @@ package Sinfo is
-- N_Raise_Expression
-- Sloc points to RAISE
- -- Name (Node2) (always present)
- -- Expression (Node3) (set to Empty if no expression present)
- -- Convert_To_Return_False (Flag13-Sem)
+ -- Name (always present)
+ -- Expression (set to Empty if no expression present)
+ -- Convert_To_Return_False
-- plus fields for expression
-------------------------------
@@ -7001,10 +6976,10 @@ package Sinfo is
-- N_Generic_Subprogram_Declaration
-- Sloc points to GENERIC
- -- Specification (Node1) subprogram specification
- -- Corresponding_Body (Node5-Sem)
- -- Generic_Formal_Declarations (List2) from generic formal part
- -- Parent_Spec (Node4-Sem)
+ -- Specification subprogram specification
+ -- Corresponding_Body
+ -- Generic_Formal_Declarations from generic formal part
+ -- Parent_Spec
---------------------------------------
-- 12.1 Generic Package Declaration --
@@ -7022,11 +6997,11 @@ package Sinfo is
-- N_Generic_Package_Declaration
-- Sloc points to GENERIC
- -- Specification (Node1) package specification
- -- Corresponding_Body (Node5-Sem)
- -- Generic_Formal_Declarations (List2) from generic formal part
- -- Parent_Spec (Node4-Sem)
- -- Activation_Chain_Entity (Node3-Sem)
+ -- Specification package specification
+ -- Corresponding_Body
+ -- Generic_Formal_Declarations from generic formal part
+ -- Parent_Spec
+ -- Activation_Chain_Entity
-------------------------------
-- 12.1 Generic Formal Part --
@@ -7064,49 +7039,49 @@ package Sinfo is
-- N_Package_Instantiation
-- Sloc points to PACKAGE
- -- Defining_Unit_Name (Node1)
- -- Name (Node2)
- -- Generic_Associations (List3) (set to No_List if no
+ -- Defining_Unit_Name
+ -- Name
+ -- Generic_Associations (set to No_List if no
-- generic actual part)
- -- Parent_Spec (Node4-Sem)
- -- Instance_Spec (Node5-Sem)
- -- Is_Elaboration_Checks_OK_Node (Flag1-Sem)
- -- Is_SPARK_Mode_On_Node (Flag2-Sem)
- -- Is_Elaboration_Warnings_OK_Node (Flag3-Sem)
- -- Is_Declaration_Level_Node (Flag5-Sem)
- -- Is_Known_Guaranteed_ABE (Flag18-Sem)
+ -- Parent_Spec
+ -- Instance_Spec
+ -- Is_Elaboration_Checks_OK_Node
+ -- Is_SPARK_Mode_On_Node
+ -- Is_Elaboration_Warnings_OK_Node
+ -- Is_Declaration_Level_Node
+ -- Is_Known_Guaranteed_ABE
-- N_Procedure_Instantiation
-- Sloc points to PROCEDURE
- -- Defining_Unit_Name (Node1)
- -- Name (Node2)
- -- Parent_Spec (Node4-Sem)
- -- Generic_Associations (List3) (set to No_List if no
+ -- Defining_Unit_Name
+ -- Name
+ -- Parent_Spec
+ -- Generic_Associations (set to No_List if no
-- generic actual part)
- -- Instance_Spec (Node5-Sem)
- -- Is_Elaboration_Checks_OK_Node (Flag1-Sem)
- -- Is_SPARK_Mode_On_Node (Flag2-Sem)
- -- Is_Elaboration_Warnings_OK_Node (Flag3-Sem)
- -- Is_Declaration_Level_Node (Flag5-Sem)
- -- Must_Override (Flag14) set if overriding indicator present
- -- Must_Not_Override (Flag15) set if not_overriding indicator present
- -- Is_Known_Guaranteed_ABE (Flag18-Sem)
+ -- Instance_Spec
+ -- Is_Elaboration_Checks_OK_Node
+ -- Is_SPARK_Mode_On_Node
+ -- Is_Elaboration_Warnings_OK_Node
+ -- Is_Declaration_Level_Node
+ -- Must_Override set if overriding indicator present
+ -- Must_Not_Override set if not_overriding indicator present
+ -- Is_Known_Guaranteed_ABE
-- N_Function_Instantiation
-- Sloc points to FUNCTION
- -- Defining_Unit_Name (Node1)
- -- Name (Node2)
- -- Generic_Associations (List3) (set to No_List if no
+ -- Defining_Unit_Name
+ -- Name
+ -- Generic_Associations (set to No_List if no
-- generic actual part)
- -- Parent_Spec (Node4-Sem)
- -- Instance_Spec (Node5-Sem)
- -- Is_Elaboration_Checks_OK_Node (Flag1-Sem)
- -- Is_SPARK_Mode_On_Node (Flag2-Sem)
- -- Is_Elaboration_Warnings_OK_Node (Flag3-Sem)
- -- Is_Declaration_Level_Node (Flag5-Sem)
- -- Must_Override (Flag14) set if overriding indicator present
- -- Must_Not_Override (Flag15) set if not_overriding indicator present
- -- Is_Known_Guaranteed_ABE (Flag18-Sem)
+ -- Parent_Spec
+ -- Instance_Spec
+ -- Is_Elaboration_Checks_OK_Node
+ -- Is_SPARK_Mode_On_Node
+ -- Is_Elaboration_Warnings_OK_Node
+ -- Is_Declaration_Level_Node
+ -- Must_Override set if overriding indicator present
+ -- Must_Not_Override set if not_overriding indicator present
+ -- Is_Known_Guaranteed_ABE
-- Note: overriding indicator is an Ada 2005 feature
@@ -7137,10 +7112,10 @@ package Sinfo is
-- N_Generic_Association
-- Sloc points to first token of generic association
- -- Selector_Name (Node2) (set to Empty if no formal
+ -- Selector_Name (set to Empty if no formal
-- parameter selector name)
- -- Explicit_Generic_Actual_Parameter (Node1) (Empty if box present)
- -- Box_Present (Flag15) (for formal_package associations with a box)
+ -- Explicit_Generic_Actual_Parameter (Empty if box present)
+ -- Box_Present (for formal_package associations with a box)
---------------------------------------------
-- 12.3 Explicit Generic Actual Parameter --
@@ -7172,15 +7147,15 @@ package Sinfo is
-- N_Formal_Object_Declaration
-- Sloc points to first identifier
- -- Defining_Identifier (Node1)
- -- In_Present (Flag15)
- -- Out_Present (Flag17)
- -- Null_Exclusion_Present (Flag11) (set to False if not present)
- -- Subtype_Mark (Node4) (set to Empty if not present)
- -- Access_Definition (Node3) (set to Empty if not present)
- -- Default_Expression (Node5) (set to Empty if no default expression)
- -- More_Ids (Flag5) (set to False if no more identifiers in list)
- -- Prev_Ids (Flag6) (set to False if no previous identifiers in list)
+ -- Defining_Identifier
+ -- In_Present
+ -- Out_Present
+ -- Null_Exclusion_Present (set to False if not present)
+ -- Subtype_Mark (set to Empty if not present)
+ -- Access_Definition (set to Empty if not present)
+ -- Default_Expression (set to Empty if no default expression)
+ -- More_Ids (set to False if no more identifiers in list)
+ -- Prev_Ids (set to False if no previous identifiers in list)
-----------------------------------
-- 12.5 Formal Type Declaration --
@@ -7194,11 +7169,12 @@ package Sinfo is
-- N_Formal_Type_Declaration
-- Sloc points to TYPE
- -- Defining_Identifier (Node1)
- -- Formal_Type_Definition (Node3)
- -- Discriminant_Specifications (List4) (set to No_List if no
+ -- Defining_Identifier
+ -- Formal_Type_Definition
+ -- Discriminant_Specifications (set to No_List if no
-- discriminant part)
- -- Unknown_Discriminants_Present (Flag13) set if (<>) discriminant
+ -- Unknown_Discriminants_Present set if (<>) discriminant
+ -- Default_Subtype_Mark
----------------------------------
-- 12.5 Formal type definition --
@@ -7234,10 +7210,10 @@ package Sinfo is
-- N_Formal_Private_Type_Definition
-- Sloc points to PRIVATE
- -- Uninitialized_Variable (Node3-Sem)
- -- Abstract_Present (Flag4)
- -- Tagged_Present (Flag15)
- -- Limited_Present (Flag17)
+ -- Uninitialized_Variable
+ -- Abstract_Present
+ -- Tagged_Present
+ -- Limited_Present
--------------------------------------------
-- 12.5.1 Formal Derived Type Definition --
@@ -7250,12 +7226,12 @@ package Sinfo is
-- N_Formal_Derived_Type_Definition
-- Sloc points to NEW
- -- Subtype_Mark (Node4)
- -- Private_Present (Flag15)
- -- Abstract_Present (Flag4)
- -- Limited_Present (Flag17)
- -- Synchronized_Present (Flag7)
- -- Interface_List (List2) (set to No_List if none)
+ -- Subtype_Mark
+ -- Private_Present
+ -- Abstract_Present
+ -- Limited_Present
+ -- Synchronized_Present
+ -- Interface_List (set to No_List if none)
-----------------------------------------------
-- 12.5.1 Formal Incomplete Type Definition --
@@ -7265,7 +7241,7 @@ package Sinfo is
-- N_Formal_Incomplete_Type_Definition
-- Sloc points to identifier of parent
- -- Tagged_Present (Flag15)
+ -- Tagged_Present
---------------------------------------------
-- 12.5.2 Formal Discrete Type Definition --
@@ -7359,9 +7335,9 @@ package Sinfo is
-- N_Formal_Concrete_Subprogram_Declaration
-- Sloc points to WITH
- -- Specification (Node1)
- -- Default_Name (Node2) (set to Empty if no subprogram default)
- -- Box_Present (Flag15)
+ -- Specification
+ -- Default_Name (set to Empty if no subprogram default)
+ -- Box_Present
-- Note: if no subprogram default is present, then Name is set
-- to Empty, and Box_Present is False.
@@ -7376,9 +7352,9 @@ package Sinfo is
-- N_Formal_Abstract_Subprogram_Declaration
-- Sloc points to WITH
- -- Specification (Node1)
- -- Default_Name (Node2) (set to Empty if no subprogram default)
- -- Box_Present (Flag15)
+ -- Specification
+ -- Default_Name (set to Empty if no subprogram default)
+ -- Box_Present
-- Note: if no subprogram default is present, then Name is set
-- to Empty, and Box_Present is False.
@@ -7413,13 +7389,13 @@ package Sinfo is
-- N_Formal_Package_Declaration
-- Sloc points to WITH
- -- Defining_Identifier (Node1)
- -- Name (Node2)
- -- Generic_Associations (List3) (set to No_List if (<>) case or
+ -- Defining_Identifier
+ -- Name
+ -- Generic_Associations (set to No_List if (<>) case or
-- empty generic actual part)
- -- Box_Present (Flag15)
- -- Instance_Spec (Node5-Sem)
- -- Is_Known_Guaranteed_ABE (Flag18-Sem)
+ -- Box_Present
+ -- Instance_Spec
+ -- Is_Known_Guaranteed_ABE
--------------------------------------
-- 12.7 Formal Package Actual Part --
@@ -7500,16 +7476,16 @@ package Sinfo is
-- N_Attribute_Definition_Clause
-- Sloc points to FOR
- -- Name (Node2) the local name
- -- Chars (Name1) the identifier name from the attribute designator
- -- Expression (Node3) the expression or name
- -- Entity (Node4-Sem)
- -- Next_Rep_Item (Node5-Sem)
- -- From_At_Mod (Flag4-Sem)
- -- Check_Address_Alignment (Flag11-Sem)
- -- From_Aspect_Specification (Flag13-Sem)
- -- Is_Delayed_Aspect (Flag14-Sem)
- -- Address_Warning_Posted (Flag18-Sem)
+ -- Name the local name
+ -- Chars the identifier name from the attribute designator
+ -- Expression the expression or name
+ -- Entity
+ -- Next_Rep_Item
+ -- From_At_Mod
+ -- Check_Address_Alignment
+ -- From_Aspect_Specification
+ -- Is_Delayed_Aspect
+ -- Address_Warning_Posted
-- Note: if From_Aspect_Specification is set, then Sloc points to the
-- aspect name, and Entity is resolved already to reference the entity
@@ -7552,19 +7528,19 @@ package Sinfo is
-- N_Aspect_Specification
-- Sloc points to aspect identifier
- -- Identifier (Node1) aspect identifier
- -- Aspect_Rep_Item (Node2-Sem)
- -- Expression (Node3) Aspect_Definition (set to Empty if none)
- -- Entity (Node4-Sem) entity to which the aspect applies
- -- Next_Rep_Item (Node5-Sem)
- -- Class_Present (Flag6) Set if 'Class present
- -- Is_Ignored (Flag9-Sem)
- -- Is_Checked (Flag11-Sem)
- -- Is_Delayed_Aspect (Flag14-Sem)
- -- Is_Disabled (Flag15-Sem)
- -- Is_Boolean_Aspect (Flag16-Sem)
- -- Split_PPC (Flag17) Set if split pre/post attribute
- -- Aspect_On_Partial_View (Flag18-Sem)
+ -- Identifier aspect identifier
+ -- Aspect_Rep_Item
+ -- Expression (set to Empty if none)
+ -- Entity entity to which the aspect applies
+ -- Next_Rep_Item
+ -- Class_Present Set if 'Class present
+ -- Is_Ignored
+ -- Is_Checked
+ -- Is_Delayed_Aspect
+ -- Is_Disabled
+ -- Is_Boolean_Aspect
+ -- Split_PPC Set if split pre/post attribute
+ -- Aspect_On_Partial_View
-- Note: Aspect_Specification is an Ada 2012 feature
@@ -7594,9 +7570,9 @@ package Sinfo is
-- N_Enumeration_Representation_Clause
-- Sloc points to FOR
- -- Identifier (Node1) direct name
- -- Array_Aggregate (Node3)
- -- Next_Rep_Item (Node5-Sem)
+ -- Identifier direct name
+ -- Array_Aggregate
+ -- Next_Rep_Item
---------------------------------
-- 13.4 Enumeration aggregate --
@@ -7621,10 +7597,10 @@ package Sinfo is
-- N_Record_Representation_Clause
-- Sloc points to FOR
- -- Identifier (Node1) direct name
- -- Mod_Clause (Node2) (set to Empty if no mod clause present)
- -- Component_Clauses (List3)
- -- Next_Rep_Item (Node5-Sem)
+ -- Identifier direct name
+ -- Mod_Clause (set to Empty if no mod clause present)
+ -- Component_Clauses
+ -- Next_Rep_Item
------------------------------
-- 13.5.1 Component clause --
@@ -7636,10 +7612,10 @@ package Sinfo is
-- N_Component_Clause
-- Sloc points to AT
- -- Component_Name (Node1) points to Name or Attribute_Reference
- -- Position (Node2)
- -- First_Bit (Node3)
- -- Last_Bit (Node4)
+ -- Component_Name points to Name or Attribute_Reference
+ -- Position
+ -- First_Bit
+ -- Last_Bit
----------------------
-- 13.5.1 Position --
@@ -7677,7 +7653,7 @@ package Sinfo is
-- N_Code_Statement
-- Sloc points to first token of the expression
- -- Expression (Node3)
+ -- Expression
-- Note: package Exp_Code contains an abstract functional interface
-- for use by Gigi in accessing the data from N_Code_Statement nodes.
@@ -7717,31 +7693,31 @@ package Sinfo is
-- Sloc points to the function name
-- plus fields for binary operator
-- plus fields for expression
- -- Shift_Count_OK (Flag4-Sem)
+ -- Shift_Count_OK
-- N_Op_Rotate_Right
-- Sloc points to the function name
-- plus fields for binary operator
-- plus fields for expression
- -- Shift_Count_OK (Flag4-Sem)
+ -- Shift_Count_OK
-- N_Op_Shift_Left
-- Sloc points to the function name
-- plus fields for binary operator
-- plus fields for expression
- -- Shift_Count_OK (Flag4-Sem)
+ -- Shift_Count_OK
-- N_Op_Shift_Right_Arithmetic
-- Sloc points to the function name
-- plus fields for binary operator
-- plus fields for expression
- -- Shift_Count_OK (Flag4-Sem)
+ -- Shift_Count_OK
-- N_Op_Shift_Right
-- Sloc points to the function name
-- plus fields for binary operator
-- plus fields for expression
- -- Shift_Count_OK (Flag4-Sem)
+ -- Shift_Count_OK
-- Note: N_Op_Rotate_Left, N_Op_Rotate_Right, N_Shift_Right_Arithmetic
-- never appear in the expanded tree if Modify_Tree_For_C mode is set.
@@ -7770,8 +7746,8 @@ package Sinfo is
-- N_Delta_Constraint
-- Sloc points to DELTA
- -- Delta_Expression (Node3)
- -- Range_Constraint (Node4) (set to Empty if not present)
+ -- Delta_Expression
+ -- Range_Constraint (set to Empty if not present)
--------------------
-- J.7 At Clause --
@@ -7790,8 +7766,8 @@ package Sinfo is
-- N_At_Clause
-- Sloc points to FOR
- -- Identifier (Node1)
- -- Expression (Node3)
+ -- Identifier
+ -- Expression
---------------------
-- J.8 Mod clause --
@@ -7816,8 +7792,8 @@ package Sinfo is
-- N_Mod_Clause
-- Sloc points to AT
- -- Expression (Node3)
- -- Pragmas_Before (List4) Pragmas before mod clause (No_List if none)
+ -- Expression
+ -- Pragmas_Before Pragmas before mod clause (No_List if none)
--------------------
-- Semantic Nodes --
@@ -7857,15 +7833,15 @@ package Sinfo is
-- N_Call_Marker
-- Sloc points to Sloc of original call
- -- Target (Node1-Sem)
- -- Is_Elaboration_Checks_OK_Node (Flag1-Sem)
- -- Is_SPARK_Mode_On_Node (Flag2-Sem)
- -- Is_Elaboration_Warnings_OK_Node (Flag3-Sem)
- -- 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)
+ -- Target
+ -- Is_Elaboration_Checks_OK_Node
+ -- Is_SPARK_Mode_On_Node
+ -- Is_Elaboration_Warnings_OK_Node
+ -- Is_Source_Call
+ -- Is_Declaration_Level_Node
+ -- Is_Dispatching_Call
+ -- Is_Preelaborable_Call
+ -- Is_Known_Guaranteed_ABE
------------------------
-- Compound Statement --
@@ -7898,7 +7874,7 @@ package Sinfo is
-- end;
-- N_Compound_Statement
- -- Actions (List1)
+ -- Actions
--------------
-- Contract --
@@ -7921,10 +7897,10 @@ package Sinfo is
-- N_Contract
-- Sloc points to the subprogram's name
- -- Pre_Post_Conditions (Node1-Sem) (set to Empty if none)
- -- Contract_Test_Cases (Node2-Sem) (set to Empty if none)
- -- Classifications (Node3-Sem) (set to Empty if none)
- -- Is_Expanded_Contract (Flag1-Sem)
+ -- Pre_Post_Conditions (set to Empty if none)
+ -- Contract_Test_Cases (set to Empty if none)
+ -- Classifications (set to Empty if none)
+ -- Is_Expanded_Contract
-- Pre_Post_Conditions contains a collection of pragmas that correspond
-- to pre- and postconditions associated with an entry or a subprogram
@@ -7991,17 +7967,17 @@ package Sinfo is
-- N_Expanded_Name
-- Sloc points to the period
- -- Chars (Name1) copy of Chars field of selector name
- -- Prefix (Node3)
- -- Selector_Name (Node2)
- -- Entity (Node4-Sem)
- -- Associated_Node (Node4-Sem)
- -- Is_Elaboration_Checks_OK_Node (Flag1-Sem)
- -- Is_SPARK_Mode_On_Node (Flag2-Sem)
- -- Is_Elaboration_Warnings_OK_Node (Flag3-Sem)
- -- Has_Private_View (Flag11-Sem) set in generic units
- -- Redundant_Use (Flag13-Sem)
- -- Atomic_Sync_Required (Flag14-Sem)
+ -- Chars copy of Chars field of selector name
+ -- Prefix
+ -- Selector_Name
+ -- Entity
+ -- Associated_Node
+ -- Is_Elaboration_Checks_OK_Node
+ -- Is_SPARK_Mode_On_Node
+ -- Is_Elaboration_Warnings_OK_Node
+ -- Has_Private_View (set in generic units)
+ -- Redundant_Use
+ -- Atomic_Sync_Required
-- plus fields for expression
-----------------------------
@@ -8026,7 +8002,7 @@ package Sinfo is
-- If the actions contain declarations, then these declarations may
-- be referenced within the expression.
- -- (AI12-0236-1): In Ada 2020, for a declare_expression, the parser
+ -- (AI12-0236-1): In Ada 2022, 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
@@ -8045,8 +8021,8 @@ package Sinfo is
-- in expression end
-- N_Expression_With_Actions
- -- Actions (List1)
- -- Expression (Node3)
+ -- Actions
+ -- Expression
-- plus fields for expression
-- Note: In the final generated tree presented to the code generator,
@@ -8074,10 +8050,10 @@ package Sinfo is
-- N_Free_Statement
-- Sloc is copied from the unchecked deallocation call
- -- Expression (Node3) argument to unchecked deallocation call
- -- Storage_Pool (Node1-Sem)
- -- Procedure_To_Call (Node2-Sem)
- -- Actual_Designated_Subtype (Node4-Sem)
+ -- Expression argument to unchecked deallocation call
+ -- Storage_Pool
+ -- Procedure_To_Call
+ -- Actual_Designated_Subtype
-- Note: in the case where a debug source file is generated, the Sloc
-- for this node points to the FREE keyword in the Sprint file output.
@@ -8113,11 +8089,11 @@ package Sinfo is
-- N_Freeze_Entity
-- Sloc points near freeze point (see above special note)
- -- Entity (Node4-Sem)
- -- Access_Types_To_Process (Elist2-Sem) (set to No_Elist if none)
- -- TSS_Elist (Elist3-Sem) (set to No_Elist if no associated TSS's)
- -- Actions (List1) (set to No_List if no freeze actions)
- -- First_Subtype_Link (Node5-Sem) (set to Empty if no link)
+ -- Entity
+ -- Access_Types_To_Process (set to No_Elist if none)
+ -- TSS_Elist (set to No_Elist if no associated TSS's)
+ -- Actions (set to No_List if no freeze actions)
+ -- First_Subtype_Link (set to Empty if no link)
-- The Actions field holds actions associated with the freeze. These
-- actions are elaborated at the point where the type is frozen.
@@ -8146,7 +8122,7 @@ package Sinfo is
-- N_Freeze_Generic_Entity
-- Sloc points near freeze point
- -- Entity (Node4-Sem)
+ -- Entity
--------------------------------
-- Implicit Label Declaration --
@@ -8178,8 +8154,8 @@ package Sinfo is
-- N_Implicit_Label_Declaration
-- Sloc points to the << token for a statement identifier, or to the
-- LOOP, DECLARE, or BEGIN token for a loop or block identifier
- -- Defining_Identifier (Node1)
- -- Label_Construct (Node2-Sem)
+ -- Defining_Identifier
+ -- Label_Construct
-- Note: in the case where a debug source file is generated, the Sloc
-- for this node points to the label name in the generated declaration.
@@ -8203,7 +8179,7 @@ package Sinfo is
-- N_Itype_Reference
-- Sloc points to the node generating the reference
- -- Itype (Node1-Sem)
+ -- Itype
-- Note: in the case where a debug source file is generated, the Sloc
-- for this node points to the REFERENCE keyword in the file output.
@@ -8252,20 +8228,20 @@ package Sinfo is
-- N_Raise_Constraint_Error
-- Sloc references related construct
- -- Condition (Node1) (set to Empty if no condition)
- -- Reason (Uint3)
+ -- Condition (set to Empty if no condition)
+ -- Reason
-- plus fields for expression
-- N_Raise_Program_Error
-- Sloc references related construct
- -- Condition (Node1) (set to Empty if no condition)
- -- Reason (Uint3)
+ -- Condition (set to Empty if no condition)
+ -- Reason
-- plus fields for expression
-- N_Raise_Storage_Error
-- Sloc references related construct
- -- Condition (Node1) (set to Empty if no condition)
- -- Reason (Uint3)
+ -- Condition (set to Empty if no condition)
+ -- Reason
-- plus fields for expression
-- Note: Sloc is copied from the expression generating the exception.
@@ -8319,15 +8295,15 @@ package Sinfo is
-- N_Push_Constraint_Error_Label
-- Sloc references first statement in region covered
- -- Exception_Label (Node5-Sem)
+ -- Exception_Label
-- N_Push_Program_Error_Label
-- Sloc references first statement in region covered
- -- Exception_Label (Node5-Sem)
+ -- Exception_Label
-- N_Push_Storage_Error_Label
-- Sloc references first statement in region covered
- -- Exception_Label (Node5-Sem)
+ -- Exception_Label
-- N_Pop_Constraint_Error_Label
-- Sloc references last statement in region covered
@@ -8368,7 +8344,7 @@ package Sinfo is
-- N_Reference
-- Sloc is copied from the expression
- -- Prefix (Node3)
+ -- Prefix
-- plus fields for expression
-- Note: in the case where a debug source file is generated, the Sloc
@@ -8390,7 +8366,7 @@ package Sinfo is
-- N_SCIL_Dispatch_Table_Tag_Init
-- Sloc references a node for a tag initialization
- -- SCIL_Entity (Node4-Sem)
+ -- SCIL_Entity
--
-- An N_SCIL_Dispatch_Table_Tag_Init node may be associated (via
-- Get_SCIL_Node) with the N_Object_Declaration node corresponding to
@@ -8398,9 +8374,9 @@ package Sinfo is
-- N_SCIL_Dispatching_Call
-- Sloc references the node of a dispatching call
- -- SCIL_Target_Prim (Node2-Sem)
- -- SCIL_Entity (Node4-Sem)
- -- SCIL_Controlling_Tag (Node5-Sem)
+ -- SCIL_Target_Prim
+ -- SCIL_Entity
+ -- SCIL_Controlling_Tag
--
-- An N_Scil_Dispatching call node may be associated (via Get_SCIL_Node)
-- with the N_Procedure_Call_Statement or N_Function_Call node (or a
@@ -8408,8 +8384,8 @@ package Sinfo is
-- N_SCIL_Membership_Test
-- Sloc references the node of a membership test
- -- SCIL_Tag_Value (Node5-Sem)
- -- SCIL_Entity (Node4-Sem)
+ -- SCIL_Tag_Value
+ -- SCIL_Entity
--
-- An N_Scil_Membership_Test node may be associated (via Get_SCIL_Node)
-- with the N_In node (or a rewriting thereof) corresponding to a
@@ -8431,7 +8407,7 @@ package Sinfo is
-- N_Unchecked_Expression
-- Sloc is a copy of the Sloc of the expression
- -- Expression (Node3)
+ -- Expression
-- plus fields for expression
-- Note: in the case where a debug source file is generated, the Sloc
@@ -8444,8 +8420,11 @@ package Sinfo is
-- An unchecked type conversion node represents the semantic action
-- corresponding to a call to an instantiation of Unchecked_Conversion.
-- It is generated as a result of actual use of Unchecked_Conversion
- -- and also the expander generates unchecked type conversion nodes
- -- directly for expansion of complex semantic actions.
+ -- and also by the expander.
+
+ -- Unchecked type conversion nodes should be created by calling
+ -- Tbuild.Unchecked_Convert_To, rather than by directly calling
+ -- Nmake.Make_Unchecked_Type_Conversion.
-- Note: an unchecked type conversion is a variable as far as the
-- semantics are concerned, which is convenient for the expander.
@@ -8457,10 +8436,10 @@ package Sinfo is
-- N_Unchecked_Type_Conversion
-- Sloc points to related node in source
- -- Subtype_Mark (Node4)
- -- Expression (Node3)
- -- Kill_Range_Check (Flag11-Sem)
- -- No_Truncation (Flag17-Sem)
+ -- Subtype_Mark
+ -- Expression
+ -- Kill_Range_Check
+ -- No_Truncation
-- plus fields for expression
-- Note: in the case where a debug source file is generated, the Sloc
@@ -8499,8 +8478,8 @@ package Sinfo is
-- N_Validate_Unchecked_Conversion
-- Sloc points to instantiation (location for warning message)
- -- Source_Type (Node1-Sem)
- -- Target_Type (Node2-Sem)
+ -- Source_Type
+ -- Target_Type
-- Note: in the case where a debug source file is generated, the Sloc
-- for this node points to the VALIDATE keyword in the file output.
@@ -8532,12 +8511,12 @@ package Sinfo is
-- N_Variable_Reference_Marker
-- Sloc points to Sloc of original variable reference
- -- Target (Node1-Sem)
- -- Is_Elaboration_Checks_OK_Node (Flag1-Sem)
- -- Is_SPARK_Mode_On_Node (Flag2-Sem)
- -- Is_Elaboration_Warnings_OK_Node (Flag3-Sem)
- -- Is_Read (Flag4-Sem)
- -- Is_Write (Flag5-Sem)
+ -- Target
+ -- Is_Elaboration_Checks_OK_Node
+ -- Is_SPARK_Mode_On_Node
+ -- Is_Elaboration_Warnings_OK_Node
+ -- Is_Read
+ -- Is_Write
-----------
-- Empty --
@@ -8547,7 +8526,7 @@ package Sinfo is
-- some other situations to indicate an uninitialized value.
-- N_Empty
- -- Chars (Name1) is set to No_Name
+ -- Chars is set to No_Name
-----------
-- Error --
@@ -8558,5307 +8537,7 @@ package Sinfo is
-- error recovery (Error_Posted is also set in the Error node).
-- N_Error
- -- Chars (Name1) is set to Error_Name
- -- Etype (Node5-Sem)
-
- --------------------------
- -- Node Type Definition --
- --------------------------
-
- -- The following is the definition of the Node_Kind type. As previously
- -- discussed, this is separated off to allow rearrangement of the order to
- -- facilitate definition of subtype ranges. The comments show the subtype
- -- classes which apply to each set of node kinds. The first entry in the
- -- comment characterizes the following list of nodes.
-
- type Node_Kind is (
- N_Unused_At_Start,
-
- -- N_Representation_Clause
-
- N_At_Clause,
- N_Component_Clause,
- N_Enumeration_Representation_Clause,
- N_Mod_Clause,
- N_Record_Representation_Clause,
-
- -- N_Representation_Clause, N_Has_Chars
-
- N_Attribute_Definition_Clause,
-
- -- N_Has_Chars
-
- N_Empty,
- N_Pragma_Argument_Association,
-
- -- N_Has_Etype, N_Has_Chars
-
- -- Note: of course N_Error does not really have Etype or Chars fields,
- -- and any attempt to access these fields in N_Error will cause an
- -- error, but historically this always has been positioned so that an
- -- "in N_Has_Chars" or "in N_Has_Etype" test yields true for N_Error.
- -- Most likely this makes coding easier somewhere but still seems
- -- undesirable. To be investigated some time ???
-
- N_Error,
-
- -- N_Entity, N_Has_Etype, N_Has_Chars
-
- N_Defining_Character_Literal,
- N_Defining_Identifier,
- N_Defining_Operator_Symbol,
-
- -- N_Subexpr, N_Has_Etype, N_Has_Chars, N_Has_Entity
-
- N_Expanded_Name,
-
- -- N_Direct_Name, N_Subexpr, N_Has_Etype,
- -- N_Has_Chars, N_Has_Entity
-
- N_Identifier,
- N_Operator_Symbol,
-
- -- N_Direct_Name, N_Subexpr, N_Has_Etype,
- -- N_Has_Chars, N_Has_Entity
-
- N_Character_Literal,
-
- -- N_Binary_Op, N_Op, N_Subexpr,
- -- N_Has_Etype, N_Has_Chars, N_Has_Entity
-
- N_Op_Add,
- N_Op_Concat,
- N_Op_Expon,
- N_Op_Subtract,
-
- -- N_Binary_Op, N_Op, N_Subexpr,
- -- N_Has_Etype, N_Has_Chars, N_Has_Entity, N_Multiplying_Operator
-
- N_Op_Divide,
- N_Op_Mod,
- N_Op_Multiply,
- N_Op_Rem,
-
- -- N_Binary_Op, N_Op, N_Subexpr, N_Has_Etype
- -- N_Has_Entity, N_Has_Chars, N_Op_Boolean
-
- N_Op_And,
-
- -- N_Binary_Op, N_Op, N_Subexpr, N_Has_Etype
- -- N_Has_Entity, N_Has_Chars, N_Op_Boolean, N_Op_Compare
-
- N_Op_Eq,
- N_Op_Ge,
- N_Op_Gt,
- N_Op_Le,
- N_Op_Lt,
- N_Op_Ne,
-
- -- N_Binary_Op, N_Op, N_Subexpr, N_Has_Etype
- -- N_Has_Entity, N_Has_Chars, N_Op_Boolean
-
- N_Op_Or,
- N_Op_Xor,
-
- -- N_Binary_Op, N_Op, N_Subexpr, N_Has_Etype,
- -- N_Op_Shift, N_Has_Chars, N_Has_Entity
-
- N_Op_Rotate_Left,
- N_Op_Rotate_Right,
- N_Op_Shift_Left,
- N_Op_Shift_Right,
- N_Op_Shift_Right_Arithmetic,
-
- -- N_Unary_Op, N_Op, N_Subexpr, N_Has_Etype,
- -- N_Has_Chars, N_Has_Entity
-
- N_Op_Abs,
- N_Op_Minus,
- N_Op_Not,
- N_Op_Plus,
-
- -- N_Subexpr, N_Has_Etype, N_Has_Entity
-
- N_Attribute_Reference,
-
- -- N_Subexpr, N_Has_Etype, N_Membership_Test
-
- N_In,
- N_Not_In,
-
- -- N_Subexpr, N_Has_Etype, N_Short_Circuit
-
- N_And_Then,
- N_Or_Else,
-
- -- N_Subexpr, N_Has_Etype, N_Subprogram_Call
-
- N_Function_Call,
- N_Procedure_Call_Statement,
-
- -- N_Subexpr, N_Has_Etype, N_Raise_xxx_Error
-
- N_Raise_Constraint_Error,
- N_Raise_Program_Error,
- N_Raise_Storage_Error,
-
- -- N_Subexpr, N_Has_Etype, N_Numeric_Or_String_Literal
-
- N_Integer_Literal,
- N_Real_Literal,
- N_String_Literal,
-
- -- N_Subexpr, N_Has_Etype
-
- N_Explicit_Dereference,
- N_Expression_With_Actions,
- N_If_Expression,
- N_Indexed_Component,
- N_Null,
- N_Qualified_Expression,
- N_Quantified_Expression,
- N_Aggregate,
- N_Allocator,
- N_Case_Expression,
- N_Delta_Aggregate,
- N_Extension_Aggregate,
- N_Raise_Expression,
- N_Range,
- N_Reference,
- N_Selected_Component,
- N_Slice,
- N_Target_Name,
- N_Type_Conversion,
- N_Unchecked_Expression,
- N_Unchecked_Type_Conversion,
-
- -- N_Has_Etype
-
- N_Subtype_Indication,
-
- -- N_Declaration
-
- N_Component_Declaration,
- N_Entry_Declaration,
- N_Expression_Function,
- N_Formal_Object_Declaration,
- N_Formal_Type_Declaration,
- N_Full_Type_Declaration,
- N_Incomplete_Type_Declaration,
- N_Iterator_Specification,
- N_Loop_Parameter_Specification,
- N_Object_Declaration,
- N_Protected_Type_Declaration,
- N_Private_Extension_Declaration,
- N_Private_Type_Declaration,
- N_Subtype_Declaration,
-
- -- N_Subprogram_Specification, N_Declaration
-
- N_Function_Specification,
- N_Procedure_Specification,
-
- -- N_Access_To_Subprogram_Definition
-
- N_Access_Function_Definition,
- N_Access_Procedure_Definition,
-
- -- N_Later_Decl_Item
-
- N_Task_Type_Declaration,
-
- -- N_Body_Stub, N_Later_Decl_Item
-
- N_Package_Body_Stub,
- N_Protected_Body_Stub,
- N_Subprogram_Body_Stub,
- N_Task_Body_Stub,
-
- -- N_Generic_Instantiation, N_Later_Decl_Item
- -- N_Subprogram_Instantiation
-
- N_Function_Instantiation,
- N_Procedure_Instantiation,
-
- -- N_Generic_Instantiation, N_Later_Decl_Item
-
- N_Package_Instantiation,
-
- -- N_Unit_Body, N_Later_Decl_Item, N_Proper_Body
-
- N_Package_Body,
- N_Subprogram_Body,
-
- -- N_Later_Decl_Item, N_Proper_Body
-
- N_Protected_Body,
- N_Task_Body,
-
- -- N_Later_Decl_Item
-
- N_Implicit_Label_Declaration,
- N_Package_Declaration,
- N_Single_Task_Declaration,
- N_Subprogram_Declaration,
- N_Use_Package_Clause,
-
- -- N_Generic_Declaration, N_Later_Decl_Item
-
- N_Generic_Package_Declaration,
- N_Generic_Subprogram_Declaration,
-
- -- N_Array_Type_Definition
-
- N_Constrained_Array_Definition,
- N_Unconstrained_Array_Definition,
-
- -- N_Renaming_Declaration
-
- N_Exception_Renaming_Declaration,
- N_Object_Renaming_Declaration,
- N_Package_Renaming_Declaration,
- N_Subprogram_Renaming_Declaration,
-
- -- N_Generic_Renaming_Declaration, N_Renaming_Declaration
-
- N_Generic_Function_Renaming_Declaration,
- N_Generic_Package_Renaming_Declaration,
- N_Generic_Procedure_Renaming_Declaration,
-
- -- N_Statement_Other_Than_Procedure_Call
-
- N_Abort_Statement,
- N_Accept_Statement,
- N_Assignment_Statement,
- N_Asynchronous_Select,
- N_Block_Statement,
- N_Case_Statement,
- N_Code_Statement,
- N_Compound_Statement,
- N_Conditional_Entry_Call,
-
- -- N_Statement_Other_Than_Procedure_Call, N_Delay_Statement
-
- N_Delay_Relative_Statement,
- N_Delay_Until_Statement,
-
- -- N_Statement_Other_Than_Procedure_Call
-
- N_Entry_Call_Statement,
- N_Free_Statement,
- N_Goto_Statement,
- N_Loop_Statement,
- N_Null_Statement,
- N_Raise_Statement,
- N_Requeue_Statement,
- N_Simple_Return_Statement,
- N_Extended_Return_Statement,
- N_Selective_Accept,
- N_Timed_Entry_Call,
-
- -- N_Statement_Other_Than_Procedure_Call, N_Has_Condition
-
- N_Exit_Statement,
- N_If_Statement,
-
- -- N_Has_Condition
-
- N_Accept_Alternative,
- N_Delay_Alternative,
- N_Elsif_Part,
- N_Entry_Body_Formal_Part,
- N_Iteration_Scheme,
- N_Terminate_Alternative,
-
- -- N_Formal_Subprogram_Declaration
-
- N_Formal_Abstract_Subprogram_Declaration,
- N_Formal_Concrete_Subprogram_Declaration,
-
- -- N_Push_xxx_Label, N_Push_Pop_xxx_Label
-
- N_Push_Constraint_Error_Label,
- N_Push_Program_Error_Label,
- N_Push_Storage_Error_Label,
-
- -- N_Pop_xxx_Label, N_Push_Pop_xxx_Label
-
- N_Pop_Constraint_Error_Label,
- N_Pop_Program_Error_Label,
- N_Pop_Storage_Error_Label,
-
- -- SCIL nodes
-
- N_SCIL_Dispatch_Table_Tag_Init,
- N_SCIL_Dispatching_Call,
- N_SCIL_Membership_Test,
-
- -- Other nodes (not part of any subtype class)
-
- N_Abortable_Part,
- N_Abstract_Subprogram_Declaration,
- N_Access_Definition,
- N_Access_To_Object_Definition,
- N_Aspect_Specification,
- N_Call_Marker,
- N_Case_Expression_Alternative,
- N_Case_Statement_Alternative,
- N_Compilation_Unit,
- N_Compilation_Unit_Aux,
- N_Component_Association,
- N_Component_Definition,
- N_Component_List,
- N_Contract,
- N_Derived_Type_Definition,
- N_Decimal_Fixed_Point_Definition,
- N_Defining_Program_Unit_Name,
- N_Delta_Constraint,
- N_Designator,
- N_Digits_Constraint,
- N_Discriminant_Association,
- N_Discriminant_Specification,
- N_Enumeration_Type_Definition,
- N_Entry_Body,
- N_Entry_Call_Alternative,
- N_Entry_Index_Specification,
- N_Exception_Declaration,
- N_Exception_Handler,
- N_Floating_Point_Definition,
- N_Formal_Decimal_Fixed_Point_Definition,
- N_Formal_Derived_Type_Definition,
- N_Formal_Discrete_Type_Definition,
- N_Formal_Floating_Point_Definition,
- N_Formal_Modular_Type_Definition,
- N_Formal_Ordinary_Fixed_Point_Definition,
- N_Formal_Package_Declaration,
- N_Formal_Private_Type_Definition,
- N_Formal_Incomplete_Type_Definition,
- N_Formal_Signed_Integer_Type_Definition,
- N_Freeze_Entity,
- N_Freeze_Generic_Entity,
- N_Generic_Association,
- 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,
- N_Number_Declaration,
- N_Ordinary_Fixed_Point_Definition,
- N_Others_Choice,
- N_Package_Specification,
- N_Parameter_Association,
- N_Parameter_Specification,
- N_Pragma,
- N_Protected_Definition,
- N_Range_Constraint,
- N_Real_Range_Specification,
- N_Record_Definition,
- N_Signed_Integer_Type_Definition,
- N_Single_Protected_Declaration,
- N_Subunit,
- N_Task_Definition,
- N_Triggering_Alternative,
- N_Use_Type_Clause,
- N_Validate_Unchecked_Conversion,
- N_Variable_Reference_Marker,
- N_Variant,
- N_Variant_Part,
- N_With_Clause,
- N_Unused_At_End);
-
- for Node_Kind'Size use 8;
- -- The data structures in Atree assume this
-
- ----------------------------
- -- Node Class Definitions --
- ----------------------------
-
- subtype N_Access_To_Subprogram_Definition is Node_Kind range
- N_Access_Function_Definition ..
- N_Access_Procedure_Definition;
-
- subtype N_Array_Type_Definition is Node_Kind range
- N_Constrained_Array_Definition ..
- N_Unconstrained_Array_Definition;
-
- subtype N_Binary_Op is Node_Kind range
- N_Op_Add ..
- N_Op_Shift_Right_Arithmetic;
-
- subtype N_Body_Stub is Node_Kind range
- N_Package_Body_Stub ..
- N_Task_Body_Stub;
-
- subtype N_Declaration is Node_Kind range
- N_Component_Declaration ..
- N_Procedure_Specification;
- -- Note: this includes all constructs normally thought of as declarations
- -- except those which are separately grouped as later declarations.
-
- subtype N_Delay_Statement is Node_Kind range
- N_Delay_Relative_Statement ..
- N_Delay_Until_Statement;
-
- subtype N_Direct_Name is Node_Kind range
- N_Identifier ..
- N_Character_Literal;
-
- subtype N_Entity is Node_Kind range
- N_Defining_Character_Literal ..
- N_Defining_Operator_Symbol;
-
- subtype N_Formal_Subprogram_Declaration is Node_Kind range
- N_Formal_Abstract_Subprogram_Declaration ..
- N_Formal_Concrete_Subprogram_Declaration;
-
- subtype N_Generic_Declaration is Node_Kind range
- N_Generic_Package_Declaration ..
- N_Generic_Subprogram_Declaration;
-
- subtype N_Generic_Instantiation is Node_Kind range
- N_Function_Instantiation ..
- N_Package_Instantiation;
-
- subtype N_Generic_Renaming_Declaration is Node_Kind range
- N_Generic_Function_Renaming_Declaration ..
- N_Generic_Procedure_Renaming_Declaration;
-
- subtype N_Has_Chars is Node_Kind range
- N_Attribute_Definition_Clause ..
- N_Op_Plus;
-
- subtype N_Has_Entity is Node_Kind range
- N_Expanded_Name ..
- N_Attribute_Reference;
- -- Nodes that have Entity fields
- -- Warning: DOES NOT INCLUDE N_Freeze_Entity, N_Freeze_Generic_Entity,
- -- N_Aspect_Specification, or N_Attribute_Definition_Clause.
-
- subtype N_Has_Etype is Node_Kind range
- N_Error ..
- N_Subtype_Indication;
-
- subtype N_Multiplying_Operator is Node_Kind range
- N_Op_Divide ..
- N_Op_Rem;
-
- subtype N_Later_Decl_Item is Node_Kind range
- N_Task_Type_Declaration ..
- N_Generic_Subprogram_Declaration;
- -- Note: this is Ada 83 relevant only (see Ada 83 RM 3.9 (2)) and includes
- -- only those items which can appear as later declarative items. This also
- -- includes N_Implicit_Label_Declaration which is not specifically in the
- -- grammar but may appear as a valid later declarative items. It does NOT
- -- include N_Pragma which can also appear among later declarative items.
- -- It does however include N_Protected_Body, which is a bit peculiar, but
- -- harmless since this cannot appear in Ada 83 mode anyway.
-
- subtype N_Membership_Test is Node_Kind range
- N_In ..
- N_Not_In;
-
- subtype N_Numeric_Or_String_Literal is Node_Kind range
- N_Integer_Literal ..
- N_String_Literal;
-
- subtype N_Op is Node_Kind range
- N_Op_Add ..
- N_Op_Plus;
-
- subtype N_Op_Boolean is Node_Kind range
- N_Op_And ..
- N_Op_Xor;
- -- Binary operators which take operands of a boolean type, and yield
- -- a result of a boolean type.
-
- subtype N_Op_Compare is Node_Kind range
- N_Op_Eq ..
- N_Op_Ne;
-
- subtype N_Op_Shift is Node_Kind range
- N_Op_Rotate_Left ..
- N_Op_Shift_Right_Arithmetic;
-
- subtype N_Proper_Body is Node_Kind range
- N_Package_Body ..
- N_Task_Body;
-
- subtype N_Push_xxx_Label is Node_Kind range
- N_Push_Constraint_Error_Label ..
- N_Push_Storage_Error_Label;
-
- subtype N_Pop_xxx_Label is Node_Kind range
- N_Pop_Constraint_Error_Label ..
- N_Pop_Storage_Error_Label;
-
- subtype N_Push_Pop_xxx_Label is Node_Kind range
- N_Push_Constraint_Error_Label ..
- N_Pop_Storage_Error_Label;
-
- subtype N_Raise_xxx_Error is Node_Kind range
- N_Raise_Constraint_Error ..
- N_Raise_Storage_Error;
-
- subtype N_Renaming_Declaration is Node_Kind range
- N_Exception_Renaming_Declaration ..
- N_Generic_Procedure_Renaming_Declaration;
-
- subtype N_Representation_Clause is Node_Kind range
- N_At_Clause ..
- N_Attribute_Definition_Clause;
-
- subtype N_Short_Circuit is Node_Kind range
- N_And_Then ..
- N_Or_Else;
-
- subtype N_SCIL_Node is Node_Kind range
- N_SCIL_Dispatch_Table_Tag_Init ..
- N_SCIL_Membership_Test;
-
- subtype N_Statement_Other_Than_Procedure_Call is Node_Kind range
- N_Abort_Statement ..
- N_If_Statement;
- -- Note that this includes all statement types except for the cases of the
- -- N_Procedure_Call_Statement which is considered to be a subexpression
- -- (since overloading is possible, so it needs to go through the normal
- -- overloading resolution for expressions).
-
- subtype N_Subprogram_Call is Node_Kind range
- N_Function_Call ..
- N_Procedure_Call_Statement;
-
- subtype N_Subprogram_Instantiation is Node_Kind range
- N_Function_Instantiation ..
- N_Procedure_Instantiation;
-
- subtype N_Has_Condition is Node_Kind range
- N_Exit_Statement ..
- N_Terminate_Alternative;
- -- Nodes with condition fields (does not include N_Raise_xxx_Error)
-
- subtype N_Subexpr is Node_Kind range
- N_Expanded_Name ..
- N_Unchecked_Type_Conversion;
- -- Nodes with expression fields
-
- subtype N_Subprogram_Specification is Node_Kind range
- N_Function_Specification ..
- N_Procedure_Specification;
-
- subtype N_Unary_Op is Node_Kind range
- N_Op_Abs ..
- N_Op_Plus;
-
- subtype N_Unit_Body is Node_Kind range
- N_Package_Body ..
- N_Subprogram_Body;
-
- ---------------------------
- -- Node Access Functions --
- ---------------------------
-
- -- The following functions return the contents of the indicated field of
- -- the node referenced by the argument, which is a Node_Id. They provide
- -- logical access to fields in the node which could be accessed using the
- -- Atree.Unchecked_Access package, but the idea is always to use these
- -- higher level routines which preserve strong typing. In debug mode,
- -- these routines check that they are being applied to an appropriate
- -- node, as well as checking that the node is in range.
-
- function Abort_Present
- (N : Node_Id) return Boolean; -- Flag15
-
- function Abortable_Part
- (N : Node_Id) return Node_Id; -- Node2
-
- function Abstract_Present
- (N : Node_Id) return Boolean; -- Flag4
-
- function Accept_Handler_Records
- (N : Node_Id) return List_Id; -- List5
-
- function Accept_Statement
- (N : Node_Id) return Node_Id; -- Node2
-
- function Access_Definition
- (N : Node_Id) return Node_Id; -- Node3
-
- function Access_To_Subprogram_Definition
- (N : Node_Id) return Node_Id; -- Node3
-
- function Access_Types_To_Process
- (N : Node_Id) return Elist_Id; -- Elist2
-
- function Actions
- (N : Node_Id) return List_Id; -- List1
-
- function Activation_Chain_Entity
- (N : Node_Id) return Node_Id; -- Node3
-
- function Acts_As_Spec
- (N : Node_Id) return Boolean; -- Flag4
-
- function Actual_Designated_Subtype
- (N : Node_Id) return Node_Id; -- Node4
-
- function Address_Warning_Posted
- (N : Node_Id) return Boolean; -- Flag18
-
- function Aggregate_Bounds
- (N : Node_Id) return Node_Id; -- Node3
-
- function Aliased_Present
- (N : Node_Id) return Boolean; -- Flag4
-
- function Alloc_For_BIP_Return
- (N : Node_Id) return Boolean; -- Flag1
-
- function All_Others
- (N : Node_Id) return Boolean; -- Flag11
-
- function All_Present
- (N : Node_Id) return Boolean; -- Flag15
-
- function Alternatives
- (N : Node_Id) return List_Id; -- List4
-
- function Ancestor_Part
- (N : Node_Id) return Node_Id; -- Node3
-
- function Atomic_Sync_Required
- (N : Node_Id) return Boolean; -- Flag14
-
- function Array_Aggregate
- (N : Node_Id) return Node_Id; -- Node3
-
- function Aspect_On_Partial_View
- (N : Node_Id) return Boolean; -- Flag18
-
- function Aspect_Rep_Item
- (N : Node_Id) return Node_Id; -- Node2
-
- function Assignment_OK
- (N : Node_Id) return Boolean; -- Flag15
-
- function Associated_Node
- (N : Node_Id) return Node_Id; -- Node4
-
- function At_End_Proc
- (N : Node_Id) return Node_Id; -- Node1
-
- function Attribute_Name
- (N : Node_Id) return Name_Id; -- Name2
-
- function Aux_Decls_Node
- (N : Node_Id) return Node_Id; -- Node5
-
- function Backwards_OK
- (N : Node_Id) return Boolean; -- Flag6
-
- function Bad_Is_Detected
- (N : Node_Id) return Boolean; -- Flag15
-
- function By_Ref
- (N : Node_Id) return Boolean; -- Flag5
-
- function Body_Required
- (N : Node_Id) return Boolean; -- Flag13
-
- function Body_To_Inline
- (N : Node_Id) return Node_Id; -- Node3
-
- function Box_Present
- (N : Node_Id) return Boolean; -- Flag15
-
- function Char_Literal_Value
- (N : Node_Id) return Uint; -- Uint2
-
- function Chars
- (N : Node_Id) return Name_Id; -- Name1
-
- function Check_Address_Alignment
- (N : Node_Id) return Boolean; -- Flag11
-
- function Choice_Parameter
- (N : Node_Id) return Node_Id; -- Node2
-
- function Choices
- (N : Node_Id) return List_Id; -- List1
-
- function Class_Present
- (N : Node_Id) return Boolean; -- Flag6
-
- function Classifications
- (N : Node_Id) return Node_Id; -- Node3
-
- function Cleanup_Actions
- (N : Node_Id) return List_Id; -- List5
-
- function Comes_From_Extended_Return_Statement
- (N : Node_Id) return Boolean; -- Flag18
-
- function Compile_Time_Known_Aggregate
- (N : Node_Id) return Boolean; -- Flag18
-
- function Component_Associations
- (N : Node_Id) return List_Id; -- List2
-
- function Component_Clauses
- (N : Node_Id) return List_Id; -- List3
-
- function Component_Definition
- (N : Node_Id) return Node_Id; -- Node4
-
- function Component_Items
- (N : Node_Id) return List_Id; -- List3
-
- function Component_List
- (N : Node_Id) return Node_Id; -- Node1
-
- function Component_Name
- (N : Node_Id) return Node_Id; -- Node1
-
- function Componentwise_Assignment
- (N : Node_Id) return Boolean; -- Flag14
-
- function Condition
- (N : Node_Id) return Node_Id; -- Node1
-
- function Condition_Actions
- (N : Node_Id) return List_Id; -- List3
-
- function Config_Pragmas
- (N : Node_Id) return List_Id; -- List4
-
- function Constant_Present
- (N : Node_Id) return Boolean; -- Flag17
-
- function Constraint
- (N : Node_Id) return Node_Id; -- Node3
-
- function Constraints
- (N : Node_Id) return List_Id; -- List1
-
- function Context_Installed
- (N : Node_Id) return Boolean; -- Flag13
-
- function Context_Pending
- (N : Node_Id) return Boolean; -- Flag16
-
- function Context_Items
- (N : Node_Id) return List_Id; -- List1
-
- function Contract_Test_Cases
- (N : Node_Id) return Node_Id; -- Node2
-
- function Controlling_Argument
- (N : Node_Id) return Node_Id; -- Node1
-
- function Conversion_OK
- (N : Node_Id) return Boolean; -- Flag14
-
- function Convert_To_Return_False
- (N : Node_Id) return Boolean; -- Flag13
-
- function Corresponding_Aspect
- (N : Node_Id) return Node_Id; -- Node3
-
- function Corresponding_Body
- (N : Node_Id) return Node_Id; -- Node5
-
- function Corresponding_Formal_Spec
- (N : Node_Id) return Node_Id; -- Node3
-
- function Corresponding_Generic_Association
- (N : Node_Id) return Node_Id; -- Node5
-
- function Corresponding_Integer_Value
- (N : Node_Id) return Uint; -- Uint4
-
- function Corresponding_Spec
- (N : Node_Id) return Entity_Id; -- Node5
-
- function Corresponding_Spec_Of_Stub
- (N : Node_Id) return Node_Id; -- Node2
-
- function Corresponding_Stub
- (N : Node_Id) return Node_Id; -- Node3
-
- function Dcheck_Function
- (N : Node_Id) return Entity_Id; -- Node5
-
- function Declarations
- (N : Node_Id) return List_Id; -- List2
-
- function Default_Expression
- (N : Node_Id) return Node_Id; -- Node5
-
- function Default_Storage_Pool
- (N : Node_Id) return Node_Id; -- Node3
-
- function Default_Name
- (N : Node_Id) return Node_Id; -- Node2
-
- function Defining_Identifier
- (N : Node_Id) return Entity_Id; -- Node1
-
- function Defining_Unit_Name
- (N : Node_Id) return Node_Id; -- Node1
-
- function Delay_Alternative
- (N : Node_Id) return Node_Id; -- Node4
-
- function Delay_Statement
- (N : Node_Id) return Node_Id; -- Node2
-
- function Delta_Expression
- (N : Node_Id) return Node_Id; -- Node3
-
- function Digits_Expression
- (N : Node_Id) return Node_Id; -- Node2
-
- function Discr_Check_Funcs_Built
- (N : Node_Id) return Boolean; -- Flag11
-
- function Discrete_Choices
- (N : Node_Id) return List_Id; -- List4
-
- function Discrete_Range
- (N : Node_Id) return Node_Id; -- Node4
-
- function Discrete_Subtype_Definition
- (N : Node_Id) return Node_Id; -- Node4
-
- function Discrete_Subtype_Definitions
- (N : Node_Id) return List_Id; -- List2
-
- function Discriminant_Specifications
- (N : Node_Id) return List_Id; -- List4
-
- function Discriminant_Type
- (N : Node_Id) return Node_Id; -- Node5
-
- function Do_Accessibility_Check
- (N : Node_Id) return Boolean; -- Flag13
-
- function Do_Discriminant_Check
- (N : Node_Id) return Boolean; -- Flag3
-
- function Do_Division_Check
- (N : Node_Id) return Boolean; -- Flag13
-
- function Do_Length_Check
- (N : Node_Id) return Boolean; -- Flag4
-
- function Do_Overflow_Check
- (N : Node_Id) return Boolean; -- Flag17
-
- function Do_Range_Check
- (N : Node_Id) return Boolean; -- Flag9
-
- function Do_Storage_Check
- (N : Node_Id) return Boolean; -- Flag17
-
- function Do_Tag_Check
- (N : Node_Id) return Boolean; -- Flag13
-
- function Elaborate_All_Desirable
- (N : Node_Id) return Boolean; -- Flag9
-
- function Elaborate_All_Present
- (N : Node_Id) return Boolean; -- Flag14
-
- function Elaborate_Desirable
- (N : Node_Id) return Boolean; -- Flag11
-
- function Elaborate_Present
- (N : Node_Id) return Boolean; -- Flag4
-
- function Else_Actions
- (N : Node_Id) return List_Id; -- List3
-
- function Else_Statements
- (N : Node_Id) return List_Id; -- List4
-
- function Elsif_Parts
- (N : Node_Id) return List_Id; -- List3
-
- function Enclosing_Variant
- (N : Node_Id) return Node_Id; -- Node2
-
- function End_Label
- (N : Node_Id) return Node_Id; -- Node4
-
- function End_Span
- (N : Node_Id) return Uint; -- Uint5
-
- function Entity
- (N : Node_Id) return Node_Id; -- Node4
-
- function Entity_Or_Associated_Node
- (N : Node_Id) return Node_Id; -- Node4
-
- function Entry_Body_Formal_Part
- (N : Node_Id) return Node_Id; -- Node5
-
- function Entry_Call_Alternative
- (N : Node_Id) return Node_Id; -- Node1
-
- function Entry_Call_Statement
- (N : Node_Id) return Node_Id; -- Node1
-
- function Entry_Direct_Name
- (N : Node_Id) return Node_Id; -- Node1
-
- function Entry_Index
- (N : Node_Id) return Node_Id; -- Node5
-
- function Entry_Index_Specification
- (N : Node_Id) return Node_Id; -- Node4
-
- function Etype
- (N : Node_Id) return Node_Id; -- Node5
-
- function Exception_Choices
- (N : Node_Id) return List_Id; -- List4
-
- function Exception_Handlers
- (N : Node_Id) return List_Id; -- List5
-
- function Exception_Junk
- (N : Node_Id) return Boolean; -- Flag8
-
- function Exception_Label
- (N : Node_Id) return Node_Id; -- Node5
-
- function Explicit_Actual_Parameter
- (N : Node_Id) return Node_Id; -- Node3
-
- function Expansion_Delayed
- (N : Node_Id) return Boolean; -- Flag11
-
- function Explicit_Generic_Actual_Parameter
- (N : Node_Id) return Node_Id; -- Node1
-
- function Expression
- (N : Node_Id) return Node_Id; -- Node3
-
- function Expression_Copy
- (N : Node_Id) return Node_Id; -- Node2
-
- function Expressions
- (N : Node_Id) return List_Id; -- List1
-
- function First_Bit
- (N : Node_Id) return Node_Id; -- Node3
-
- function First_Inlined_Subprogram
- (N : Node_Id) return Entity_Id; -- Node3
-
- function First_Name
- (N : Node_Id) return Boolean; -- Flag5
-
- function First_Named_Actual
- (N : Node_Id) return Node_Id; -- Node4
-
- function First_Real_Statement
- (N : Node_Id) return Node_Id; -- Node2
-
- function First_Subtype_Link
- (N : Node_Id) return Entity_Id; -- Node5
-
- function Float_Truncate
- (N : Node_Id) return Boolean; -- Flag11
-
- function Formal_Type_Definition
- (N : Node_Id) return Node_Id; -- Node3
-
- function Forwards_OK
- (N : Node_Id) return Boolean; -- Flag5
-
- function From_Aspect_Specification
- (N : Node_Id) return Boolean; -- Flag13
-
- function From_At_End
- (N : Node_Id) return Boolean; -- Flag4
-
- function From_At_Mod
- (N : Node_Id) return Boolean; -- Flag4
-
- function From_Conditional_Expression
- (N : Node_Id) return Boolean; -- Flag1
-
- function From_Default
- (N : Node_Id) return Boolean; -- Flag6
-
- function Generalized_Indexing
- (N : Node_Id) return Node_Id; -- Node4
-
- function Generic_Associations
- (N : Node_Id) return List_Id; -- List3
-
- function Generic_Formal_Declarations
- (N : Node_Id) return List_Id; -- List2
-
- function Generic_Parent
- (N : Node_Id) return Node_Id; -- Node5
-
- function Generic_Parent_Type
- (N : Node_Id) return Node_Id; -- Node4
-
- function Handled_Statement_Sequence
- (N : Node_Id) return Node_Id; -- Node4
-
- function Handler_List_Entry
- (N : Node_Id) return Node_Id; -- Node2
-
- function Has_Created_Identifier
- (N : Node_Id) return Boolean; -- Flag15
-
- function Has_Dereference_Action
- (N : Node_Id) return Boolean; -- Flag13
-
- function Has_Dynamic_Length_Check
- (N : Node_Id) return Boolean; -- Flag10
-
- function Has_Init_Expression
- (N : Node_Id) return Boolean; -- Flag14
-
- function Has_Local_Raise
- (N : Node_Id) return Boolean; -- Flag8
-
- function Has_No_Elaboration_Code
- (N : Node_Id) return Boolean; -- Flag17
-
- function Has_Pragma_Suppress_All
- (N : Node_Id) return Boolean; -- Flag14
-
- function Has_Private_View
- (N : Node_Id) return Boolean; -- Flag11
-
- function Has_Relative_Deadline_Pragma
- (N : Node_Id) return Boolean; -- Flag9
-
- function Has_Self_Reference
- (N : Node_Id) return Boolean; -- Flag13
-
- function Has_SP_Choice
- (N : Node_Id) return Boolean; -- Flag15
-
- function Has_Storage_Size_Pragma
- (N : Node_Id) return Boolean; -- Flag5
-
- function Has_Target_Names
- (N : Node_Id) return Boolean; -- Flag8
-
- function Has_Wide_Character
- (N : Node_Id) return Boolean; -- Flag11
-
- function Has_Wide_Wide_Character
- (N : Node_Id) return Boolean; -- Flag13
-
- function Header_Size_Added
- (N : Node_Id) return Boolean; -- Flag11
-
- function Hidden_By_Use_Clause
- (N : Node_Id) return Elist_Id; -- Elist5
-
- function High_Bound
- (N : Node_Id) return Node_Id; -- Node2
-
- function Identifier
- (N : Node_Id) return Node_Id; -- Node1
-
- function Interface_List
- (N : Node_Id) return List_Id; -- List2
-
- function Interface_Present
- (N : Node_Id) return Boolean; -- Flag16
-
- function Implicit_With
- (N : Node_Id) return Boolean; -- Flag16
-
- function Import_Interface_Present
- (N : Node_Id) return Boolean; -- Flag16
-
- function In_Present
- (N : Node_Id) return Boolean; -- Flag15
-
- function Includes_Infinities
- (N : Node_Id) return Boolean; -- Flag11
-
- function Incomplete_View
- (N : Node_Id) return Node_Id; -- Node2
-
- function Inherited_Discriminant
- (N : Node_Id) return Boolean; -- Flag13
-
- function Instance_Spec
- (N : Node_Id) return Node_Id; -- Node5
-
- function Intval
- (N : Node_Id) return Uint; -- Uint3
-
- function Is_Abort_Block
- (N : Node_Id) return Boolean; -- Flag4
-
- function Is_Accessibility_Actual
- (N : Node_Id) return Boolean; -- Flag13
-
- function Is_Analyzed_Pragma
- (N : Node_Id) return Boolean; -- Flag5
-
- function Is_Asynchronous_Call_Block
- (N : Node_Id) return Boolean; -- Flag7
-
- function Is_Boolean_Aspect
- (N : Node_Id) return Boolean; -- Flag16
-
- function Is_Checked
- (N : Node_Id) return Boolean; -- Flag11
-
- function Is_Checked_Ghost_Pragma
- (N : Node_Id) return Boolean; -- Flag3
-
- function Is_Component_Left_Opnd
- (N : Node_Id) return Boolean; -- Flag13
-
- function Is_Component_Right_Opnd
- (N : Node_Id) return Boolean; -- Flag14
-
- function Is_Controlling_Actual
- (N : Node_Id) return Boolean; -- Flag16
-
- function Is_Declaration_Level_Node
- (N : Node_Id) return Boolean; -- Flag5
-
- function Is_Delayed_Aspect
- (N : Node_Id) return Boolean; -- Flag14
-
- function Is_Disabled
- (N : Node_Id) return Boolean; -- Flag15
-
- function Is_Dispatching_Call
- (N : Node_Id) return Boolean; -- Flag6
-
- function Is_Dynamic_Coextension
- (N : Node_Id) return Boolean; -- Flag18
-
- function Is_Effective_Use_Clause
- (N : Node_Id) return Boolean; -- Flag1
-
- function Is_Elaboration_Checks_OK_Node
- (N : Node_Id) return Boolean; -- Flag1
-
- function Is_Elaboration_Code
- (N : Node_Id) return Boolean; -- Flag9
-
- function Is_Elaboration_Warnings_OK_Node
- (N : Node_Id) return Boolean; -- Flag3
-
- function Is_Elsif
- (N : Node_Id) return Boolean; -- Flag13
-
- function Is_Entry_Barrier_Function
- (N : Node_Id) return Boolean; -- Flag8
-
- function Is_Expanded_Build_In_Place_Call
- (N : Node_Id) return Boolean; -- Flag11
-
- function Is_Expanded_Contract
- (N : Node_Id) return Boolean; -- Flag1
-
- function Is_Finalization_Wrapper
- (N : Node_Id) return Boolean; -- Flag9
-
- function Is_Folded_In_Parser
- (N : Node_Id) return Boolean; -- Flag4
-
- function Is_Generic_Contract_Pragma
- (N : Node_Id) return Boolean; -- Flag2
-
- function Is_Homogeneous_Aggregate
- (N : Node_Id) return Boolean; -- Flag14
-
- function Is_Ignored
- (N : Node_Id) return Boolean; -- Flag9
-
- function Is_Ignored_Ghost_Pragma
- (N : Node_Id) return Boolean; -- Flag8
-
- function Is_In_Discriminant_Check
- (N : Node_Id) return Boolean; -- Flag11
-
- function Is_Inherited_Pragma
- (N : Node_Id) return Boolean; -- Flag4
-
- function Is_Initialization_Block
- (N : Node_Id) return Boolean; -- Flag1
-
- function Is_Known_Guaranteed_ABE
- (N : Node_Id) return Boolean; -- Flag18
-
- function Is_Machine_Number
- (N : Node_Id) return Boolean; -- Flag11
-
- function Is_Null_Loop
- (N : Node_Id) return Boolean; -- Flag16
-
- 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
-
- function Is_Protected_Subprogram_Body
- (N : Node_Id) return Boolean; -- Flag7
-
- function Is_Qualified_Universal_Literal
- (N : Node_Id) return Boolean; -- Flag4
-
- function Is_Read
- (N : Node_Id) return Boolean; -- Flag4
-
- function Is_Source_Call
- (N : Node_Id) return Boolean; -- Flag4
-
- function Is_SPARK_Mode_On_Node
- (N : Node_Id) return Boolean; -- Flag2
-
- function Is_Static_Coextension
- (N : Node_Id) return Boolean; -- Flag14
-
- function Is_Static_Expression
- (N : Node_Id) return Boolean; -- Flag6
-
- function Is_Subprogram_Descriptor
- (N : Node_Id) return Boolean; -- Flag16
-
- function Is_Task_Allocation_Block
- (N : Node_Id) return Boolean; -- Flag6
-
- function Is_Task_Body_Procedure
- (N : Node_Id) return Boolean; -- Flag1
-
- function Is_Task_Master
- (N : Node_Id) return Boolean; -- Flag5
-
- function Is_Write
- (N : Node_Id) return Boolean; -- Flag5
-
- 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
-
- function Label_Construct
- (N : Node_Id) return Node_Id; -- Node2
-
- function Left_Opnd
- (N : Node_Id) return Node_Id; -- Node2
-
- function Last_Bit
- (N : Node_Id) return Node_Id; -- Node4
-
- function Last_Name
- (N : Node_Id) return Boolean; -- Flag6
-
- function Library_Unit
- (N : Node_Id) return Node_Id; -- Node4
-
- function Limited_View_Installed
- (N : Node_Id) return Boolean; -- Flag18
-
- function Limited_Present
- (N : Node_Id) return Boolean; -- Flag17
-
- function Literals
- (N : Node_Id) return List_Id; -- List1
-
- function Local_Raise_Not_OK
- (N : Node_Id) return Boolean; -- Flag7
-
- function Local_Raise_Statements
- (N : Node_Id) return Elist_Id; -- Elist1
-
- function Loop_Actions
- (N : Node_Id) return List_Id; -- List5
-
- function Loop_Parameter_Specification
- (N : Node_Id) return Node_Id; -- Node4
-
- function Low_Bound
- (N : Node_Id) return Node_Id; -- Node1
-
- function Mod_Clause
- (N : Node_Id) return Node_Id; -- Node2
-
- function More_Ids
- (N : Node_Id) return Boolean; -- Flag5
-
- function Must_Be_Byte_Aligned
- (N : Node_Id) return Boolean; -- Flag14
-
- function Must_Not_Freeze
- (N : Node_Id) return Boolean; -- Flag8
-
- function Must_Not_Override
- (N : Node_Id) return Boolean; -- Flag15
-
- function Must_Override
- (N : Node_Id) return Boolean; -- Flag14
-
- function Name
- (N : Node_Id) return Node_Id; -- Node2
-
- function Names
- (N : Node_Id) return List_Id; -- List2
-
- function Next_Entity
- (N : Node_Id) return Node_Id; -- Node2
-
- function Next_Exit_Statement
- (N : Node_Id) return Node_Id; -- Node3
-
- function Next_Implicit_With
- (N : Node_Id) return Node_Id; -- Node3
-
- function Next_Named_Actual
- (N : Node_Id) return Node_Id; -- Node4
-
- function Next_Pragma
- (N : Node_Id) return Node_Id; -- Node1
-
- function Next_Rep_Item
- (N : Node_Id) return Node_Id; -- Node5
-
- function Next_Use_Clause
- (N : Node_Id) return Node_Id; -- Node3
-
- function No_Ctrl_Actions
- (N : Node_Id) return Boolean; -- Flag7
-
- function No_Elaboration_Check
- (N : Node_Id) return Boolean; -- Flag4
-
- function No_Entities_Ref_In_Spec
- (N : Node_Id) return Boolean; -- Flag8
-
- function No_Initialization
- (N : Node_Id) return Boolean; -- Flag13
-
- function No_Minimize_Eliminate
- (N : Node_Id) return Boolean; -- Flag17
-
- function No_Side_Effect_Removal
- (N : Node_Id) return Boolean; -- Flag17
-
- function No_Truncation
- (N : Node_Id) return Boolean; -- Flag17
-
- function Null_Excluding_Subtype
- (N : Node_Id) return Boolean; -- Flag16
-
- function Null_Exclusion_Present
- (N : Node_Id) return Boolean; -- Flag11
-
- function Null_Exclusion_In_Return_Present
- (N : Node_Id) return Boolean; -- Flag14
-
- function Null_Present
- (N : Node_Id) return Boolean; -- Flag13
-
- function Null_Record_Present
- (N : Node_Id) return Boolean; -- Flag17
-
- function Null_Statement
- (N : Node_Id) return Node_Id; -- Node2
-
- function Object_Definition
- (N : Node_Id) return Node_Id; -- Node4
-
- function Of_Present
- (N : Node_Id) return Boolean; -- Flag16
-
- function Original_Discriminant
- (N : Node_Id) return Node_Id; -- Node2
-
- function Original_Entity
- (N : Node_Id) return Entity_Id; -- Node2
-
- function Others_Discrete_Choices
- (N : Node_Id) return List_Id; -- List1
-
- function Out_Present
- (N : Node_Id) return Boolean; -- Flag17
-
- function Parameter_Associations
- (N : Node_Id) return List_Id; -- List3
-
- function Parameter_Specifications
- (N : Node_Id) return List_Id; -- List3
-
- function Parameter_Type
- (N : Node_Id) return Node_Id; -- Node2
-
- function Parent_Spec
- (N : Node_Id) return Node_Id; -- Node4
-
- function Parent_With
- (N : Node_Id) return Boolean; -- Flag1
-
- function Position
- (N : Node_Id) return Node_Id; -- Node2
-
- function Pragma_Argument_Associations
- (N : Node_Id) return List_Id; -- List2
-
- function Pragma_Identifier
- (N : Node_Id) return Node_Id; -- Node4
-
- function Pragmas_After
- (N : Node_Id) return List_Id; -- List5
-
- function Pragmas_Before
- (N : Node_Id) return List_Id; -- List4
-
- function Pre_Post_Conditions
- (N : Node_Id) return Node_Id; -- Node1
-
- function Prefix
- (N : Node_Id) return Node_Id; -- Node3
-
- function Premature_Use
- (N : Node_Id) return Node_Id; -- Node5
-
- function Present_Expr
- (N : Node_Id) return Uint; -- Uint3
-
- function Prev_Ids
- (N : Node_Id) return Boolean; -- Flag6
-
- function Prev_Use_Clause
- (N : Node_Id) return Node_Id; -- Node1
-
- function Print_In_Hex
- (N : Node_Id) return Boolean; -- Flag13
-
- function Private_Declarations
- (N : Node_Id) return List_Id; -- List3
-
- function Private_Present
- (N : Node_Id) return Boolean; -- Flag15
-
- function Procedure_To_Call
- (N : Node_Id) return Node_Id; -- Node2
-
- function Proper_Body
- (N : Node_Id) return Node_Id; -- Node1
-
- function Protected_Definition
- (N : Node_Id) return Node_Id; -- Node3
-
- function Protected_Present
- (N : Node_Id) return Boolean; -- Flag6
-
- function Raises_Constraint_Error
- (N : Node_Id) return Boolean; -- Flag7
-
- function Range_Constraint
- (N : Node_Id) return Node_Id; -- Node4
-
- function Range_Expression
- (N : Node_Id) return Node_Id; -- Node4
-
- function Real_Range_Specification
- (N : Node_Id) return Node_Id; -- Node4
-
- function Realval
- (N : Node_Id) return Ureal; -- Ureal3
-
- function Reason
- (N : Node_Id) return Uint; -- Uint3
-
- function Record_Extension_Part
- (N : Node_Id) return Node_Id; -- Node3
-
- function Redundant_Use
- (N : Node_Id) return Boolean; -- Flag13
-
- function Renaming_Exception
- (N : Node_Id) return Node_Id; -- Node2
-
- function Result_Definition
- (N : Node_Id) return Node_Id; -- Node4
-
- function Return_Object_Declarations
- (N : Node_Id) return List_Id; -- List3
-
- function Return_Statement_Entity
- (N : Node_Id) return Node_Id; -- Node5
-
- function Reverse_Present
- (N : Node_Id) return Boolean; -- Flag15
-
- function Right_Opnd
- (N : Node_Id) return Node_Id; -- Node3
-
- function Rounded_Result
- (N : Node_Id) return Boolean; -- Flag18
-
- function Save_Invocation_Graph_Of_Body
- (N : Node_Id) return Boolean; -- Flag1
-
- function SCIL_Controlling_Tag
- (N : Node_Id) return Node_Id; -- Node5
-
- function SCIL_Entity
- (N : Node_Id) return Node_Id; -- Node4
-
- function SCIL_Tag_Value
- (N : Node_Id) return Node_Id; -- Node5
-
- function SCIL_Target_Prim
- (N : Node_Id) return Node_Id; -- Node2
-
- function Scope
- (N : Node_Id) return Node_Id; -- Node3
-
- function Select_Alternatives
- (N : Node_Id) return List_Id; -- List1
-
- function Selector_Name
- (N : Node_Id) return Node_Id; -- Node2
-
- function Selector_Names
- (N : Node_Id) return List_Id; -- List1
-
- function Shift_Count_OK
- (N : Node_Id) return Boolean; -- Flag4
-
- function Source_Type
- (N : Node_Id) return Entity_Id; -- Node1
-
- function Specification
- (N : Node_Id) return Node_Id; -- Node1
-
- function Split_PPC
- (N : Node_Id) return Boolean; -- Flag17
-
- function Statements
- (N : Node_Id) return List_Id; -- List3
-
- function Storage_Pool
- (N : Node_Id) return Node_Id; -- Node1
-
- function Subpool_Handle_Name
- (N : Node_Id) return Node_Id; -- Node4
-
- function Strval
- (N : Node_Id) return String_Id; -- Str3
-
- function Subtype_Indication
- (N : Node_Id) return Node_Id; -- Node5
-
- function Subtype_Mark
- (N : Node_Id) return Node_Id; -- Node4
-
- function Subtype_Marks
- (N : Node_Id) return List_Id; -- List2
-
- function Suppress_Assignment_Checks
- (N : Node_Id) return Boolean; -- Flag18
-
- function Suppress_Loop_Warnings
- (N : Node_Id) return Boolean; -- Flag17
-
- function Synchronized_Present
- (N : Node_Id) return Boolean; -- Flag7
-
- function Tagged_Present
- (N : Node_Id) return Boolean; -- Flag15
-
- function Target
- (N : Node_Id) return Entity_Id; -- Node1
-
- function Target_Type
- (N : Node_Id) return Entity_Id; -- Node2
-
- function Task_Definition
- (N : Node_Id) return Node_Id; -- Node3
-
- function Task_Present
- (N : Node_Id) return Boolean; -- Flag5
-
- function Then_Actions
- (N : Node_Id) return List_Id; -- List2
-
- function Then_Statements
- (N : Node_Id) return List_Id; -- List2
-
- function Triggering_Alternative
- (N : Node_Id) return Node_Id; -- Node1
-
- function Triggering_Statement
- (N : Node_Id) return Node_Id; -- Node1
-
- function TSS_Elist
- (N : Node_Id) return Elist_Id; -- Elist3
-
- function Type_Definition
- (N : Node_Id) return Node_Id; -- Node3
-
- function Uneval_Old_Accept
- (N : Node_Id) return Boolean; -- Flag7
-
- function Uneval_Old_Warn
- (N : Node_Id) return Boolean; -- Flag18
-
- function Unit
- (N : Node_Id) return Node_Id; -- Node2
-
- function Unknown_Discriminants_Present
- (N : Node_Id) return Boolean; -- Flag13
-
- function Unreferenced_In_Spec
- (N : Node_Id) return Boolean; -- Flag7
-
- function Variant_Part
- (N : Node_Id) return Node_Id; -- Node4
-
- function Variants
- (N : Node_Id) return List_Id; -- List1
-
- function Visible_Declarations
- (N : Node_Id) return List_Id; -- List2
-
- function Uninitialized_Variable
- (N : Node_Id) return Node_Id; -- Node3
-
- function Used_Operations
- (N : Node_Id) return Elist_Id; -- Elist2
-
- function Was_Attribute_Reference
- (N : Node_Id) return Boolean; -- Flag2
-
- function Was_Default_Init_Box_Association
- (N : Node_Id) return Boolean; -- Flag14
-
- function Was_Expression_Function
- (N : Node_Id) return Boolean; -- Flag18
-
- function Was_Originally_Stub
- (N : Node_Id) return Boolean; -- Flag13
-
- -- End functions (note used by xsinfo utility program to end processing)
-
- ----------------------------
- -- Node Update Procedures --
- ----------------------------
-
- -- These are the corresponding node update routines, which again provide
- -- a high level logical access with type checking. In addition to setting
- -- the indicated field of the node N to the given Val, in the case of
- -- tree pointers (List1-4), the parent pointer of the Val node is set to
- -- point back to node N. This automates the setting of the parent pointer.
-
- -- WARNING: There is a matching C declaration of a few subprograms in fe.h
-
- procedure Set_Abort_Present
- (N : Node_Id; Val : Boolean := True); -- Flag15
-
- procedure Set_Abortable_Part
- (N : Node_Id; Val : Node_Id); -- Node2
-
- procedure Set_Abstract_Present
- (N : Node_Id; Val : Boolean := True); -- Flag4
-
- procedure Set_Accept_Handler_Records
- (N : Node_Id; Val : List_Id); -- List5
-
- procedure Set_Accept_Statement
- (N : Node_Id; Val : Node_Id); -- Node2
-
- procedure Set_Access_Definition
- (N : Node_Id; Val : Node_Id); -- Node3
-
- procedure Set_Access_To_Subprogram_Definition
- (N : Node_Id; Val : Node_Id); -- Node3
-
- procedure Set_Access_Types_To_Process
- (N : Node_Id; Val : Elist_Id); -- Elist2
-
- procedure Set_Actions
- (N : Node_Id; Val : List_Id); -- List1
-
- procedure Set_Activation_Chain_Entity
- (N : Node_Id; Val : Node_Id); -- Node3
-
- procedure Set_Acts_As_Spec
- (N : Node_Id; Val : Boolean := True); -- Flag4
-
- procedure Set_Actual_Designated_Subtype
- (N : Node_Id; Val : Node_Id); -- Node4
-
- procedure Set_Address_Warning_Posted
- (N : Node_Id; Val : Boolean := True); -- Flag18
-
- procedure Set_Aggregate_Bounds
- (N : Node_Id; Val : Node_Id); -- Node3
-
- procedure Set_Aliased_Present
- (N : Node_Id; Val : Boolean := True); -- Flag4
-
- procedure Set_Alloc_For_BIP_Return
- (N : Node_Id; Val : Boolean := True); -- Flag1
-
- procedure Set_All_Others
- (N : Node_Id; Val : Boolean := True); -- Flag11
-
- procedure Set_All_Present
- (N : Node_Id; Val : Boolean := True); -- Flag15
-
- procedure Set_Alternatives
- (N : Node_Id; Val : List_Id); -- List4
-
- procedure Set_Ancestor_Part
- (N : Node_Id; Val : Node_Id); -- Node3
-
- procedure Set_Atomic_Sync_Required
- (N : Node_Id; Val : Boolean := True); -- Flag14
-
- procedure Set_Array_Aggregate
- (N : Node_Id; Val : Node_Id); -- Node3
-
- procedure Set_Aspect_On_Partial_View
- (N : Node_Id; Val : Boolean := True); -- Flag18
-
- procedure Set_Aspect_Rep_Item
- (N : Node_Id; Val : Node_Id); -- Node2
-
- procedure Set_Assignment_OK
- (N : Node_Id; Val : Boolean := True); -- Flag15
-
- procedure Set_Associated_Node
- (N : Node_Id; Val : Node_Id); -- Node4
-
- procedure Set_Attribute_Name
- (N : Node_Id; Val : Name_Id); -- Name2
-
- procedure Set_At_End_Proc
- (N : Node_Id; Val : Node_Id); -- Node1
-
- procedure Set_Aux_Decls_Node
- (N : Node_Id; Val : Node_Id); -- Node5
-
- procedure Set_Backwards_OK
- (N : Node_Id; Val : Boolean := True); -- Flag6
-
- procedure Set_Bad_Is_Detected
- (N : Node_Id; Val : Boolean := True); -- Flag15
-
- procedure Set_Body_Required
- (N : Node_Id; Val : Boolean := True); -- Flag13
-
- procedure Set_Body_To_Inline
- (N : Node_Id; Val : Node_Id); -- Node3
-
- procedure Set_Box_Present
- (N : Node_Id; Val : Boolean := True); -- Flag15
-
- procedure Set_By_Ref
- (N : Node_Id; Val : Boolean := True); -- Flag5
-
- procedure Set_Char_Literal_Value
- (N : Node_Id; Val : Uint); -- Uint2
-
- procedure Set_Chars
- (N : Node_Id; Val : Name_Id); -- Name1
-
- procedure Set_Check_Address_Alignment
- (N : Node_Id; Val : Boolean := True); -- Flag11
-
- procedure Set_Choice_Parameter
- (N : Node_Id; Val : Node_Id); -- Node2
-
- procedure Set_Choices
- (N : Node_Id; Val : List_Id); -- List1
-
- procedure Set_Class_Present
- (N : Node_Id; Val : Boolean := True); -- Flag6
-
- procedure Set_Classifications
- (N : Node_Id; Val : Node_Id); -- Node3
-
- procedure Set_Cleanup_Actions
- (N : Node_Id; Val : List_Id); -- List5
-
- procedure Set_Comes_From_Extended_Return_Statement
- (N : Node_Id; Val : Boolean := True); -- Flag18
-
- procedure Set_Compile_Time_Known_Aggregate
- (N : Node_Id; Val : Boolean := True); -- Flag18
-
- procedure Set_Component_Associations
- (N : Node_Id; Val : List_Id); -- List2
-
- procedure Set_Component_Clauses
- (N : Node_Id; Val : List_Id); -- List3
-
- procedure Set_Component_Definition
- (N : Node_Id; Val : Node_Id); -- Node4
-
- procedure Set_Component_Items
- (N : Node_Id; Val : List_Id); -- List3
-
- procedure Set_Component_List
- (N : Node_Id; Val : Node_Id); -- Node1
-
- procedure Set_Component_Name
- (N : Node_Id; Val : Node_Id); -- Node1
-
- procedure Set_Componentwise_Assignment
- (N : Node_Id; Val : Boolean := True); -- Flag14
-
- procedure Set_Condition
- (N : Node_Id; Val : Node_Id); -- Node1
-
- procedure Set_Condition_Actions
- (N : Node_Id; Val : List_Id); -- List3
-
- procedure Set_Config_Pragmas
- (N : Node_Id; Val : List_Id); -- List4
-
- procedure Set_Constant_Present
- (N : Node_Id; Val : Boolean := True); -- Flag17
-
- procedure Set_Constraint
- (N : Node_Id; Val : Node_Id); -- Node3
-
- procedure Set_Constraints
- (N : Node_Id; Val : List_Id); -- List1
-
- procedure Set_Context_Installed
- (N : Node_Id; Val : Boolean := True); -- Flag13
-
- procedure Set_Context_Items
- (N : Node_Id; Val : List_Id); -- List1
-
- procedure Set_Context_Pending
- (N : Node_Id; Val : Boolean := True); -- Flag16
-
- procedure Set_Contract_Test_Cases
- (N : Node_Id; Val : Node_Id); -- Node2
-
- procedure Set_Controlling_Argument
- (N : Node_Id; Val : Node_Id); -- Node1
-
- procedure Set_Conversion_OK
- (N : Node_Id; Val : Boolean := True); -- Flag14
-
- procedure Set_Convert_To_Return_False
- (N : Node_Id; Val : Boolean := True); -- Flag13
-
- procedure Set_Corresponding_Aspect
- (N : Node_Id; Val : Node_Id); -- Node3
-
- procedure Set_Corresponding_Body
- (N : Node_Id; Val : Node_Id); -- Node5
-
- procedure Set_Corresponding_Formal_Spec
- (N : Node_Id; Val : Node_Id); -- Node3
-
- procedure Set_Corresponding_Generic_Association
- (N : Node_Id; Val : Node_Id); -- Node5
-
- procedure Set_Corresponding_Integer_Value
- (N : Node_Id; Val : Uint); -- Uint4
-
- procedure Set_Corresponding_Spec
- (N : Node_Id; Val : Entity_Id); -- Node5
-
- procedure Set_Corresponding_Spec_Of_Stub
- (N : Node_Id; Val : Node_Id); -- Node2
-
- procedure Set_Corresponding_Stub
- (N : Node_Id; Val : Node_Id); -- Node3
-
- procedure Set_Dcheck_Function
- (N : Node_Id; Val : Entity_Id); -- Node5
-
- procedure Set_Declarations
- (N : Node_Id; Val : List_Id); -- List2
-
- procedure Set_Default_Expression
- (N : Node_Id; Val : Node_Id); -- Node5
-
- procedure Set_Default_Storage_Pool
- (N : Node_Id; Val : Node_Id); -- Node3
-
- procedure Set_Default_Name
- (N : Node_Id; Val : Node_Id); -- Node2
-
- procedure Set_Defining_Identifier
- (N : Node_Id; Val : Entity_Id); -- Node1
-
- procedure Set_Defining_Unit_Name
- (N : Node_Id; Val : Node_Id); -- Node1
-
- procedure Set_Delay_Alternative
- (N : Node_Id; Val : Node_Id); -- Node4
-
- procedure Set_Delay_Statement
- (N : Node_Id; Val : Node_Id); -- Node2
-
- procedure Set_Delta_Expression
- (N : Node_Id; Val : Node_Id); -- Node3
-
- procedure Set_Digits_Expression
- (N : Node_Id; Val : Node_Id); -- Node2
-
- procedure Set_Discr_Check_Funcs_Built
- (N : Node_Id; Val : Boolean := True); -- Flag11
-
- procedure Set_Discrete_Choices
- (N : Node_Id; Val : List_Id); -- List4
-
- procedure Set_Discrete_Range
- (N : Node_Id; Val : Node_Id); -- Node4
-
- procedure Set_Discrete_Subtype_Definition
- (N : Node_Id; Val : Node_Id); -- Node4
-
- procedure Set_Discrete_Subtype_Definitions
- (N : Node_Id; Val : List_Id); -- List2
-
- procedure Set_Discriminant_Specifications
- (N : Node_Id; Val : List_Id); -- List4
-
- procedure Set_Discriminant_Type
- (N : Node_Id; Val : Node_Id); -- Node5
-
- procedure Set_Do_Accessibility_Check
- (N : Node_Id; Val : Boolean := True); -- Flag13
-
- procedure Set_Do_Discriminant_Check
- (N : Node_Id; Val : Boolean := True); -- Flag3
-
- procedure Set_Do_Division_Check
- (N : Node_Id; Val : Boolean := True); -- Flag13
-
- procedure Set_Do_Length_Check
- (N : Node_Id; Val : Boolean := True); -- Flag4
-
- procedure Set_Do_Overflow_Check
- (N : Node_Id; Val : Boolean := True); -- Flag17
-
- procedure Set_Do_Range_Check
- (N : Node_Id; Val : Boolean := True); -- Flag9
-
- procedure Set_Do_Storage_Check
- (N : Node_Id; Val : Boolean := True); -- Flag17
-
- procedure Set_Do_Tag_Check
- (N : Node_Id; Val : Boolean := True); -- Flag13
-
- procedure Set_Elaborate_All_Desirable
- (N : Node_Id; Val : Boolean := True); -- Flag9
-
- procedure Set_Elaborate_All_Present
- (N : Node_Id; Val : Boolean := True); -- Flag14
-
- procedure Set_Elaborate_Desirable
- (N : Node_Id; Val : Boolean := True); -- Flag11
-
- procedure Set_Elaborate_Present
- (N : Node_Id; Val : Boolean := True); -- Flag4
-
- procedure Set_Else_Actions
- (N : Node_Id; Val : List_Id); -- List3
-
- procedure Set_Else_Statements
- (N : Node_Id; Val : List_Id); -- List4
-
- procedure Set_Elsif_Parts
- (N : Node_Id; Val : List_Id); -- List3
-
- procedure Set_Enclosing_Variant
- (N : Node_Id; Val : Node_Id); -- Node2
-
- procedure Set_End_Label
- (N : Node_Id; Val : Node_Id); -- Node4
-
- procedure Set_End_Span
- (N : Node_Id; Val : Uint); -- Uint5
-
- procedure Set_Entity
- (N : Node_Id; Val : Node_Id); -- Node4
-
- procedure Set_Entry_Body_Formal_Part
- (N : Node_Id; Val : Node_Id); -- Node5
-
- procedure Set_Entry_Call_Alternative
- (N : Node_Id; Val : Node_Id); -- Node1
-
- procedure Set_Entry_Call_Statement
- (N : Node_Id; Val : Node_Id); -- Node1
-
- procedure Set_Entry_Direct_Name
- (N : Node_Id; Val : Node_Id); -- Node1
-
- procedure Set_Entry_Index
- (N : Node_Id; Val : Node_Id); -- Node5
-
- procedure Set_Entry_Index_Specification
- (N : Node_Id; Val : Node_Id); -- Node4
-
- procedure Set_Etype
- (N : Node_Id; Val : Node_Id); -- Node5
-
- procedure Set_Exception_Choices
- (N : Node_Id; Val : List_Id); -- List4
-
- procedure Set_Exception_Handlers
- (N : Node_Id; Val : List_Id); -- List5
-
- procedure Set_Exception_Junk
- (N : Node_Id; Val : Boolean := True); -- Flag8
-
- procedure Set_Exception_Label
- (N : Node_Id; Val : Node_Id); -- Node5
-
- procedure Set_Expansion_Delayed
- (N : Node_Id; Val : Boolean := True); -- Flag11
-
- procedure Set_Explicit_Actual_Parameter
- (N : Node_Id; Val : Node_Id); -- Node3
-
- procedure Set_Explicit_Generic_Actual_Parameter
- (N : Node_Id; Val : Node_Id); -- Node1
-
- procedure Set_Expression
- (N : Node_Id; Val : Node_Id); -- Node3
-
- procedure Set_Expression_Copy
- (N : Node_Id; Val : Node_Id); -- Node2
-
- procedure Set_Expressions
- (N : Node_Id; Val : List_Id); -- List1
-
- procedure Set_First_Bit
- (N : Node_Id; Val : Node_Id); -- Node3
-
- procedure Set_First_Inlined_Subprogram
- (N : Node_Id; Val : Entity_Id); -- Node3
-
- procedure Set_First_Name
- (N : Node_Id; Val : Boolean := True); -- Flag5
-
- procedure Set_First_Named_Actual
- (N : Node_Id; Val : Node_Id); -- Node4
-
- procedure Set_First_Real_Statement
- (N : Node_Id; Val : Node_Id); -- Node2
-
- procedure Set_First_Subtype_Link
- (N : Node_Id; Val : Entity_Id); -- Node5
-
- procedure Set_Float_Truncate
- (N : Node_Id; Val : Boolean := True); -- Flag11
-
- procedure Set_Formal_Type_Definition
- (N : Node_Id; Val : Node_Id); -- Node3
-
- procedure Set_Forwards_OK
- (N : Node_Id; Val : Boolean := True); -- Flag5
-
- procedure Set_From_Aspect_Specification
- (N : Node_Id; Val : Boolean := True); -- Flag13
-
- procedure Set_From_At_End
- (N : Node_Id; Val : Boolean := True); -- Flag4
-
- procedure Set_From_At_Mod
- (N : Node_Id; Val : Boolean := True); -- Flag4
-
- procedure Set_From_Conditional_Expression
- (N : Node_Id; Val : Boolean := True); -- Flag1
-
- procedure Set_From_Default
- (N : Node_Id; Val : Boolean := True); -- Flag6
-
- procedure Set_Generalized_Indexing
- (N : Node_Id; Val : Node_Id); -- Node4
-
- procedure Set_Generic_Associations
- (N : Node_Id; Val : List_Id); -- List3
-
- procedure Set_Generic_Formal_Declarations
- (N : Node_Id; Val : List_Id); -- List2
-
- procedure Set_Generic_Parent
- (N : Node_Id; Val : Node_Id); -- Node5
-
- procedure Set_Generic_Parent_Type
- (N : Node_Id; Val : Node_Id); -- Node4
-
- procedure Set_Handled_Statement_Sequence
- (N : Node_Id; Val : Node_Id); -- Node4
-
- procedure Set_Handler_List_Entry
- (N : Node_Id; Val : Node_Id); -- Node2
-
- procedure Set_Has_Created_Identifier
- (N : Node_Id; Val : Boolean := True); -- Flag15
-
- procedure Set_Has_Dereference_Action
- (N : Node_Id; Val : Boolean := True); -- Flag13
-
- procedure Set_Has_Dynamic_Length_Check
- (N : Node_Id; Val : Boolean := True); -- Flag10
-
- procedure Set_Has_Init_Expression
- (N : Node_Id; Val : Boolean := True); -- Flag14
-
- procedure Set_Has_Local_Raise
- (N : Node_Id; Val : Boolean := True); -- Flag8
-
- procedure Set_Has_No_Elaboration_Code
- (N : Node_Id; Val : Boolean := True); -- Flag17
-
- procedure Set_Has_Pragma_Suppress_All
- (N : Node_Id; Val : Boolean := True); -- Flag14
-
- procedure Set_Has_Private_View
- (N : Node_Id; Val : Boolean := True); -- Flag11
-
- procedure Set_Has_Relative_Deadline_Pragma
- (N : Node_Id; Val : Boolean := True); -- Flag9
-
- procedure Set_Has_Self_Reference
- (N : Node_Id; Val : Boolean := True); -- Flag13
-
- procedure Set_Has_SP_Choice
- (N : Node_Id; Val : Boolean := True); -- Flag15
-
- procedure Set_Has_Storage_Size_Pragma
- (N : Node_Id; Val : Boolean := True); -- Flag5
-
- procedure Set_Has_Target_Names
- (N : Node_Id; Val : Boolean := True); -- Flag8
-
- procedure Set_Has_Wide_Character
- (N : Node_Id; Val : Boolean := True); -- Flag11
-
- procedure Set_Has_Wide_Wide_Character
- (N : Node_Id; Val : Boolean := True); -- Flag13
-
- procedure Set_Header_Size_Added
- (N : Node_Id; Val : Boolean := True); -- Flag11
-
- procedure Set_Hidden_By_Use_Clause
- (N : Node_Id; Val : Elist_Id); -- Elist5
-
- procedure Set_High_Bound
- (N : Node_Id; Val : Node_Id); -- Node2
-
- procedure Set_Identifier
- (N : Node_Id; Val : Node_Id); -- Node1
-
- procedure Set_Interface_List
- (N : Node_Id; Val : List_Id); -- List2
-
- procedure Set_Interface_Present
- (N : Node_Id; Val : Boolean := True); -- Flag16
-
- procedure Set_Implicit_With
- (N : Node_Id; Val : Boolean := True); -- Flag16
-
- procedure Set_Import_Interface_Present
- (N : Node_Id; Val : Boolean := True); -- Flag16
-
- procedure Set_In_Present
- (N : Node_Id; Val : Boolean := True); -- Flag15
-
- procedure Set_Includes_Infinities
- (N : Node_Id; Val : Boolean := True); -- Flag11
-
- procedure Set_Incomplete_View
- (N : Node_Id; Val : Node_Id); -- Node2
-
- procedure Set_Inherited_Discriminant
- (N : Node_Id; Val : Boolean := True); -- Flag13
-
- procedure Set_Instance_Spec
- (N : Node_Id; Val : Node_Id); -- Node5
-
- procedure Set_Intval
- (N : Node_Id; Val : Uint); -- Uint3
-
- procedure Set_Is_Abort_Block
- (N : Node_Id; Val : Boolean := True); -- Flag4
-
- procedure Set_Is_Accessibility_Actual
- (N : Node_Id; Val : Boolean := True); -- Flag13
-
- procedure Set_Is_Analyzed_Pragma
- (N : Node_Id; Val : Boolean := True); -- Flag5
-
- procedure Set_Is_Asynchronous_Call_Block
- (N : Node_Id; Val : Boolean := True); -- Flag7
-
- procedure Set_Is_Boolean_Aspect
- (N : Node_Id; Val : Boolean := True); -- Flag16
-
- procedure Set_Is_Checked
- (N : Node_Id; Val : Boolean := True); -- Flag11
-
- procedure Set_Is_Checked_Ghost_Pragma
- (N : Node_Id; Val : Boolean := True); -- Flag3
-
- procedure Set_Is_Component_Left_Opnd
- (N : Node_Id; Val : Boolean := True); -- Flag13
-
- procedure Set_Is_Component_Right_Opnd
- (N : Node_Id; Val : Boolean := True); -- Flag14
-
- procedure Set_Is_Controlling_Actual
- (N : Node_Id; Val : Boolean := True); -- Flag16
-
- procedure Set_Is_Declaration_Level_Node
- (N : Node_Id; Val : Boolean := True); -- Flag5
-
- procedure Set_Is_Delayed_Aspect
- (N : Node_Id; Val : Boolean := True); -- Flag14
-
- procedure Set_Is_Disabled
- (N : Node_Id; Val : Boolean := True); -- Flag15
-
- procedure Set_Is_Dispatching_Call
- (N : Node_Id; Val : Boolean := True); -- Flag6
-
- procedure Set_Is_Dynamic_Coextension
- (N : Node_Id; Val : Boolean := True); -- Flag18
-
- procedure Set_Is_Effective_Use_Clause
- (N : Node_Id; Val : Boolean := True); -- Flag1
-
- procedure Set_Is_Elaboration_Checks_OK_Node
- (N : Node_Id; Val : Boolean := True); -- Flag1
-
- procedure Set_Is_Elaboration_Code
- (N : Node_Id; Val : Boolean := True); -- Flag9
-
- procedure Set_Is_Elaboration_Warnings_OK_Node
- (N : Node_Id; Val : Boolean := True); -- Flag3
-
- procedure Set_Is_Elsif
- (N : Node_Id; Val : Boolean := True); -- Flag13
-
- procedure Set_Is_Entry_Barrier_Function
- (N : Node_Id; Val : Boolean := True); -- Flag8
-
- procedure Set_Is_Expanded_Build_In_Place_Call
- (N : Node_Id; Val : Boolean := True); -- Flag11
-
- procedure Set_Is_Expanded_Contract
- (N : Node_Id; Val : Boolean := True); -- Flag1
-
- procedure Set_Is_Finalization_Wrapper
- (N : Node_Id; Val : Boolean := True); -- Flag9
-
- procedure Set_Is_Folded_In_Parser
- (N : Node_Id; Val : Boolean := True); -- Flag4
-
- procedure Set_Is_Generic_Contract_Pragma
- (N : Node_Id; Val : Boolean := True); -- Flag2
-
- procedure Set_Is_Homogeneous_Aggregate
- (N : Node_Id; Val : Boolean := True); -- Flag14
-
- procedure Set_Is_Ignored
- (N : Node_Id; Val : Boolean := True); -- Flag9
-
- procedure Set_Is_Ignored_Ghost_Pragma
- (N : Node_Id; Val : Boolean := True); -- Flag8
-
- procedure Set_Is_In_Discriminant_Check
- (N : Node_Id; Val : Boolean := True); -- Flag11
-
- procedure Set_Is_Inherited_Pragma
- (N : Node_Id; Val : Boolean := True); -- Flag4
-
- procedure Set_Is_Initialization_Block
- (N : Node_Id; Val : Boolean := True); -- Flag1
-
- procedure Set_Is_Known_Guaranteed_ABE
- (N : Node_Id; Val : Boolean := True); -- Flag18
-
- procedure Set_Is_Machine_Number
- (N : Node_Id; Val : Boolean := True); -- Flag11
-
- procedure Set_Is_Null_Loop
- (N : Node_Id; Val : Boolean := True); -- Flag16
-
- 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
-
- procedure Set_Is_Protected_Subprogram_Body
- (N : Node_Id; Val : Boolean := True); -- Flag7
-
- procedure Set_Is_Qualified_Universal_Literal
- (N : Node_Id; Val : Boolean := True); -- Flag4
-
- procedure Set_Is_Read
- (N : Node_Id; Val : Boolean := True); -- Flag4
-
- procedure Set_Is_Source_Call
- (N : Node_Id; Val : Boolean := True); -- Flag4
-
- procedure Set_Is_SPARK_Mode_On_Node
- (N : Node_Id; Val : Boolean := True); -- Flag2
-
- procedure Set_Is_Static_Coextension
- (N : Node_Id; Val : Boolean := True); -- Flag14
-
- procedure Set_Is_Static_Expression
- (N : Node_Id; Val : Boolean := True); -- Flag6
-
- procedure Set_Is_Subprogram_Descriptor
- (N : Node_Id; Val : Boolean := True); -- Flag16
-
- procedure Set_Is_Task_Allocation_Block
- (N : Node_Id; Val : Boolean := True); -- Flag6
-
- procedure Set_Is_Task_Body_Procedure
- (N : Node_Id; Val : Boolean := True); -- Flag1
-
- procedure Set_Is_Task_Master
- (N : Node_Id; Val : Boolean := True); -- Flag5
-
- 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
-
- procedure Set_Iterator_Specification
- (N : Node_Id; Val : Node_Id); -- Node2
-
- 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
-
- procedure Set_Last_Bit
- (N : Node_Id; Val : Node_Id); -- Node4
-
- procedure Set_Last_Name
- (N : Node_Id; Val : Boolean := True); -- Flag6
-
- procedure Set_Library_Unit
- (N : Node_Id; Val : Node_Id); -- Node4
-
- procedure Set_Label_Construct
- (N : Node_Id; Val : Node_Id); -- Node2
-
- procedure Set_Left_Opnd
- (N : Node_Id; Val : Node_Id); -- Node2
-
- procedure Set_Limited_View_Installed
- (N : Node_Id; Val : Boolean := True); -- Flag18
-
- procedure Set_Limited_Present
- (N : Node_Id; Val : Boolean := True); -- Flag17
-
- procedure Set_Literals
- (N : Node_Id; Val : List_Id); -- List1
-
- procedure Set_Local_Raise_Not_OK
- (N : Node_Id; Val : Boolean := True); -- Flag7
-
- procedure Set_Local_Raise_Statements
- (N : Node_Id; Val : Elist_Id); -- Elist1
-
- procedure Set_Loop_Actions
- (N : Node_Id; Val : List_Id); -- List5
-
- procedure Set_Loop_Parameter_Specification
- (N : Node_Id; Val : Node_Id); -- Node4
-
- procedure Set_Low_Bound
- (N : Node_Id; Val : Node_Id); -- Node1
-
- procedure Set_Mod_Clause
- (N : Node_Id; Val : Node_Id); -- Node2
-
- procedure Set_More_Ids
- (N : Node_Id; Val : Boolean := True); -- Flag5
-
- procedure Set_Must_Be_Byte_Aligned
- (N : Node_Id; Val : Boolean := True); -- Flag14
-
- procedure Set_Must_Not_Freeze
- (N : Node_Id; Val : Boolean := True); -- Flag8
-
- procedure Set_Must_Not_Override
- (N : Node_Id; Val : Boolean := True); -- Flag15
-
- procedure Set_Must_Override
- (N : Node_Id; Val : Boolean := True); -- Flag14
-
- procedure Set_Name
- (N : Node_Id; Val : Node_Id); -- Node2
-
- procedure Set_Names
- (N : Node_Id; Val : List_Id); -- List2
-
- procedure Set_Next_Entity
- (N : Node_Id; Val : Node_Id); -- Node2
-
- procedure Set_Next_Exit_Statement
- (N : Node_Id; Val : Node_Id); -- Node3
-
- procedure Set_Next_Implicit_With
- (N : Node_Id; Val : Node_Id); -- Node3
-
- procedure Set_Next_Named_Actual
- (N : Node_Id; Val : Node_Id); -- Node4
-
- procedure Set_Next_Pragma
- (N : Node_Id; Val : Node_Id); -- Node1
-
- procedure Set_Next_Rep_Item
- (N : Node_Id; Val : Node_Id); -- Node5
-
- procedure Set_Next_Use_Clause
- (N : Node_Id; Val : Node_Id); -- Node3
-
- procedure Set_No_Ctrl_Actions
- (N : Node_Id; Val : Boolean := True); -- Flag7
-
- procedure Set_No_Elaboration_Check
- (N : Node_Id; Val : Boolean := True); -- Flag4
-
- procedure Set_No_Entities_Ref_In_Spec
- (N : Node_Id; Val : Boolean := True); -- Flag8
-
- procedure Set_No_Initialization
- (N : Node_Id; Val : Boolean := True); -- Flag13
-
- procedure Set_No_Minimize_Eliminate
- (N : Node_Id; Val : Boolean := True); -- Flag17
-
- procedure Set_No_Side_Effect_Removal
- (N : Node_Id; Val : Boolean := True); -- Flag17
-
- procedure Set_No_Truncation
- (N : Node_Id; Val : Boolean := True); -- Flag17
-
- procedure Set_Null_Excluding_Subtype
- (N : Node_Id; Val : Boolean := True); -- Flag16
-
- procedure Set_Null_Exclusion_Present
- (N : Node_Id; Val : Boolean := True); -- Flag11
-
- procedure Set_Null_Exclusion_In_Return_Present
- (N : Node_Id; Val : Boolean := True); -- Flag14
-
- procedure Set_Null_Present
- (N : Node_Id; Val : Boolean := True); -- Flag13
-
- procedure Set_Null_Record_Present
- (N : Node_Id; Val : Boolean := True); -- Flag17
-
- procedure Set_Null_Statement
- (N : Node_Id; Val : Node_Id); -- Node2
-
- procedure Set_Object_Definition
- (N : Node_Id; Val : Node_Id); -- Node4
-
- procedure Set_Of_Present
- (N : Node_Id; Val : Boolean := True); -- Flag16
-
- procedure Set_Original_Discriminant
- (N : Node_Id; Val : Node_Id); -- Node2
-
- procedure Set_Original_Entity
- (N : Node_Id; Val : Entity_Id); -- Node2
-
- procedure Set_Others_Discrete_Choices
- (N : Node_Id; Val : List_Id); -- List1
-
- procedure Set_Out_Present
- (N : Node_Id; Val : Boolean := True); -- Flag17
-
- procedure Set_Parameter_Associations
- (N : Node_Id; Val : List_Id); -- List3
-
- procedure Set_Parameter_Specifications
- (N : Node_Id; Val : List_Id); -- List3
-
- procedure Set_Parameter_Type
- (N : Node_Id; Val : Node_Id); -- Node2
-
- procedure Set_Parent_Spec
- (N : Node_Id; Val : Node_Id); -- Node4
-
- procedure Set_Parent_With
- (N : Node_Id; Val : Boolean := True); -- Flag1
-
- procedure Set_Position
- (N : Node_Id; Val : Node_Id); -- Node2
-
- procedure Set_Pragma_Argument_Associations
- (N : Node_Id; Val : List_Id); -- List2
-
- procedure Set_Pragma_Identifier
- (N : Node_Id; Val : Node_Id); -- Node4
-
- procedure Set_Pragmas_After
- (N : Node_Id; Val : List_Id); -- List5
-
- procedure Set_Pragmas_Before
- (N : Node_Id; Val : List_Id); -- List4
-
- procedure Set_Pre_Post_Conditions
- (N : Node_Id; Val : Node_Id); -- Node1
-
- procedure Set_Prefix
- (N : Node_Id; Val : Node_Id); -- Node3
-
- procedure Set_Premature_Use
- (N : Node_Id; Val : Node_Id); -- Node5
-
- procedure Set_Present_Expr
- (N : Node_Id; Val : Uint); -- Uint3
-
- procedure Set_Prev_Ids
- (N : Node_Id; Val : Boolean := True); -- Flag6
-
- procedure Set_Prev_Use_Clause
- (N : Node_Id; Val : Node_Id); -- Node1
-
- procedure Set_Print_In_Hex
- (N : Node_Id; Val : Boolean := True); -- Flag13
-
- procedure Set_Private_Declarations
- (N : Node_Id; Val : List_Id); -- List3
-
- procedure Set_Private_Present
- (N : Node_Id; Val : Boolean := True); -- Flag15
-
- procedure Set_Procedure_To_Call
- (N : Node_Id; Val : Node_Id); -- Node2
-
- procedure Set_Proper_Body
- (N : Node_Id; Val : Node_Id); -- Node1
-
- procedure Set_Protected_Definition
- (N : Node_Id; Val : Node_Id); -- Node3
-
- procedure Set_Protected_Present
- (N : Node_Id; Val : Boolean := True); -- Flag6
-
- procedure Set_Raises_Constraint_Error
- (N : Node_Id; Val : Boolean := True); -- Flag7
-
- procedure Set_Range_Constraint
- (N : Node_Id; Val : Node_Id); -- Node4
-
- procedure Set_Range_Expression
- (N : Node_Id; Val : Node_Id); -- Node4
-
- procedure Set_Real_Range_Specification
- (N : Node_Id; Val : Node_Id); -- Node4
-
- procedure Set_Realval
- (N : Node_Id; Val : Ureal); -- Ureal3
-
- procedure Set_Reason
- (N : Node_Id; Val : Uint); -- Uint3
-
- procedure Set_Record_Extension_Part
- (N : Node_Id; Val : Node_Id); -- Node3
-
- procedure Set_Redundant_Use
- (N : Node_Id; Val : Boolean := True); -- Flag13
-
- procedure Set_Renaming_Exception
- (N : Node_Id; Val : Node_Id); -- Node2
-
- procedure Set_Result_Definition
- (N : Node_Id; Val : Node_Id); -- Node4
-
- procedure Set_Return_Object_Declarations
- (N : Node_Id; Val : List_Id); -- List3
-
- procedure Set_Return_Statement_Entity
- (N : Node_Id; Val : Node_Id); -- Node5
-
- procedure Set_Reverse_Present
- (N : Node_Id; Val : Boolean := True); -- Flag15
-
- procedure Set_Right_Opnd
- (N : Node_Id; Val : Node_Id); -- Node3
-
- procedure Set_Rounded_Result
- (N : Node_Id; Val : Boolean := True); -- Flag18
-
- procedure Set_Save_Invocation_Graph_Of_Body
- (N : Node_Id; Val : Boolean := True); -- Flag1
-
- procedure Set_SCIL_Controlling_Tag
- (N : Node_Id; Val : Node_Id); -- Node5
-
- procedure Set_SCIL_Entity
- (N : Node_Id; Val : Node_Id); -- Node4
-
- procedure Set_SCIL_Tag_Value
- (N : Node_Id; Val : Node_Id); -- Node5
-
- procedure Set_SCIL_Target_Prim
- (N : Node_Id; Val : Node_Id); -- Node2
-
- procedure Set_Scope
- (N : Node_Id; Val : Node_Id); -- Node3
-
- procedure Set_Select_Alternatives
- (N : Node_Id; Val : List_Id); -- List1
-
- procedure Set_Selector_Name
- (N : Node_Id; Val : Node_Id); -- Node2
-
- procedure Set_Selector_Names
- (N : Node_Id; Val : List_Id); -- List1
-
- procedure Set_Shift_Count_OK
- (N : Node_Id; Val : Boolean := True); -- Flag4
-
- procedure Set_Source_Type
- (N : Node_Id; Val : Entity_Id); -- Node1
-
- procedure Set_Specification
- (N : Node_Id; Val : Node_Id); -- Node1
-
- procedure Set_Split_PPC
- (N : Node_Id; Val : Boolean); -- Flag17
-
- procedure Set_Statements
- (N : Node_Id; Val : List_Id); -- List3
-
- procedure Set_Storage_Pool
- (N : Node_Id; Val : Node_Id); -- Node1
-
- procedure Set_Subpool_Handle_Name
- (N : Node_Id; Val : Node_Id); -- Node4
-
- procedure Set_Strval
- (N : Node_Id; Val : String_Id); -- Str3
-
- procedure Set_Subtype_Indication
- (N : Node_Id; Val : Node_Id); -- Node5
-
- procedure Set_Subtype_Mark
- (N : Node_Id; Val : Node_Id); -- Node4
-
- procedure Set_Subtype_Marks
- (N : Node_Id; Val : List_Id); -- List2
-
- procedure Set_Suppress_Assignment_Checks
- (N : Node_Id; Val : Boolean := True); -- Flag18
-
- procedure Set_Suppress_Loop_Warnings
- (N : Node_Id; Val : Boolean := True); -- Flag17
-
- procedure Set_Synchronized_Present
- (N : Node_Id; Val : Boolean := True); -- Flag7
-
- procedure Set_Tagged_Present
- (N : Node_Id; Val : Boolean := True); -- Flag15
-
- procedure Set_Target
- (N : Node_Id; Val : Entity_Id); -- Node1
-
- procedure Set_Target_Type
- (N : Node_Id; Val : Entity_Id); -- Node2
-
- procedure Set_Task_Definition
- (N : Node_Id; Val : Node_Id); -- Node3
-
- procedure Set_Task_Present
- (N : Node_Id; Val : Boolean := True); -- Flag5
-
- procedure Set_Then_Actions
- (N : Node_Id; Val : List_Id); -- List2
-
- procedure Set_Then_Statements
- (N : Node_Id; Val : List_Id); -- List2
-
- procedure Set_Triggering_Alternative
- (N : Node_Id; Val : Node_Id); -- Node1
-
- procedure Set_Triggering_Statement
- (N : Node_Id; Val : Node_Id); -- Node1
-
- procedure Set_TSS_Elist
- (N : Node_Id; Val : Elist_Id); -- Elist3
-
- procedure Set_Type_Definition
- (N : Node_Id; Val : Node_Id); -- Node3
-
- procedure Set_Uneval_Old_Accept
- (N : Node_Id; Val : Boolean := True); -- Flag7
-
- procedure Set_Uneval_Old_Warn
- (N : Node_Id; Val : Boolean := True); -- Flag18
-
- procedure Set_Unit
- (N : Node_Id; Val : Node_Id); -- Node2
-
- procedure Set_Unknown_Discriminants_Present
- (N : Node_Id; Val : Boolean := True); -- Flag13
-
- procedure Set_Unreferenced_In_Spec
- (N : Node_Id; Val : Boolean := True); -- Flag7
-
- procedure Set_Variant_Part
- (N : Node_Id; Val : Node_Id); -- Node4
-
- procedure Set_Variants
- (N : Node_Id; Val : List_Id); -- List1
-
- procedure Set_Visible_Declarations
- (N : Node_Id; Val : List_Id); -- List2
-
- procedure Set_Uninitialized_Variable
- (N : Node_Id; Val : Node_Id); -- Node3
-
- procedure Set_Used_Operations
- (N : Node_Id; Val : Elist_Id); -- Elist2
-
- procedure Set_Was_Attribute_Reference
- (N : Node_Id; Val : Boolean := True); -- Flag2
-
- procedure Set_Was_Default_Init_Box_Association
- (N : Node_Id; Val : Boolean := True); -- Flag14
-
- procedure Set_Was_Expression_Function
- (N : Node_Id; Val : Boolean := True); -- Flag18
-
- procedure Set_Was_Originally_Stub
- (N : Node_Id; Val : Boolean := True); -- Flag13
-
- -------------------------
- -- Iterator Procedures --
- -------------------------
-
- -- The call to Next_xxx (N) is equivalent to N := Next_xxx (N)
-
- procedure Next_Entity (N : in out Node_Id);
- procedure Next_Named_Actual (N : in out Node_Id);
- procedure Next_Rep_Item (N : in out Node_Id);
- procedure Next_Use_Clause (N : in out Node_Id);
-
- -------------------------------------------
- -- Miscellaneous Tree Access Subprograms --
- -------------------------------------------
-
- function End_Location (N : Node_Id) return Source_Ptr;
- -- N is an N_If_Statement or N_Case_Statement node, and this function
- -- returns the location of the IF token in the END IF sequence by
- -- translating the value of the End_Span field.
-
- -- WARNING: There is a matching C declaration of this subprogram in fe.h
-
- procedure Set_End_Location (N : Node_Id; S : Source_Ptr);
- -- N is an N_If_Statement or N_Case_Statement node. This procedure sets
- -- the End_Span field to correspond to the given value S. In other words,
- -- End_Span is set to the difference between S and Sloc (N), the starting
- -- location.
-
- function Get_Pragma_Arg (Arg : Node_Id) return Node_Id;
- -- Given an argument to a pragma Arg, this function returns the expression
- -- for the argument. This is Arg itself, or, in the case where Arg is a
- -- pragma argument association node, the expression from this node.
-
- -----------------------
- -- Utility Functions --
- -----------------------
-
- procedure Map_Pragma_Name (From, To : Name_Id);
- -- Used in the implementation of pragma Rename_Pragma. Maps pragma name
- -- From to pragma name To, so From can be used as a synonym for To.
-
- Too_Many_Pragma_Mappings : exception;
- -- Raised if Map_Pragma_Name is called too many times. We expect that few
- -- programs will use it at all, and those that do will use it approximately
- -- once or twice.
-
- function Pragma_Name (N : Node_Id) return Name_Id;
- -- Obtain the name of pragma N from the Chars field of its identifier. If
- -- the pragma has been renamed using Rename_Pragma, this routine returns
- -- the name of the renaming.
-
- function Pragma_Name_Unmapped (N : Node_Id) return Name_Id;
- -- Obtain the name of pragma N from the Chars field of its identifier. This
- -- form of name extraction does not take into account renamings performed
- -- by Rename_Pragma.
-
- -----------------------------
- -- Syntactic Parent Tables --
- -----------------------------
-
- -- These tables show for each node, and for each of the five fields,
- -- whether the corresponding field is syntactic (True) or semantic (False).
- -- Unused entries are also set to False.
-
- subtype Field_Num is Natural range 1 .. 5;
-
- Is_Syntactic_Field : constant array (Node_Kind, Field_Num) of Boolean := (
-
- -- Following entries can be built automatically from the sinfo sources
- -- using the makeisf utility (currently this program is in spitbol).
-
- N_Identifier =>
- (1 => True, -- Chars (Name1)
- 2 => False, -- Original_Discriminant (Node2-Sem)
- 3 => False, -- unused
- 4 => False, -- Entity (Node4-Sem)
- 5 => False), -- Etype (Node5-Sem)
-
- N_Integer_Literal =>
- (1 => False, -- unused
- 2 => False, -- Original_Entity (Node2-Sem)
- 3 => True, -- Intval (Uint3)
- 4 => False, -- unused
- 5 => False), -- Etype (Node5-Sem)
-
- N_Real_Literal =>
- (1 => False, -- unused
- 2 => False, -- Original_Entity (Node2-Sem)
- 3 => True, -- Realval (Ureal3)
- 4 => False, -- Corresponding_Integer_Value (Uint4-Sem)
- 5 => False), -- Etype (Node5-Sem)
-
- N_Character_Literal =>
- (1 => True, -- Chars (Name1)
- 2 => True, -- Char_Literal_Value (Uint2)
- 3 => False, -- unused
- 4 => False, -- Entity (Node4-Sem)
- 5 => False), -- Etype (Node5-Sem)
-
- N_String_Literal =>
- (1 => False, -- unused
- 2 => False, -- unused
- 3 => True, -- Strval (Str3)
- 4 => False, -- unused
- 5 => False), -- Etype (Node5-Sem)
-
- N_Pragma =>
- (1 => False, -- Next_Pragma (Node1-Sem)
- 2 => True, -- Pragma_Argument_Associations (List2)
- 3 => False, -- Corresponding_Aspect (Node3-Sem)
- 4 => True, -- Pragma_Identifier (Node4)
- 5 => False), -- Next_Rep_Item (Node5-Sem)
-
- N_Pragma_Argument_Association =>
- (1 => True, -- Chars (Name1)
- 2 => False, -- Expression_Copy (Node2-Sem)
- 3 => True, -- Expression (Node3)
- 4 => False, -- unused
- 5 => False), -- unused
-
- N_Defining_Identifier =>
- (1 => True, -- Chars (Name1)
- 2 => False, -- Next_Entity (Node2-Sem)
- 3 => False, -- Scope (Node3-Sem)
- 4 => False, -- unused
- 5 => False), -- Etype (Node5-Sem)
-
- N_Full_Type_Declaration =>
- (1 => True, -- Defining_Identifier (Node1)
- 2 => False, -- Incomplete_View (Node2-Sem)
- 3 => True, -- Type_Definition (Node3)
- 4 => True, -- Discriminant_Specifications (List4)
- 5 => False), -- unused
-
- N_Subtype_Declaration =>
- (1 => True, -- Defining_Identifier (Node1)
- 2 => False, -- unused
- 3 => False, -- unused
- 4 => False, -- Generic_Parent_Type (Node4-Sem)
- 5 => True), -- Subtype_Indication (Node5)
-
- N_Subtype_Indication =>
- (1 => False, -- unused
- 2 => False, -- unused
- 3 => True, -- Constraint (Node3)
- 4 => True, -- Subtype_Mark (Node4)
- 5 => False), -- Etype (Node5-Sem)
-
- N_Object_Declaration =>
- (1 => True, -- Defining_Identifier (Node1)
- 2 => False, -- Handler_List_Entry (Node2-Sem)
- 3 => True, -- Expression (Node3)
- 4 => True, -- Object_Definition (Node4)
- 5 => False), -- Corresponding_Generic_Association (Node5-Sem)
-
- N_Number_Declaration =>
- (1 => True, -- Defining_Identifier (Node1)
- 2 => False, -- unused
- 3 => True, -- Expression (Node3)
- 4 => False, -- unused
- 5 => False), -- unused
-
- N_Derived_Type_Definition =>
- (1 => False, -- unused
- 2 => True, -- Interface_List (List2)
- 3 => True, -- Record_Extension_Part (Node3)
- 4 => False, -- unused
- 5 => True), -- Subtype_Indication (Node5)
-
- N_Range_Constraint =>
- (1 => False, -- unused
- 2 => False, -- unused
- 3 => False, -- unused
- 4 => True, -- Range_Expression (Node4)
- 5 => False), -- unused
-
- N_Range =>
- (1 => True, -- Low_Bound (Node1)
- 2 => True, -- High_Bound (Node2)
- 3 => False, -- unused
- 4 => False, -- unused
- 5 => False), -- Etype (Node5-Sem)
-
- N_Enumeration_Type_Definition =>
- (1 => True, -- Literals (List1)
- 2 => False, -- unused
- 3 => False, -- unused
- 4 => True, -- End_Label (Node4)
- 5 => False), -- unused
-
- N_Defining_Character_Literal =>
- (1 => True, -- Chars (Name1)
- 2 => False, -- Next_Entity (Node2-Sem)
- 3 => False, -- Scope (Node3-Sem)
- 4 => False, -- unused
- 5 => False), -- Etype (Node5-Sem)
-
- N_Signed_Integer_Type_Definition =>
- (1 => True, -- Low_Bound (Node1)
- 2 => True, -- High_Bound (Node2)
- 3 => False, -- unused
- 4 => False, -- unused
- 5 => False), -- unused
-
- N_Modular_Type_Definition =>
- (1 => False, -- unused
- 2 => False, -- unused
- 3 => True, -- Expression (Node3)
- 4 => False, -- unused
- 5 => False), -- unused
-
- N_Floating_Point_Definition =>
- (1 => False, -- unused
- 2 => True, -- Digits_Expression (Node2)
- 3 => False, -- unused
- 4 => True, -- Real_Range_Specification (Node4)
- 5 => False), -- unused
-
- N_Real_Range_Specification =>
- (1 => True, -- Low_Bound (Node1)
- 2 => True, -- High_Bound (Node2)
- 3 => False, -- unused
- 4 => False, -- unused
- 5 => False), -- unused
-
- N_Ordinary_Fixed_Point_Definition =>
- (1 => False, -- unused
- 2 => False, -- unused
- 3 => True, -- Delta_Expression (Node3)
- 4 => True, -- Real_Range_Specification (Node4)
- 5 => False), -- unused
-
- N_Decimal_Fixed_Point_Definition =>
- (1 => False, -- unused
- 2 => True, -- Digits_Expression (Node2)
- 3 => True, -- Delta_Expression (Node3)
- 4 => True, -- Real_Range_Specification (Node4)
- 5 => False), -- unused
-
- N_Digits_Constraint =>
- (1 => False, -- unused
- 2 => True, -- Digits_Expression (Node2)
- 3 => False, -- unused
- 4 => True, -- Range_Constraint (Node4)
- 5 => False), -- unused
-
- N_Unconstrained_Array_Definition =>
- (1 => False, -- unused
- 2 => True, -- Subtype_Marks (List2)
- 3 => False, -- unused
- 4 => True, -- Component_Definition (Node4)
- 5 => False), -- unused
-
- N_Constrained_Array_Definition =>
- (1 => False, -- unused
- 2 => True, -- Discrete_Subtype_Definitions (List2)
- 3 => False, -- unused
- 4 => True, -- Component_Definition (Node4)
- 5 => False), -- unused
-
- N_Component_Definition =>
- (1 => False, -- unused
- 2 => False, -- unused
- 3 => True, -- Access_Definition (Node3)
- 4 => False, -- unused
- 5 => True), -- Subtype_Indication (Node5)
-
- N_Discriminant_Specification =>
- (1 => True, -- Defining_Identifier (Node1)
- 2 => False, -- unused
- 3 => True, -- Expression (Node3)
- 4 => False, -- unused
- 5 => True), -- Discriminant_Type (Node5)
-
- N_Index_Or_Discriminant_Constraint =>
- (1 => True, -- Constraints (List1)
- 2 => False, -- unused
- 3 => False, -- unused
- 4 => False, -- unused
- 5 => False), -- unused
-
- N_Discriminant_Association =>
- (1 => True, -- Selector_Names (List1)
- 2 => False, -- unused
- 3 => True, -- Expression (Node3)
- 4 => False, -- unused
- 5 => False), -- unused
-
- N_Record_Definition =>
- (1 => True, -- Component_List (Node1)
- 2 => True, -- Interface_List (List2)
- 3 => False, -- unused
- 4 => True, -- End_Label (Node4)
- 5 => False), -- unused
-
- N_Component_List =>
- (1 => False, -- unused
- 2 => False, -- unused
- 3 => True, -- Component_Items (List3)
- 4 => True, -- Variant_Part (Node4)
- 5 => False), -- unused
-
- N_Component_Declaration =>
- (1 => True, -- Defining_Identifier (Node1)
- 2 => False, -- unused
- 3 => True, -- Expression (Node3)
- 4 => True, -- Component_Definition (Node4)
- 5 => False), -- unused
-
- N_Variant_Part =>
- (1 => True, -- Variants (List1)
- 2 => True, -- Name (Node2)
- 3 => False, -- unused
- 4 => False, -- unused
- 5 => False), -- unused
-
- N_Variant =>
- (1 => True, -- Component_List (Node1)
- 2 => False, -- Enclosing_Variant (Node2-Sem)
- 3 => False, -- Present_Expr (Uint3-Sem)
- 4 => True, -- Discrete_Choices (List4)
- 5 => False), -- Dcheck_Function (Node5-Sem)
-
- N_Others_Choice =>
- (1 => False, -- Others_Discrete_Choices (List1-Sem)
- 2 => False, -- unused
- 3 => False, -- unused
- 4 => False, -- unused
- 5 => False), -- unused
-
- N_Access_To_Object_Definition =>
- (1 => False, -- unused
- 2 => False, -- unused
- 3 => False, -- unused
- 4 => False, -- unused
- 5 => True), -- Subtype_Indication (Node5)
-
- N_Access_Function_Definition =>
- (1 => False, -- unused
- 2 => False, -- unused
- 3 => True, -- Parameter_Specifications (List3)
- 4 => True, -- Result_Definition (Node4)
- 5 => False), -- unused
-
- N_Access_Procedure_Definition =>
- (1 => False, -- unused
- 2 => False, -- unused
- 3 => True, -- Parameter_Specifications (List3)
- 4 => False, -- unused
- 5 => False), -- unused
-
- N_Access_Definition =>
- (1 => False, -- unused
- 2 => False, -- unused
- 3 => True, -- Access_To_Subprogram_Definition (Node3)
- 4 => True, -- Subtype_Mark (Node4)
- 5 => False), -- unused
-
- N_Incomplete_Type_Declaration =>
- (1 => True, -- Defining_Identifier (Node1)
- 2 => False, -- unused
- 3 => False, -- unused
- 4 => True, -- Discriminant_Specifications (List4)
- 5 => False), -- Premature_Use
-
- N_Explicit_Dereference =>
- (1 => False, -- unused
- 2 => False, -- unused
- 3 => True, -- Prefix (Node3)
- 4 => False, -- Actual_Designated_Subtype (Node4-Sem)
- 5 => False), -- Etype (Node5-Sem)
-
- N_Indexed_Component =>
- (1 => True, -- Expressions (List1)
- 2 => False, -- unused
- 3 => True, -- Prefix (Node3)
- 4 => False, -- Generalized_Indexing (Node4-Sem)
- 5 => False), -- Etype (Node5-Sem)
-
- N_Slice =>
- (1 => False, -- unused
- 2 => False, -- unused
- 3 => True, -- Prefix (Node3)
- 4 => True, -- Discrete_Range (Node4)
- 5 => False), -- Etype (Node5-Sem)
-
- N_Selected_Component =>
- (1 => False, -- unused
- 2 => True, -- Selector_Name (Node2)
- 3 => True, -- Prefix (Node3)
- 4 => False, -- unused
- 5 => False), -- Etype (Node5-Sem)
-
- N_Attribute_Reference =>
- (1 => True, -- Expressions (List1)
- 2 => True, -- Attribute_Name (Name2)
- 3 => True, -- Prefix (Node3)
- 4 => False, -- Entity (Node4-Sem)
- 5 => False), -- Etype (Node5-Sem)
-
- N_Aggregate =>
- (1 => True, -- Expressions (List1)
- 2 => True, -- Component_Associations (List2)
- 3 => False, -- Aggregate_Bounds (Node3-Sem)
- 4 => False, -- unused
- 5 => False), -- Etype (Node5-Sem)
-
- N_Component_Association =>
- (1 => True, -- Choices (List1)
- 2 => False, -- unused
- 3 => True, -- Expression (Node3)
- 4 => False, -- unused
- 5 => True), -- Loop_Actions (List5-Sem);
-
- N_Iterated_Component_Association =>
- (1 => True, -- Defining_Identifier (Node1)
- 2 => True, -- Iterator_Specification
- 3 => True, -- Expression (Node3)
- 4 => True, -- Discrete_Choices (List4)
- 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, -- Unused
- 2 => True, -- Component_Associations (List2)
- 3 => True, -- Expression (Node3)
- 4 => False, -- Unused
- 5 => False), -- Etype (Node5-Sem)
-
- N_Extension_Aggregate =>
- (1 => True, -- Expressions (List1)
- 2 => True, -- Component_Associations (List2)
- 3 => True, -- Ancestor_Part (Node3)
- 4 => False, -- unused
- 5 => False), -- Etype (Node5-Sem)
-
- N_Null =>
- (1 => False, -- unused
- 2 => False, -- unused
- 3 => False, -- unused
- 4 => False, -- unused
- 5 => False), -- Etype (Node5-Sem)
-
- N_And_Then =>
- (1 => False, -- Actions (List1-Sem)
- 2 => True, -- Left_Opnd (Node2)
- 3 => True, -- Right_Opnd (Node3)
- 4 => False, -- unused
- 5 => False), -- Etype (Node5-Sem)
-
- N_Or_Else =>
- (1 => False, -- Actions (List1-Sem)
- 2 => True, -- Left_Opnd (Node2)
- 3 => True, -- Right_Opnd (Node3)
- 4 => False, -- unused
- 5 => False), -- Etype (Node5-Sem)
-
- N_In =>
- (1 => False, -- unused
- 2 => True, -- Left_Opnd (Node2)
- 3 => True, -- Right_Opnd (Node3)
- 4 => True, -- Alternatives (List4)
- 5 => False), -- Etype (Node5-Sem)
-
- N_Not_In =>
- (1 => False, -- unused
- 2 => True, -- Left_Opnd (Node2)
- 3 => True, -- Right_Opnd (Node3)
- 4 => True, -- Alternatives (List4)
- 5 => False), -- Etype (Node5-Sem)
-
- N_Op_And =>
- (1 => True, -- Chars (Name1)
- 2 => True, -- Left_Opnd (Node2)
- 3 => True, -- Right_Opnd (Node3)
- 4 => False, -- Entity (Node4-Sem)
- 5 => False), -- Etype (Node5-Sem)
-
- N_Op_Or =>
- (1 => True, -- Chars (Name1)
- 2 => True, -- Left_Opnd (Node2)
- 3 => True, -- Right_Opnd (Node3)
- 4 => False, -- Entity (Node4-Sem)
- 5 => False), -- Etype (Node5-Sem)
-
- N_Op_Xor =>
- (1 => True, -- Chars (Name1)
- 2 => True, -- Left_Opnd (Node2)
- 3 => True, -- Right_Opnd (Node3)
- 4 => False, -- Entity (Node4-Sem)
- 5 => False), -- Etype (Node5-Sem)
-
- N_Op_Eq =>
- (1 => True, -- Chars (Name1)
- 2 => True, -- Left_Opnd (Node2)
- 3 => True, -- Right_Opnd (Node3)
- 4 => False, -- Entity (Node4-Sem)
- 5 => False), -- Etype (Node5-Sem)
-
- N_Op_Ne =>
- (1 => True, -- Chars (Name1)
- 2 => True, -- Left_Opnd (Node2)
- 3 => True, -- Right_Opnd (Node3)
- 4 => False, -- Entity (Node4-Sem)
- 5 => False), -- Etype (Node5-Sem)
-
- N_Op_Lt =>
- (1 => True, -- Chars (Name1)
- 2 => True, -- Left_Opnd (Node2)
- 3 => True, -- Right_Opnd (Node3)
- 4 => False, -- Entity (Node4-Sem)
- 5 => False), -- Etype (Node5-Sem)
-
- N_Op_Le =>
- (1 => True, -- Chars (Name1)
- 2 => True, -- Left_Opnd (Node2)
- 3 => True, -- Right_Opnd (Node3)
- 4 => False, -- Entity (Node4-Sem)
- 5 => False), -- Etype (Node5-Sem)
-
- N_Op_Gt =>
- (1 => True, -- Chars (Name1)
- 2 => True, -- Left_Opnd (Node2)
- 3 => True, -- Right_Opnd (Node3)
- 4 => False, -- Entity (Node4-Sem)
- 5 => False), -- Etype (Node5-Sem)
-
- N_Op_Ge =>
- (1 => True, -- Chars (Name1)
- 2 => True, -- Left_Opnd (Node2)
- 3 => True, -- Right_Opnd (Node3)
- 4 => False, -- Entity (Node4-Sem)
- 5 => False), -- Etype (Node5-Sem)
-
- N_Op_Add =>
- (1 => True, -- Chars (Name1)
- 2 => True, -- Left_Opnd (Node2)
- 3 => True, -- Right_Opnd (Node3)
- 4 => False, -- Entity (Node4-Sem)
- 5 => False), -- Etype (Node5-Sem)
-
- N_Op_Subtract =>
- (1 => True, -- Chars (Name1)
- 2 => True, -- Left_Opnd (Node2)
- 3 => True, -- Right_Opnd (Node3)
- 4 => False, -- Entity (Node4-Sem)
- 5 => False), -- Etype (Node5-Sem)
-
- N_Op_Concat =>
- (1 => True, -- Chars (Name1)
- 2 => True, -- Left_Opnd (Node2)
- 3 => True, -- Right_Opnd (Node3)
- 4 => False, -- Entity (Node4-Sem)
- 5 => False), -- Etype (Node5-Sem)
-
- N_Op_Multiply =>
- (1 => True, -- Chars (Name1)
- 2 => True, -- Left_Opnd (Node2)
- 3 => True, -- Right_Opnd (Node3)
- 4 => False, -- Entity (Node4-Sem)
- 5 => False), -- Etype (Node5-Sem)
-
- N_Op_Divide =>
- (1 => True, -- Chars (Name1)
- 2 => True, -- Left_Opnd (Node2)
- 3 => True, -- Right_Opnd (Node3)
- 4 => False, -- Entity (Node4-Sem)
- 5 => False), -- Etype (Node5-Sem)
-
- N_Op_Mod =>
- (1 => True, -- Chars (Name1)
- 2 => True, -- Left_Opnd (Node2)
- 3 => True, -- Right_Opnd (Node3)
- 4 => False, -- Entity (Node4-Sem)
- 5 => False), -- Etype (Node5-Sem)
-
- N_Op_Rem =>
- (1 => True, -- Chars (Name1)
- 2 => True, -- Left_Opnd (Node2)
- 3 => True, -- Right_Opnd (Node3)
- 4 => False, -- Entity (Node4-Sem)
- 5 => False), -- Etype (Node5-Sem)
-
- N_Op_Expon =>
- (1 => True, -- Chars (Name1)
- 2 => True, -- Left_Opnd (Node2)
- 3 => True, -- Right_Opnd (Node3)
- 4 => False, -- Entity (Node4-Sem)
- 5 => False), -- Etype (Node5-Sem)
-
- N_Op_Plus =>
- (1 => True, -- Chars (Name1)
- 2 => False, -- unused
- 3 => True, -- Right_Opnd (Node3)
- 4 => False, -- Entity (Node4-Sem)
- 5 => False), -- Etype (Node5-Sem)
-
- N_Op_Minus =>
- (1 => True, -- Chars (Name1)
- 2 => False, -- unused
- 3 => True, -- Right_Opnd (Node3)
- 4 => False, -- Entity (Node4-Sem)
- 5 => False), -- Etype (Node5-Sem)
-
- N_Op_Abs =>
- (1 => True, -- Chars (Name1)
- 2 => False, -- unused
- 3 => True, -- Right_Opnd (Node3)
- 4 => False, -- Entity (Node4-Sem)
- 5 => False), -- Etype (Node5-Sem)
-
- N_Op_Not =>
- (1 => True, -- Chars (Name1)
- 2 => False, -- unused
- 3 => True, -- Right_Opnd (Node3)
- 4 => False, -- Entity (Node4-Sem)
- 5 => False), -- Etype (Node5-Sem)
-
- N_Type_Conversion =>
- (1 => False, -- unused
- 2 => False, -- unused
- 3 => True, -- Expression (Node3)
- 4 => True, -- Subtype_Mark (Node4)
- 5 => False), -- Etype (Node5-Sem)
-
- N_Qualified_Expression =>
- (1 => False, -- unused
- 2 => False, -- unused
- 3 => True, -- Expression (Node3)
- 4 => True, -- Subtype_Mark (Node4)
- 5 => False), -- Etype (Node5-Sem)
-
- N_Quantified_Expression =>
- (1 => True, -- Condition (Node1)
- 2 => True, -- Iterator_Specification (Node2)
- 3 => False, -- unused
- 4 => True, -- Loop_Parameter_Specification (Node4)
- 5 => False), -- unused
-
- N_Allocator =>
- (1 => False, -- Storage_Pool (Node1-Sem)
- 2 => False, -- Procedure_To_Call (Node2-Sem)
- 3 => True, -- Expression (Node3)
- 4 => True, -- Subpool_Handle_Name (Node4)
- 5 => False), -- Etype (Node5-Sem)
-
- N_Null_Statement =>
- (1 => False, -- unused
- 2 => False, -- unused
- 3 => False, -- unused
- 4 => False, -- unused
- 5 => False), -- unused
-
- N_Label =>
- (1 => True, -- Identifier (Node1)
- 2 => False, -- unused
- 3 => False, -- unused
- 4 => False, -- unused
- 5 => False), -- unused
-
- N_Assignment_Statement =>
- (1 => False, -- unused
- 2 => True, -- Name (Node2)
- 3 => True, -- Expression (Node3)
- 4 => False, -- unused
- 5 => False), -- unused
-
- N_Target_Name =>
- (1 => False, -- unused
- 2 => False, -- unused
- 3 => False, -- unused
- 4 => False, -- unused
- 5 => False), -- Etype (Node5-Sem)
-
- N_If_Statement =>
- (1 => True, -- Condition (Node1)
- 2 => True, -- Then_Statements (List2)
- 3 => True, -- Elsif_Parts (List3)
- 4 => True, -- Else_Statements (List4)
- 5 => True), -- End_Span (Uint5)
-
- N_Elsif_Part =>
- (1 => True, -- Condition (Node1)
- 2 => True, -- Then_Statements (List2)
- 3 => False, -- Condition_Actions (List3-Sem)
- 4 => False, -- unused
- 5 => False), -- unused
-
- N_Case_Expression =>
- (1 => False, -- unused
- 2 => False, -- unused
- 3 => True, -- Expression (Node3)
- 4 => True, -- Alternatives (List4)
- 5 => False), -- Etype (Node5-Sem)
-
- N_Case_Expression_Alternative =>
- (1 => False, -- Actions (List1-Sem)
- 2 => False, -- unused
- 3 => True, -- Expression (Node3)
- 4 => True, -- Discrete_Choices (List4)
- 5 => False), -- unused
-
- N_Case_Statement =>
- (1 => False, -- unused
- 2 => False, -- unused
- 3 => True, -- Expression (Node3)
- 4 => True, -- Alternatives (List4)
- 5 => True), -- End_Span (Uint5)
-
- N_Case_Statement_Alternative =>
- (1 => False, -- unused
- 2 => False, -- unused
- 3 => True, -- Statements (List3)
- 4 => True, -- Discrete_Choices (List4)
- 5 => False), -- unused
-
- N_Loop_Statement =>
- (1 => True, -- Identifier (Node1)
- 2 => True, -- Iteration_Scheme (Node2)
- 3 => True, -- Statements (List3)
- 4 => True, -- End_Label (Node4)
- 5 => False), -- unused
-
- N_Iteration_Scheme =>
- (1 => True, -- Condition (Node1)
- 2 => True, -- Iterator_Specification (Node2)
- 3 => False, -- Condition_Actions (List3-Sem)
- 4 => True, -- Loop_Parameter_Specification (Node4)
- 5 => False), -- unused
-
- N_Loop_Parameter_Specification =>
- (1 => True, -- Defining_Identifier (Node1)
- 2 => False, -- unused
- 3 => False, -- unused
- 4 => True, -- Discrete_Subtype_Definition (Node4)
- 5 => True), -- Iterator_Filter (Node5)
-
- N_Iterator_Specification =>
- (1 => True, -- Defining_Identifier (Node1)
- 2 => True, -- Name (Node2)
- 3 => False, -- Unused
- 4 => False, -- Unused
- 5 => True), -- Subtype_Indication (Node5)
-
- N_Block_Statement =>
- (1 => True, -- Identifier (Node1)
- 2 => True, -- Declarations (List2)
- 3 => False, -- Activation_Chain_Entity (Node3-Sem)
- 4 => True, -- Handled_Statement_Sequence (Node4)
- 5 => False), -- unused
-
- N_Exit_Statement =>
- (1 => True, -- Condition (Node1)
- 2 => True, -- Name (Node2)
- 3 => False, -- unused
- 4 => False, -- unused
- 5 => False), -- unused
-
- N_Goto_Statement =>
- (1 => False, -- unused
- 2 => True, -- Name (Node2)
- 3 => False, -- unused
- 4 => False, -- unused
- 5 => False), -- unused
-
- N_Subprogram_Declaration =>
- (1 => True, -- Specification (Node1)
- 2 => False, -- unused
- 3 => False, -- Body_To_Inline (Node3-Sem)
- 4 => False, -- Parent_Spec (Node4-Sem)
- 5 => False), -- Corresponding_Body (Node5-Sem)
-
- N_Abstract_Subprogram_Declaration =>
- (1 => True, -- Specification (Node1)
- 2 => False, -- unused
- 3 => False, -- unused
- 4 => False, -- unused
- 5 => False), -- unused
-
- N_Function_Specification =>
- (1 => True, -- Defining_Unit_Name (Node1)
- 2 => False, -- unused
- 3 => True, -- Parameter_Specifications (List3)
- 4 => True, -- Result_Definition (Node4)
- 5 => False), -- Generic_Parent (Node5-Sem)
-
- N_Procedure_Specification =>
- (1 => True, -- Defining_Unit_Name (Node1)
- 2 => False, -- Null_Statement (Node2-Sem)
- 3 => True, -- Parameter_Specifications (List3)
- 4 => False, -- unused
- 5 => False), -- Generic_Parent (Node5-Sem)
-
- N_Designator =>
- (1 => True, -- Identifier (Node1)
- 2 => True, -- Name (Node2)
- 3 => False, -- unused
- 4 => False, -- unused
- 5 => False), -- unused
-
- N_Defining_Program_Unit_Name =>
- (1 => True, -- Defining_Identifier (Node1)
- 2 => True, -- Name (Node2)
- 3 => False, -- unused
- 4 => False, -- unused
- 5 => False), -- unused
-
- N_Operator_Symbol =>
- (1 => True, -- Chars (Name1)
- 2 => False, -- unused
- 3 => True, -- Strval (Str3)
- 4 => False, -- Entity (Node4-Sem)
- 5 => False), -- Etype (Node5-Sem)
-
- N_Defining_Operator_Symbol =>
- (1 => True, -- Chars (Name1)
- 2 => False, -- Next_Entity (Node2-Sem)
- 3 => False, -- Scope (Node3-Sem)
- 4 => False, -- unused
- 5 => False), -- Etype (Node5-Sem)
-
- N_Parameter_Specification =>
- (1 => True, -- Defining_Identifier (Node1)
- 2 => True, -- Parameter_Type (Node2)
- 3 => True, -- Expression (Node3)
- 4 => False, -- unused
- 5 => False), -- Default_Expression (Node5-Sem)
-
- N_Subprogram_Body =>
- (1 => True, -- Specification (Node1)
- 2 => True, -- Declarations (List2)
- 3 => False, -- Activation_Chain_Entity (Node3-Sem)
- 4 => True, -- Handled_Statement_Sequence (Node4)
- 5 => False), -- Corresponding_Spec (Node5-Sem)
-
- N_Expression_Function =>
- (1 => True, -- Specification (Node1)
- 2 => False, -- unused
- 3 => True, -- Expression (Node3)
- 4 => False, -- unused
- 5 => False), -- unused
-
- N_Procedure_Call_Statement =>
- (1 => False, -- Controlling_Argument (Node1-Sem)
- 2 => True, -- Name (Node2)
- 3 => True, -- Parameter_Associations (List3)
- 4 => False, -- First_Named_Actual (Node4-Sem)
- 5 => False), -- Etype (Node5-Sem)
-
- N_Function_Call =>
- (1 => False, -- Controlling_Argument (Node1-Sem)
- 2 => True, -- Name (Node2)
- 3 => True, -- Parameter_Associations (List3)
- 4 => False, -- First_Named_Actual (Node4-Sem)
- 5 => False), -- Etype (Node5-Sem)
-
- N_Parameter_Association =>
- (1 => False, -- unused
- 2 => True, -- Selector_Name (Node2)
- 3 => True, -- Explicit_Actual_Parameter (Node3)
- 4 => False, -- Next_Named_Actual (Node4-Sem)
- 5 => False), -- unused
-
- N_Simple_Return_Statement =>
- (1 => False, -- Storage_Pool (Node1-Sem)
- 2 => False, -- Procedure_To_Call (Node2-Sem)
- 3 => True, -- Expression (Node3)
- 4 => False, -- unused
- 5 => False), -- Return_Statement_Entity (Node5-Sem)
-
- N_Extended_Return_Statement =>
- (1 => False, -- Storage_Pool (Node1-Sem)
- 2 => False, -- Procedure_To_Call (Node2-Sem)
- 3 => True, -- Return_Object_Declarations (List3)
- 4 => True, -- Handled_Statement_Sequence (Node4)
- 5 => False), -- Return_Statement_Entity (Node5-Sem)
-
- N_Package_Declaration =>
- (1 => True, -- Specification (Node1)
- 2 => False, -- unused
- 3 => False, -- Activation_Chain_Entity (Node3-Sem)
- 4 => False, -- Parent_Spec (Node4-Sem)
- 5 => False), -- Corresponding_Body (Node5-Sem)
-
- N_Package_Specification =>
- (1 => True, -- Defining_Unit_Name (Node1)
- 2 => True, -- Visible_Declarations (List2)
- 3 => True, -- Private_Declarations (List3)
- 4 => True, -- End_Label (Node4)
- 5 => False), -- Generic_Parent (Node5-Sem)
-
- N_Package_Body =>
- (1 => True, -- Defining_Unit_Name (Node1)
- 2 => True, -- Declarations (List2)
- 3 => False, -- unused
- 4 => True, -- Handled_Statement_Sequence (Node4)
- 5 => False), -- Corresponding_Spec (Node5-Sem)
-
- N_Private_Type_Declaration =>
- (1 => True, -- Defining_Identifier (Node1)
- 2 => False, -- unused
- 3 => False, -- unused
- 4 => True, -- Discriminant_Specifications (List4)
- 5 => False), -- unused
-
- N_Private_Extension_Declaration =>
- (1 => True, -- Defining_Identifier (Node1)
- 2 => True, -- Interface_List (List2)
- 3 => False, -- unused
- 4 => True, -- Discriminant_Specifications (List4)
- 5 => True), -- Subtype_Indication (Node5)
-
- N_Use_Package_Clause =>
- (1 => False, -- Prev_Use_Clause (Node1-Sem)
- 2 => True, -- Name (Node2)
- 3 => False, -- Next_Use_Clause (Node3-Sem)
- 4 => False, -- Associated_Node (Node4-Sem)
- 5 => False), -- Hidden_By_Use_Clause (Elist5-Sem)
-
- N_Use_Type_Clause =>
- (1 => False, -- Prev_Use_Clause (Node1-Sem)
- 2 => False, -- Used_Operations (Elist2-Sem)
- 3 => False, -- Next_Use_Clause (Node3-Sem)
- 4 => True, -- Subtype_Mark (Node4)
- 5 => False), -- Hidden_By_Use_Clause (Elist5-Sem)
-
- N_Object_Renaming_Declaration =>
- (1 => True, -- Defining_Identifier (Node1)
- 2 => True, -- Name (Node2)
- 3 => True, -- Access_Definition (Node3)
- 4 => True, -- Subtype_Mark (Node4)
- 5 => False), -- Corresponding_Generic_Association (Node5-Sem)
-
- N_Exception_Renaming_Declaration =>
- (1 => True, -- Defining_Identifier (Node1)
- 2 => True, -- Name (Node2)
- 3 => False, -- unused
- 4 => False, -- unused
- 5 => False), -- unused
-
- N_Package_Renaming_Declaration =>
- (1 => True, -- Defining_Unit_Name (Node1)
- 2 => True, -- Name (Node2)
- 3 => False, -- unused
- 4 => False, -- Parent_Spec (Node4-Sem)
- 5 => False), -- unused
-
- N_Subprogram_Renaming_Declaration =>
- (1 => True, -- Specification (Node1)
- 2 => True, -- Name (Node2)
- 3 => False, -- Corresponding_Formal_Spec (Node3-Sem)
- 4 => False, -- Parent_Spec (Node4-Sem)
- 5 => False), -- Corresponding_Spec (Node5-Sem)
-
- N_Generic_Package_Renaming_Declaration =>
- (1 => True, -- Defining_Unit_Name (Node1)
- 2 => True, -- Name (Node2)
- 3 => False, -- unused
- 4 => False, -- Parent_Spec (Node4-Sem)
- 5 => False), -- unused
-
- N_Generic_Procedure_Renaming_Declaration =>
- (1 => True, -- Defining_Unit_Name (Node1)
- 2 => True, -- Name (Node2)
- 3 => False, -- unused
- 4 => False, -- Parent_Spec (Node4-Sem)
- 5 => False), -- unused
-
- N_Generic_Function_Renaming_Declaration =>
- (1 => True, -- Defining_Unit_Name (Node1)
- 2 => True, -- Name (Node2)
- 3 => False, -- unused
- 4 => False, -- Parent_Spec (Node4-Sem)
- 5 => False), -- unused
-
- N_Task_Type_Declaration =>
- (1 => True, -- Defining_Identifier (Node1)
- 2 => True, -- Interface_List (List2)
- 3 => True, -- Task_Definition (Node3)
- 4 => True, -- Discriminant_Specifications (List4)
- 5 => False), -- Corresponding_Body (Node5-Sem)
-
- N_Single_Task_Declaration =>
- (1 => True, -- Defining_Identifier (Node1)
- 2 => True, -- Interface_List (List2)
- 3 => True, -- Task_Definition (Node3)
- 4 => False, -- unused
- 5 => False), -- unused
-
- N_Task_Definition =>
- (1 => False, -- unused
- 2 => True, -- Visible_Declarations (List2)
- 3 => True, -- Private_Declarations (List3)
- 4 => True, -- End_Label (Node4)
- 5 => False), -- unused
-
- N_Task_Body =>
- (1 => True, -- Defining_Identifier (Node1)
- 2 => True, -- Declarations (List2)
- 3 => False, -- Activation_Chain_Entity (Node3-Sem)
- 4 => True, -- Handled_Statement_Sequence (Node4)
- 5 => False), -- Corresponding_Spec (Node5-Sem)
-
- N_Protected_Type_Declaration =>
- (1 => True, -- Defining_Identifier (Node1)
- 2 => True, -- Interface_List (List2)
- 3 => True, -- Protected_Definition (Node3)
- 4 => True, -- Discriminant_Specifications (List4)
- 5 => False), -- Corresponding_Body (Node5-Sem)
-
- N_Single_Protected_Declaration =>
- (1 => True, -- Defining_Identifier (Node1)
- 2 => True, -- Interface_List (List2)
- 3 => True, -- Protected_Definition (Node3)
- 4 => False, -- unused
- 5 => False), -- unused
-
- N_Protected_Definition =>
- (1 => False, -- unused
- 2 => True, -- Visible_Declarations (List2)
- 3 => True, -- Private_Declarations (List3)
- 4 => True, -- End_Label (Node4)
- 5 => False), -- unused
-
- N_Protected_Body =>
- (1 => True, -- Defining_Identifier (Node1)
- 2 => True, -- Declarations (List2)
- 3 => False, -- unused
- 4 => True, -- End_Label (Node4)
- 5 => False), -- Corresponding_Spec (Node5-Sem)
-
- N_Entry_Declaration =>
- (1 => True, -- Defining_Identifier (Node1)
- 2 => False, -- unused
- 3 => True, -- Parameter_Specifications (List3)
- 4 => True, -- Discrete_Subtype_Definition (Node4)
- 5 => False), -- Corresponding_Body (Node5-Sem)
-
- N_Accept_Statement =>
- (1 => True, -- Entry_Direct_Name (Node1)
- 2 => True, -- Declarations (List2)
- 3 => True, -- Parameter_Specifications (List3)
- 4 => True, -- Handled_Statement_Sequence (Node4)
- 5 => True), -- Entry_Index (Node5)
-
- N_Entry_Body =>
- (1 => True, -- Defining_Identifier (Node1)
- 2 => True, -- Declarations (List2)
- 3 => False, -- Activation_Chain_Entity (Node3-Sem)
- 4 => True, -- Handled_Statement_Sequence (Node4)
- 5 => True), -- Entry_Body_Formal_Part (Node5)
-
- N_Entry_Body_Formal_Part =>
- (1 => True, -- Condition (Node1)
- 2 => False, -- unused
- 3 => True, -- Parameter_Specifications (List3)
- 4 => True, -- Entry_Index_Specification (Node4)
- 5 => False), -- unused
-
- N_Entry_Index_Specification =>
- (1 => True, -- Defining_Identifier (Node1)
- 2 => False, -- unused
- 3 => False, -- unused
- 4 => True, -- Discrete_Subtype_Definition (Node4)
- 5 => False), -- unused
-
- N_Entry_Call_Statement =>
- (1 => False, -- unused
- 2 => True, -- Name (Node2)
- 3 => True, -- Parameter_Associations (List3)
- 4 => False, -- First_Named_Actual (Node4-Sem)
- 5 => False), -- unused
-
- N_Requeue_Statement =>
- (1 => False, -- unused
- 2 => True, -- Name (Node2)
- 3 => False, -- unused
- 4 => False, -- unused
- 5 => False), -- unused
-
- N_Delay_Until_Statement =>
- (1 => False, -- unused
- 2 => False, -- unused
- 3 => True, -- Expression (Node3)
- 4 => False, -- unused
- 5 => False), -- unused
-
- N_Delay_Relative_Statement =>
- (1 => False, -- unused
- 2 => False, -- unused
- 3 => True, -- Expression (Node3)
- 4 => False, -- unused
- 5 => False), -- unused
-
- N_Selective_Accept =>
- (1 => True, -- Select_Alternatives (List1)
- 2 => False, -- unused
- 3 => False, -- unused
- 4 => True, -- Else_Statements (List4)
- 5 => False), -- unused
-
- N_Accept_Alternative =>
- (1 => True, -- Condition (Node1)
- 2 => True, -- Accept_Statement (Node2)
- 3 => True, -- Statements (List3)
- 4 => True, -- Pragmas_Before (List4)
- 5 => False), -- Accept_Handler_Records (List5-Sem)
-
- N_Delay_Alternative =>
- (1 => True, -- Condition (Node1)
- 2 => True, -- Delay_Statement (Node2)
- 3 => True, -- Statements (List3)
- 4 => True, -- Pragmas_Before (List4)
- 5 => False), -- unused
-
- N_Terminate_Alternative =>
- (1 => True, -- Condition (Node1)
- 2 => False, -- unused
- 3 => False, -- unused
- 4 => True, -- Pragmas_Before (List4)
- 5 => True), -- Pragmas_After (List5)
-
- N_Timed_Entry_Call =>
- (1 => True, -- Entry_Call_Alternative (Node1)
- 2 => False, -- unused
- 3 => False, -- unused
- 4 => True, -- Delay_Alternative (Node4)
- 5 => False), -- unused
-
- N_Entry_Call_Alternative =>
- (1 => True, -- Entry_Call_Statement (Node1)
- 2 => False, -- unused
- 3 => True, -- Statements (List3)
- 4 => True, -- Pragmas_Before (List4)
- 5 => False), -- unused
-
- N_Conditional_Entry_Call =>
- (1 => True, -- Entry_Call_Alternative (Node1)
- 2 => False, -- unused
- 3 => False, -- unused
- 4 => True, -- Else_Statements (List4)
- 5 => False), -- unused
-
- N_Asynchronous_Select =>
- (1 => True, -- Triggering_Alternative (Node1)
- 2 => True, -- Abortable_Part (Node2)
- 3 => False, -- unused
- 4 => False, -- unused
- 5 => False), -- unused
-
- N_Triggering_Alternative =>
- (1 => True, -- Triggering_Statement (Node1)
- 2 => False, -- unused
- 3 => True, -- Statements (List3)
- 4 => True, -- Pragmas_Before (List4)
- 5 => False), -- unused
-
- N_Abortable_Part =>
- (1 => False, -- unused
- 2 => False, -- unused
- 3 => True, -- Statements (List3)
- 4 => False, -- unused
- 5 => False), -- unused
-
- N_Abort_Statement =>
- (1 => False, -- unused
- 2 => True, -- Names (List2)
- 3 => False, -- unused
- 4 => False, -- unused
- 5 => False), -- unused
-
- N_Compilation_Unit =>
- (1 => True, -- Context_Items (List1)
- 2 => True, -- Unit (Node2)
- 3 => False, -- First_Inlined_Subprogram (Node3-Sem)
- 4 => False, -- Library_Unit (Node4-Sem)
- 5 => True), -- Aux_Decls_Node (Node5)
-
- N_Compilation_Unit_Aux =>
- (1 => True, -- Actions (List1)
- 2 => True, -- Declarations (List2)
- 3 => False, -- Default_Storage_Pool (Node3)
- 4 => True, -- Config_Pragmas (List4)
- 5 => True), -- Pragmas_After (List5)
-
- N_With_Clause =>
- (1 => False, -- unused
- 2 => True, -- Name (Node2)
- 3 => False, -- unused
- 4 => False, -- Library_Unit (Node4-Sem)
- 5 => False), -- Corresponding_Spec (Node5-Sem)
-
- N_Subprogram_Body_Stub =>
- (1 => True, -- Specification (Node1)
- 2 => False, -- Corresponding_Spec_Of_Stub (Node2-Sem)
- 3 => False, -- unused
- 4 => False, -- Library_Unit (Node4-Sem)
- 5 => False), -- Corresponding_Body (Node5-Sem)
-
- N_Package_Body_Stub =>
- (1 => True, -- Defining_Identifier (Node1)
- 2 => False, -- Corresponding_Spec_Of_Stub (Node2-Sem)
- 3 => False, -- unused
- 4 => False, -- Library_Unit (Node4-Sem)
- 5 => False), -- Corresponding_Body (Node5-Sem)
-
- N_Task_Body_Stub =>
- (1 => True, -- Defining_Identifier (Node1)
- 2 => False, -- Corresponding_Spec_Of_Stub (Node2-Sem)
- 3 => False, -- unused
- 4 => False, -- Library_Unit (Node4-Sem)
- 5 => False), -- Corresponding_Body (Node5-Sem)
-
- N_Protected_Body_Stub =>
- (1 => True, -- Defining_Identifier (Node1)
- 2 => False, -- Corresponding_Spec_Of_Stub (Node2-Sem)
- 3 => False, -- unused
- 4 => False, -- Library_Unit (Node4-Sem)
- 5 => False), -- Corresponding_Body (Node5-Sem)
-
- N_Subunit =>
- (1 => True, -- Proper_Body (Node1)
- 2 => True, -- Name (Node2)
- 3 => False, -- Corresponding_Stub (Node3-Sem)
- 4 => False, -- unused
- 5 => False), -- unused
-
- N_Exception_Declaration =>
- (1 => True, -- Defining_Identifier (Node1)
- 2 => False, -- unused
- 3 => False, -- Expression (Node3-Sem)
- 4 => False, -- unused
- 5 => False), -- unused
-
- N_Handled_Sequence_Of_Statements =>
- (1 => True, -- At_End_Proc (Node1)
- 2 => False, -- First_Real_Statement (Node2-Sem)
- 3 => True, -- Statements (List3)
- 4 => True, -- End_Label (Node4)
- 5 => True), -- Exception_Handlers (List5)
-
- N_Exception_Handler =>
- (1 => False, -- Local_Raise_Statements (Elist1)
- 2 => True, -- Choice_Parameter (Node2)
- 3 => True, -- Statements (List3)
- 4 => True, -- Exception_Choices (List4)
- 5 => False), -- Exception_Label (Node5)
-
- N_Raise_Statement =>
- (1 => False, -- unused
- 2 => True, -- Name (Node2)
- 3 => True, -- Expression (Node3)
- 4 => False, -- unused
- 5 => False), -- unused
-
- N_Raise_Expression =>
- (1 => False, -- unused
- 2 => True, -- Name (Node2)
- 3 => True, -- Expression (Node3)
- 4 => False, -- unused
- 5 => False), -- Etype (Node5-Sem)
-
- N_Generic_Subprogram_Declaration =>
- (1 => True, -- Specification (Node1)
- 2 => True, -- Generic_Formal_Declarations (List2)
- 3 => False, -- unused
- 4 => False, -- Parent_Spec (Node4-Sem)
- 5 => False), -- Corresponding_Body (Node5-Sem)
-
- N_Generic_Package_Declaration =>
- (1 => True, -- Specification (Node1)
- 2 => True, -- Generic_Formal_Declarations (List2)
- 3 => False, -- Activation_Chain_Entity (Node3-Sem)
- 4 => False, -- Parent_Spec (Node4-Sem)
- 5 => False), -- Corresponding_Body (Node5-Sem)
-
- N_Package_Instantiation =>
- (1 => True, -- Defining_Unit_Name (Node1)
- 2 => True, -- Name (Node2)
- 3 => True, -- Generic_Associations (List3)
- 4 => False, -- Parent_Spec (Node4-Sem)
- 5 => False), -- Instance_Spec (Node5-Sem)
-
- N_Procedure_Instantiation =>
- (1 => True, -- Defining_Unit_Name (Node1)
- 2 => True, -- Name (Node2)
- 3 => True, -- Generic_Associations (List3)
- 4 => False, -- Parent_Spec (Node4-Sem)
- 5 => False), -- Instance_Spec (Node5-Sem)
-
- N_Function_Instantiation =>
- (1 => True, -- Defining_Unit_Name (Node1)
- 2 => True, -- Name (Node2)
- 3 => True, -- Generic_Associations (List3)
- 4 => False, -- Parent_Spec (Node4-Sem)
- 5 => False), -- Instance_Spec (Node5-Sem)
-
- N_Generic_Association =>
- (1 => True, -- Explicit_Generic_Actual_Parameter (Node1)
- 2 => True, -- Selector_Name (Node2)
- 3 => False, -- unused
- 4 => False, -- unused
- 5 => False), -- unused
-
- N_Formal_Object_Declaration =>
- (1 => True, -- Defining_Identifier (Node1)
- 2 => False, -- unused
- 3 => True, -- Access_Definition (Node3)
- 4 => True, -- Subtype_Mark (Node4)
- 5 => True), -- Default_Expression (Node5)
-
- N_Formal_Type_Declaration =>
- (1 => True, -- Defining_Identifier (Node1)
- 2 => False, -- unused
- 3 => True, -- Formal_Type_Definition (Node3)
- 4 => True, -- Discriminant_Specifications (List4)
- 5 => False), -- unused
-
- N_Formal_Private_Type_Definition =>
- (1 => False, -- unused
- 2 => False, -- unused
- 3 => False, -- unused
- 4 => False, -- unused
- 5 => False), -- unused
-
- N_Formal_Incomplete_Type_Definition =>
- (1 => False, -- unused
- 2 => False, -- unused
- 3 => False, -- unused
- 4 => False, -- unused
- 5 => False), -- unused
-
- N_Formal_Derived_Type_Definition =>
- (1 => False, -- unused
- 2 => True, -- Interface_List (List2)
- 3 => False, -- unused
- 4 => True, -- Subtype_Mark (Node4)
- 5 => False), -- unused
-
- N_Formal_Discrete_Type_Definition =>
- (1 => False, -- unused
- 2 => False, -- unused
- 3 => False, -- unused
- 4 => False, -- unused
- 5 => False), -- unused
-
- N_Formal_Signed_Integer_Type_Definition =>
- (1 => False, -- unused
- 2 => False, -- unused
- 3 => False, -- unused
- 4 => False, -- unused
- 5 => False), -- unused
-
- N_Formal_Modular_Type_Definition =>
- (1 => False, -- unused
- 2 => False, -- unused
- 3 => False, -- unused
- 4 => False, -- unused
- 5 => False), -- unused
-
- N_Formal_Floating_Point_Definition =>
- (1 => False, -- unused
- 2 => False, -- unused
- 3 => False, -- unused
- 4 => False, -- unused
- 5 => False), -- unused
-
- N_Formal_Ordinary_Fixed_Point_Definition =>
- (1 => False, -- unused
- 2 => False, -- unused
- 3 => False, -- unused
- 4 => False, -- unused
- 5 => False), -- unused
-
- N_Formal_Decimal_Fixed_Point_Definition =>
- (1 => False, -- unused
- 2 => False, -- unused
- 3 => False, -- unused
- 4 => False, -- unused
- 5 => False), -- unused
-
- N_Formal_Concrete_Subprogram_Declaration =>
- (1 => True, -- Specification (Node1)
- 2 => True, -- Default_Name (Node2)
- 3 => False, -- unused
- 4 => False, -- unused
- 5 => False), -- unused
-
- N_Formal_Abstract_Subprogram_Declaration =>
- (1 => True, -- Specification (Node1)
- 2 => True, -- Default_Name (Node2)
- 3 => False, -- unused
- 4 => False, -- unused
- 5 => False), -- unused
-
- N_Formal_Package_Declaration =>
- (1 => True, -- Defining_Identifier (Node1)
- 2 => True, -- Name (Node2)
- 3 => True, -- Generic_Associations (List3)
- 4 => False, -- unused
- 5 => False), -- Instance_Spec (Node5-Sem)
-
- N_Attribute_Definition_Clause =>
- (1 => True, -- Chars (Name1)
- 2 => True, -- Name (Node2)
- 3 => True, -- Expression (Node3)
- 4 => False, -- unused
- 5 => False), -- Next_Rep_Item (Node5-Sem)
-
- N_Aspect_Specification =>
- (1 => True, -- Identifier (Node1)
- 2 => False, -- Aspect_Rep_Item (Node2-Sem)
- 3 => True, -- Expression (Node3)
- 4 => False, -- Entity (Node4-Sem)
- 5 => False), -- Next_Rep_Item (Node5-Sem)
-
- N_Enumeration_Representation_Clause =>
- (1 => True, -- Identifier (Node1)
- 2 => False, -- unused
- 3 => True, -- Array_Aggregate (Node3)
- 4 => False, -- unused
- 5 => False), -- Next_Rep_Item (Node5-Sem)
-
- N_Record_Representation_Clause =>
- (1 => True, -- Identifier (Node1)
- 2 => True, -- Mod_Clause (Node2)
- 3 => True, -- Component_Clauses (List3)
- 4 => False, -- unused
- 5 => False), -- Next_Rep_Item (Node5-Sem)
-
- N_Component_Clause =>
- (1 => True, -- Component_Name (Node1)
- 2 => True, -- Position (Node2)
- 3 => True, -- First_Bit (Node3)
- 4 => True, -- Last_Bit (Node4)
- 5 => False), -- unused
-
- N_Code_Statement =>
- (1 => False, -- unused
- 2 => False, -- unused
- 3 => True, -- Expression (Node3)
- 4 => False, -- unused
- 5 => False), -- unused
-
- N_Op_Rotate_Left =>
- (1 => True, -- Chars (Name1)
- 2 => True, -- Left_Opnd (Node2)
- 3 => True, -- Right_Opnd (Node3)
- 4 => False, -- Entity (Node4-Sem)
- 5 => False), -- Etype (Node5-Sem)
-
- N_Op_Rotate_Right =>
- (1 => True, -- Chars (Name1)
- 2 => True, -- Left_Opnd (Node2)
- 3 => True, -- Right_Opnd (Node3)
- 4 => False, -- Entity (Node4-Sem)
- 5 => False), -- Etype (Node5-Sem)
-
- N_Op_Shift_Left =>
- (1 => True, -- Chars (Name1)
- 2 => True, -- Left_Opnd (Node2)
- 3 => True, -- Right_Opnd (Node3)
- 4 => False, -- Entity (Node4-Sem)
- 5 => False), -- Etype (Node5-Sem)
-
- N_Op_Shift_Right_Arithmetic =>
- (1 => True, -- Chars (Name1)
- 2 => True, -- Left_Opnd (Node2)
- 3 => True, -- Right_Opnd (Node3)
- 4 => False, -- Entity (Node4-Sem)
- 5 => False), -- Etype (Node5-Sem)
-
- N_Op_Shift_Right =>
- (1 => True, -- Chars (Name1)
- 2 => True, -- Left_Opnd (Node2)
- 3 => True, -- Right_Opnd (Node3)
- 4 => False, -- Entity (Node4-Sem)
- 5 => False), -- Etype (Node5-Sem)
-
- N_Delta_Constraint =>
- (1 => False, -- unused
- 2 => False, -- unused
- 3 => True, -- Delta_Expression (Node3)
- 4 => True, -- Range_Constraint (Node4)
- 5 => False), -- unused
-
- N_At_Clause =>
- (1 => True, -- Identifier (Node1)
- 2 => False, -- unused
- 3 => True, -- Expression (Node3)
- 4 => False, -- unused
- 5 => False), -- unused
-
- N_Mod_Clause =>
- (1 => False, -- unused
- 2 => False, -- unused
- 3 => True, -- Expression (Node3)
- 4 => True, -- Pragmas_Before (List4)
- 5 => False), -- unused
-
- N_If_Expression =>
- (1 => True, -- Expressions (List1)
- 2 => False, -- Then_Actions (List2-Sem)
- 3 => False, -- Else_Actions (List3-Sem)
- 4 => False, -- unused
- 5 => False), -- Etype (Node5-Sem)
-
- N_Compound_Statement =>
- (1 => True, -- Actions (List1)
- 2 => False, -- unused
- 3 => False, -- unused
- 4 => False, -- unused
- 5 => False), -- unused
-
- N_Contract =>
- (1 => False, -- Pre_Post_Conditions (Node1-Sem)
- 2 => False, -- Contract_Test_Cases (Node2-Sem)
- 3 => False, -- Classifications (Node3-Sem)
- 4 => False, -- unused
- 5 => False), -- unused
-
- N_Expanded_Name =>
- (1 => True, -- Chars (Name1)
- 2 => True, -- Selector_Name (Node2)
- 3 => True, -- Prefix (Node3)
- 4 => False, -- Entity (Node4-Sem)
- 5 => False), -- Etype (Node5-Sem)
-
- N_Expression_With_Actions =>
- (1 => True, -- Actions (List1)
- 2 => False, -- unused
- 3 => True, -- Expression (Node3)
- 4 => False, -- unused
- 5 => False), -- unused
-
- N_Free_Statement =>
- (1 => False, -- Storage_Pool (Node1-Sem)
- 2 => False, -- Procedure_To_Call (Node2-Sem)
- 3 => True, -- Expression (Node3)
- 4 => False, -- Actual_Designated_Subtype (Node4-Sem)
- 5 => False), -- unused
-
- N_Freeze_Entity =>
- (1 => True, -- Actions (List1)
- 2 => False, -- Access_Types_To_Process (Elist2-Sem)
- 3 => False, -- TSS_Elist (Elist3-Sem)
- 4 => False, -- Entity (Node4-Sem)
- 5 => False), -- First_Subtype_Link (Node5-Sem)
-
- N_Freeze_Generic_Entity =>
- (1 => False, -- unused
- 2 => False, -- unused
- 3 => False, -- unused
- 4 => False, -- Entity (Node4-Sem)
- 5 => False), -- unused
-
- N_Implicit_Label_Declaration =>
- (1 => True, -- Defining_Identifier (Node1)
- 2 => False, -- Label_Construct (Node2-Sem)
- 3 => False, -- unused
- 4 => False, -- unused
- 5 => False), -- unused
-
- N_Itype_Reference =>
- (1 => False, -- Itype (Node1-Sem)
- 2 => False, -- unused
- 3 => False, -- unused
- 4 => False, -- unused
- 5 => False), -- unused
-
- N_Raise_Constraint_Error =>
- (1 => True, -- Condition (Node1)
- 2 => False, -- unused
- 3 => True, -- Reason (Uint3)
- 4 => False, -- unused
- 5 => False), -- Etype (Node5-Sem)
-
- N_Raise_Program_Error =>
- (1 => True, -- Condition (Node1)
- 2 => False, -- unused
- 3 => True, -- Reason (Uint3)
- 4 => False, -- unused
- 5 => False), -- Etype (Node5-Sem)
-
- N_Raise_Storage_Error =>
- (1 => True, -- Condition (Node1)
- 2 => False, -- unused
- 3 => True, -- Reason (Uint3)
- 4 => False, -- unused
- 5 => False), -- Etype (Node5-Sem)
-
- N_Push_Constraint_Error_Label =>
- (1 => False, -- unused
- 2 => False, -- unused
- 3 => False, -- unused
- 4 => False, -- unused
- 5 => False), -- unused
-
- N_Push_Program_Error_Label =>
- (1 => False, -- unused
- 2 => False, -- unused
- 3 => False, -- unused
- 4 => False, -- unused
- 5 => False), -- Exception_Label
-
- N_Push_Storage_Error_Label =>
- (1 => False, -- unused
- 2 => False, -- unused
- 3 => False, -- unused
- 4 => False, -- unused
- 5 => False), -- Exception_Label
-
- N_Pop_Constraint_Error_Label =>
- (1 => False, -- unused
- 2 => False, -- unused
- 3 => False, -- unused
- 4 => False, -- unused
- 5 => False), -- unused
-
- N_Pop_Program_Error_Label =>
- (1 => False, -- unused
- 2 => False, -- unused
- 3 => False, -- unused
- 4 => False, -- unused
- 5 => False), -- unused
-
- N_Pop_Storage_Error_Label =>
- (1 => False, -- unused
- 2 => False, -- unused
- 3 => False, -- unused
- 4 => False, -- unused
- 5 => False), -- unused
-
- N_Reference =>
- (1 => False, -- unused
- 2 => False, -- unused
- 3 => True, -- Prefix (Node3)
- 4 => False, -- unused
- 5 => False), -- Etype (Node5-Sem)
-
- N_Unchecked_Expression =>
- (1 => False, -- unused
- 2 => False, -- unused
- 3 => True, -- Expression (Node3)
- 4 => False, -- unused
- 5 => False), -- Etype (Node5-Sem)
-
- N_Unchecked_Type_Conversion =>
- (1 => False, -- unused
- 2 => False, -- unused
- 3 => True, -- Expression (Node3)
- 4 => True, -- Subtype_Mark (Node4)
- 5 => False), -- Etype (Node5-Sem)
-
- N_Validate_Unchecked_Conversion =>
- (1 => False, -- Source_Type (Node1-Sem)
- 2 => False, -- Target_Type (Node2-Sem)
- 3 => False, -- unused
- 4 => False, -- unused
- 5 => False), -- unused
-
- -- Entries for SCIL nodes
-
- N_SCIL_Dispatch_Table_Tag_Init =>
- (1 => False, -- unused
- 2 => False, -- unused
- 3 => False, -- unused
- 4 => False, -- SCIL_Entity (Node4-Sem)
- 5 => False), -- unused
-
- N_SCIL_Dispatching_Call =>
- (1 => False, -- unused
- 2 => False, -- SCIL_Target_Prim (Node2-Sem)
- 3 => False, -- unused
- 4 => False, -- SCIL_Entity (Node4-Sem)
- 5 => False), -- SCIL_Controlling_Tag (Node5-Sem)
-
- N_SCIL_Membership_Test =>
- (1 => False, -- unused
- 2 => False, -- unused
- 3 => False, -- unused
- 4 => False, -- SCIL_Entity (Node4-Sem)
- 5 => False), -- SCIL_Tag_Value (Node5-Sem)
-
- N_Call_Marker =>
- (1 => False, -- Target (Node1-Sem)
- 2 => False, -- unused
- 3 => False, -- unused
- 4 => False, -- unused
- 5 => False), -- unused
-
- N_Variable_Reference_Marker =>
- (1 => False, -- Target (Node1-Sem)
- 2 => False, -- unused
- 3 => False, -- unused
- 4 => False, -- unused
- 5 => False), -- unused
-
- -- Entries for Empty, Error, and Unused. Even though these have a Chars
- -- field for debugging purposes, they are not really syntactic fields, so
- -- we mark all fields as unused.
-
- N_Empty =>
- (1 => False, -- unused
- 2 => False, -- unused
- 3 => False, -- unused
- 4 => False, -- unused
- 5 => False), -- unused
-
- N_Error =>
- (1 => False, -- unused
- 2 => False, -- unused
- 3 => False, -- unused
- 4 => False, -- unused
- 5 => False), -- unused
-
- N_Unused_At_Start =>
- (1 => False, -- unused
- 2 => False, -- unused
- 3 => False, -- unused
- 4 => False, -- unused
- 5 => False), -- unused
-
- N_Unused_At_End =>
- (1 => False, -- unused
- 2 => False, -- unused
- 3 => False, -- unused
- 4 => False, -- unused
- 5 => False)); -- unused
-
- --------------------
- -- Inline Pragmas --
- --------------------
-
- pragma Inline (Abort_Present);
- pragma Inline (Abortable_Part);
- pragma Inline (Abstract_Present);
- pragma Inline (Accept_Handler_Records);
- pragma Inline (Accept_Statement);
- pragma Inline (Access_Definition);
- pragma Inline (Access_To_Subprogram_Definition);
- pragma Inline (Access_Types_To_Process);
- pragma Inline (Actions);
- pragma Inline (Activation_Chain_Entity);
- pragma Inline (Acts_As_Spec);
- pragma Inline (Actual_Designated_Subtype);
- pragma Inline (Address_Warning_Posted);
- pragma Inline (Aggregate_Bounds);
- pragma Inline (Aliased_Present);
- pragma Inline (Alloc_For_BIP_Return);
- pragma Inline (All_Others);
- pragma Inline (All_Present);
- pragma Inline (Alternatives);
- pragma Inline (Ancestor_Part);
- pragma Inline (Atomic_Sync_Required);
- pragma Inline (Array_Aggregate);
- pragma Inline (Aspect_On_Partial_View);
- pragma Inline (Aspect_Rep_Item);
- pragma Inline (Assignment_OK);
- pragma Inline (Associated_Node);
- pragma Inline (At_End_Proc);
- pragma Inline (Attribute_Name);
- pragma Inline (Aux_Decls_Node);
- pragma Inline (Backwards_OK);
- pragma Inline (Bad_Is_Detected);
- pragma Inline (Body_To_Inline);
- pragma Inline (Body_Required);
- pragma Inline (By_Ref);
- pragma Inline (Box_Present);
- pragma Inline (Char_Literal_Value);
- pragma Inline (Chars);
- pragma Inline (Check_Address_Alignment);
- pragma Inline (Choice_Parameter);
- pragma Inline (Choices);
- pragma Inline (Class_Present);
- pragma Inline (Classifications);
- pragma Inline (Cleanup_Actions);
- pragma Inline (Comes_From_Extended_Return_Statement);
- pragma Inline (Compile_Time_Known_Aggregate);
- pragma Inline (Component_Associations);
- pragma Inline (Component_Clauses);
- pragma Inline (Component_Definition);
- pragma Inline (Component_Items);
- pragma Inline (Component_List);
- pragma Inline (Component_Name);
- pragma Inline (Componentwise_Assignment);
- pragma Inline (Condition);
- pragma Inline (Condition_Actions);
- pragma Inline (Config_Pragmas);
- pragma Inline (Constant_Present);
- pragma Inline (Constraint);
- pragma Inline (Constraints);
- pragma Inline (Context_Installed);
- pragma Inline (Context_Items);
- pragma Inline (Context_Pending);
- pragma Inline (Contract_Test_Cases);
- pragma Inline (Controlling_Argument);
- pragma Inline (Convert_To_Return_False);
- pragma Inline (Conversion_OK);
- pragma Inline (Corresponding_Aspect);
- pragma Inline (Corresponding_Body);
- pragma Inline (Corresponding_Formal_Spec);
- pragma Inline (Corresponding_Generic_Association);
- pragma Inline (Corresponding_Integer_Value);
- pragma Inline (Corresponding_Spec);
- pragma Inline (Corresponding_Spec_Of_Stub);
- pragma Inline (Corresponding_Stub);
- pragma Inline (Dcheck_Function);
- pragma Inline (Declarations);
- pragma Inline (Default_Expression);
- pragma Inline (Default_Storage_Pool);
- pragma Inline (Default_Name);
- pragma Inline (Defining_Identifier);
- pragma Inline (Defining_Unit_Name);
- pragma Inline (Delay_Alternative);
- pragma Inline (Delay_Statement);
- pragma Inline (Delta_Expression);
- pragma Inline (Digits_Expression);
- pragma Inline (Discr_Check_Funcs_Built);
- pragma Inline (Discrete_Choices);
- pragma Inline (Discrete_Range);
- pragma Inline (Discrete_Subtype_Definition);
- pragma Inline (Discrete_Subtype_Definitions);
- pragma Inline (Discriminant_Specifications);
- pragma Inline (Discriminant_Type);
- pragma Inline (Do_Accessibility_Check);
- pragma Inline (Do_Discriminant_Check);
- pragma Inline (Do_Length_Check);
- pragma Inline (Do_Division_Check);
- pragma Inline (Do_Overflow_Check);
- pragma Inline (Do_Range_Check);
- pragma Inline (Do_Storage_Check);
- pragma Inline (Do_Tag_Check);
- pragma Inline (Elaborate_All_Desirable);
- pragma Inline (Elaborate_All_Present);
- pragma Inline (Elaborate_Desirable);
- pragma Inline (Elaborate_Present);
- pragma Inline (Else_Actions);
- pragma Inline (Else_Statements);
- pragma Inline (Elsif_Parts);
- pragma Inline (Enclosing_Variant);
- pragma Inline (End_Label);
- pragma Inline (End_Span);
- pragma Inline (Entity);
- pragma Inline (Entity_Or_Associated_Node);
- pragma Inline (Entry_Body_Formal_Part);
- pragma Inline (Entry_Call_Alternative);
- pragma Inline (Entry_Call_Statement);
- pragma Inline (Entry_Direct_Name);
- pragma Inline (Entry_Index);
- pragma Inline (Entry_Index_Specification);
- pragma Inline (Etype);
- pragma Inline (Exception_Choices);
- pragma Inline (Exception_Handlers);
- pragma Inline (Exception_Junk);
- pragma Inline (Exception_Label);
- pragma Inline (Expansion_Delayed);
- pragma Inline (Explicit_Actual_Parameter);
- pragma Inline (Explicit_Generic_Actual_Parameter);
- pragma Inline (Expression);
- pragma Inline (Expression_Copy);
- pragma Inline (Expressions);
- pragma Inline (First_Bit);
- pragma Inline (First_Inlined_Subprogram);
- pragma Inline (First_Name);
- pragma Inline (First_Named_Actual);
- pragma Inline (First_Real_Statement);
- pragma Inline (First_Subtype_Link);
- pragma Inline (Float_Truncate);
- pragma Inline (Formal_Type_Definition);
- pragma Inline (Forwards_OK);
- pragma Inline (From_Aspect_Specification);
- pragma Inline (From_At_End);
- pragma Inline (From_At_Mod);
- pragma Inline (From_Conditional_Expression);
- pragma Inline (From_Default);
- pragma Inline (Generalized_Indexing);
- pragma Inline (Generic_Associations);
- pragma Inline (Generic_Formal_Declarations);
- pragma Inline (Generic_Parent);
- pragma Inline (Generic_Parent_Type);
- pragma Inline (Handled_Statement_Sequence);
- pragma Inline (Handler_List_Entry);
- pragma Inline (Has_Created_Identifier);
- pragma Inline (Has_Dereference_Action);
- pragma Inline (Has_Dynamic_Length_Check);
- pragma Inline (Has_Init_Expression);
- pragma Inline (Has_Local_Raise);
- pragma Inline (Has_Self_Reference);
- pragma Inline (Has_SP_Choice);
- pragma Inline (Has_No_Elaboration_Code);
- pragma Inline (Has_Pragma_Suppress_All);
- pragma Inline (Has_Private_View);
- pragma Inline (Has_Relative_Deadline_Pragma);
- pragma Inline (Has_Storage_Size_Pragma);
- pragma Inline (Has_Target_Names);
- pragma Inline (Has_Wide_Character);
- pragma Inline (Has_Wide_Wide_Character);
- pragma Inline (Header_Size_Added);
- pragma Inline (Hidden_By_Use_Clause);
- pragma Inline (High_Bound);
- pragma Inline (Identifier);
- pragma Inline (Implicit_With);
- pragma Inline (Interface_List);
- pragma Inline (Interface_Present);
- pragma Inline (Includes_Infinities);
- pragma Inline (Import_Interface_Present);
- pragma Inline (In_Present);
- pragma Inline (Incomplete_View);
- pragma Inline (Inherited_Discriminant);
- pragma Inline (Instance_Spec);
- pragma Inline (Intval);
- pragma Inline (Iterator_Specification);
- pragma Inline (Is_Abort_Block);
- pragma Inline (Is_Accessibility_Actual);
- pragma Inline (Is_Analyzed_Pragma);
- pragma Inline (Is_Asynchronous_Call_Block);
- pragma Inline (Is_Boolean_Aspect);
- pragma Inline (Is_Checked);
- pragma Inline (Is_Checked_Ghost_Pragma);
- pragma Inline (Is_Component_Left_Opnd);
- pragma Inline (Is_Component_Right_Opnd);
- pragma Inline (Is_Controlling_Actual);
- pragma Inline (Is_Declaration_Level_Node);
- pragma Inline (Is_Delayed_Aspect);
- pragma Inline (Is_Disabled);
- pragma Inline (Is_Dispatching_Call);
- pragma Inline (Is_Dynamic_Coextension);
- pragma Inline (Is_Effective_Use_Clause);
- pragma Inline (Is_Elaboration_Checks_OK_Node);
- pragma Inline (Is_Elaboration_Code);
- pragma Inline (Is_Elaboration_Warnings_OK_Node);
- pragma Inline (Is_Elsif);
- pragma Inline (Is_Entry_Barrier_Function);
- pragma Inline (Is_Expanded_Build_In_Place_Call);
- pragma Inline (Is_Expanded_Contract);
- pragma Inline (Is_Finalization_Wrapper);
- pragma Inline (Is_Folded_In_Parser);
- pragma Inline (Is_Generic_Contract_Pragma);
- pragma Inline (Is_Homogeneous_Aggregate);
- pragma Inline (Is_Ignored);
- pragma Inline (Is_Ignored_Ghost_Pragma);
- pragma Inline (Is_In_Discriminant_Check);
- pragma Inline (Is_Inherited_Pragma);
- pragma Inline (Is_Initialization_Block);
- pragma Inline (Is_Known_Guaranteed_ABE);
- pragma Inline (Is_Machine_Number);
- pragma Inline (Is_Null_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);
- pragma Inline (Is_Read);
- pragma Inline (Is_Source_Call);
- pragma Inline (Is_SPARK_Mode_On_Node);
- pragma Inline (Is_Static_Coextension);
- pragma Inline (Is_Static_Expression);
- pragma Inline (Is_Subprogram_Descriptor);
- pragma Inline (Is_Task_Allocation_Block);
- 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);
- pragma Inline (Library_Unit);
- pragma Inline (Label_Construct);
- pragma Inline (Left_Opnd);
- pragma Inline (Limited_View_Installed);
- pragma Inline (Limited_Present);
- pragma Inline (Literals);
- pragma Inline (Local_Raise_Not_OK);
- pragma Inline (Local_Raise_Statements);
- pragma Inline (Loop_Actions);
- pragma Inline (Loop_Parameter_Specification);
- pragma Inline (Low_Bound);
- pragma Inline (Mod_Clause);
- pragma Inline (More_Ids);
- pragma Inline (Must_Be_Byte_Aligned);
- pragma Inline (Must_Not_Freeze);
- pragma Inline (Must_Not_Override);
- pragma Inline (Must_Override);
- pragma Inline (Name);
- pragma Inline (Names);
- pragma Inline (Next_Entity);
- pragma Inline (Next_Exit_Statement);
- pragma Inline (Next_Implicit_With);
- pragma Inline (Next_Named_Actual);
- pragma Inline (Next_Pragma);
- pragma Inline (Next_Rep_Item);
- pragma Inline (Next_Use_Clause);
- pragma Inline (No_Ctrl_Actions);
- pragma Inline (No_Elaboration_Check);
- pragma Inline (No_Entities_Ref_In_Spec);
- pragma Inline (No_Initialization);
- pragma Inline (No_Minimize_Eliminate);
- pragma Inline (No_Side_Effect_Removal);
- pragma Inline (No_Truncation);
- pragma Inline (Null_Excluding_Subtype);
- pragma Inline (Null_Exclusion_Present);
- pragma Inline (Null_Exclusion_In_Return_Present);
- pragma Inline (Null_Present);
- pragma Inline (Null_Record_Present);
- pragma Inline (Null_Statement);
- pragma Inline (Object_Definition);
- pragma Inline (Of_Present);
- pragma Inline (Original_Discriminant);
- pragma Inline (Original_Entity);
- pragma Inline (Others_Discrete_Choices);
- pragma Inline (Out_Present);
- pragma Inline (Parameter_Associations);
- pragma Inline (Parameter_Specifications);
- pragma Inline (Parameter_Type);
- pragma Inline (Parent_Spec);
- pragma Inline (Parent_With);
- pragma Inline (Position);
- pragma Inline (Pragma_Argument_Associations);
- pragma Inline (Pragma_Identifier);
- pragma Inline (Pragmas_After);
- pragma Inline (Pragmas_Before);
- pragma Inline (Pre_Post_Conditions);
- pragma Inline (Prefix);
- pragma Inline (Premature_Use);
- pragma Inline (Present_Expr);
- pragma Inline (Prev_Ids);
- pragma Inline (Prev_Use_Clause);
- pragma Inline (Print_In_Hex);
- pragma Inline (Private_Declarations);
- pragma Inline (Private_Present);
- pragma Inline (Procedure_To_Call);
- pragma Inline (Proper_Body);
- pragma Inline (Protected_Definition);
- pragma Inline (Protected_Present);
- pragma Inline (Raises_Constraint_Error);
- pragma Inline (Range_Constraint);
- pragma Inline (Range_Expression);
- pragma Inline (Real_Range_Specification);
- pragma Inline (Realval);
- pragma Inline (Reason);
- pragma Inline (Record_Extension_Part);
- pragma Inline (Redundant_Use);
- pragma Inline (Renaming_Exception);
- pragma Inline (Result_Definition);
- pragma Inline (Return_Object_Declarations);
- pragma Inline (Return_Statement_Entity);
- pragma Inline (Reverse_Present);
- pragma Inline (Right_Opnd);
- pragma Inline (Rounded_Result);
- pragma Inline (Save_Invocation_Graph_Of_Body);
- pragma Inline (SCIL_Controlling_Tag);
- pragma Inline (SCIL_Entity);
- pragma Inline (SCIL_Tag_Value);
- pragma Inline (SCIL_Target_Prim);
- pragma Inline (Scope);
- pragma Inline (Select_Alternatives);
- pragma Inline (Selector_Name);
- pragma Inline (Selector_Names);
- pragma Inline (Shift_Count_OK);
- pragma Inline (Source_Type);
- pragma Inline (Specification);
- pragma Inline (Split_PPC);
- pragma Inline (Statements);
- pragma Inline (Storage_Pool);
- pragma Inline (Subpool_Handle_Name);
- pragma Inline (Strval);
- pragma Inline (Subtype_Indication);
- pragma Inline (Subtype_Mark);
- pragma Inline (Subtype_Marks);
- pragma Inline (Suppress_Assignment_Checks);
- pragma Inline (Suppress_Loop_Warnings);
- pragma Inline (Synchronized_Present);
- pragma Inline (Tagged_Present);
- pragma Inline (Target);
- pragma Inline (Target_Type);
- pragma Inline (Task_Definition);
- pragma Inline (Task_Present);
- pragma Inline (Then_Actions);
- pragma Inline (Then_Statements);
- pragma Inline (Triggering_Alternative);
- pragma Inline (Triggering_Statement);
- pragma Inline (TSS_Elist);
- pragma Inline (Type_Definition);
- pragma Inline (Uneval_Old_Accept);
- pragma Inline (Uneval_Old_Warn);
- pragma Inline (Unit);
- pragma Inline (Uninitialized_Variable);
- pragma Inline (Unknown_Discriminants_Present);
- pragma Inline (Unreferenced_In_Spec);
- pragma Inline (Variant_Part);
- pragma Inline (Variants);
- pragma Inline (Visible_Declarations);
- pragma Inline (Used_Operations);
- pragma Inline (Was_Attribute_Reference);
- pragma Inline (Was_Default_Init_Box_Association);
- pragma Inline (Was_Expression_Function);
- pragma Inline (Was_Originally_Stub);
-
- pragma Inline (Set_Abort_Present);
- pragma Inline (Set_Abortable_Part);
- pragma Inline (Set_Abstract_Present);
- pragma Inline (Set_Accept_Handler_Records);
- pragma Inline (Set_Accept_Statement);
- pragma Inline (Set_Access_Definition);
- pragma Inline (Set_Access_To_Subprogram_Definition);
- pragma Inline (Set_Access_Types_To_Process);
- pragma Inline (Set_Actions);
- pragma Inline (Set_Activation_Chain_Entity);
- pragma Inline (Set_Acts_As_Spec);
- pragma Inline (Set_Actual_Designated_Subtype);
- pragma Inline (Set_Address_Warning_Posted);
- pragma Inline (Set_Aggregate_Bounds);
- pragma Inline (Set_Aliased_Present);
- pragma Inline (Set_Alloc_For_BIP_Return);
- pragma Inline (Set_All_Others);
- pragma Inline (Set_All_Present);
- pragma Inline (Set_Alternatives);
- pragma Inline (Set_Ancestor_Part);
- pragma Inline (Set_Array_Aggregate);
- pragma Inline (Set_Aspect_On_Partial_View);
- pragma Inline (Set_Aspect_Rep_Item);
- pragma Inline (Set_Assignment_OK);
- pragma Inline (Set_Associated_Node);
- pragma Inline (Set_At_End_Proc);
- pragma Inline (Set_Atomic_Sync_Required);
- pragma Inline (Set_Attribute_Name);
- pragma Inline (Set_Aux_Decls_Node);
- pragma Inline (Set_Backwards_OK);
- pragma Inline (Set_Bad_Is_Detected);
- pragma Inline (Set_Body_Required);
- pragma Inline (Set_Body_To_Inline);
- pragma Inline (Set_Box_Present);
- pragma Inline (Set_By_Ref);
- pragma Inline (Set_Char_Literal_Value);
- pragma Inline (Set_Chars);
- pragma Inline (Set_Check_Address_Alignment);
- pragma Inline (Set_Choice_Parameter);
- pragma Inline (Set_Choices);
- pragma Inline (Set_Class_Present);
- pragma Inline (Set_Classifications);
- pragma Inline (Set_Cleanup_Actions);
- pragma Inline (Set_Comes_From_Extended_Return_Statement);
- pragma Inline (Set_Compile_Time_Known_Aggregate);
- pragma Inline (Set_Component_Associations);
- pragma Inline (Set_Component_Clauses);
- pragma Inline (Set_Component_Definition);
- pragma Inline (Set_Component_Items);
- pragma Inline (Set_Component_List);
- pragma Inline (Set_Component_Name);
- pragma Inline (Set_Componentwise_Assignment);
- pragma Inline (Set_Condition);
- pragma Inline (Set_Condition_Actions);
- pragma Inline (Set_Config_Pragmas);
- pragma Inline (Set_Constant_Present);
- pragma Inline (Set_Constraint);
- pragma Inline (Set_Constraints);
- pragma Inline (Set_Context_Installed);
- pragma Inline (Set_Context_Items);
- pragma Inline (Set_Context_Pending);
- pragma Inline (Set_Contract_Test_Cases);
- pragma Inline (Set_Controlling_Argument);
- pragma Inline (Set_Conversion_OK);
- pragma Inline (Set_Convert_To_Return_False);
- pragma Inline (Set_Corresponding_Aspect);
- pragma Inline (Set_Corresponding_Body);
- pragma Inline (Set_Corresponding_Formal_Spec);
- pragma Inline (Set_Corresponding_Generic_Association);
- pragma Inline (Set_Corresponding_Integer_Value);
- pragma Inline (Set_Corresponding_Spec);
- pragma Inline (Set_Corresponding_Spec_Of_Stub);
- pragma Inline (Set_Corresponding_Stub);
- pragma Inline (Set_Dcheck_Function);
- pragma Inline (Set_Declarations);
- pragma Inline (Set_Default_Expression);
- pragma Inline (Set_Default_Name);
- pragma Inline (Set_Default_Storage_Pool);
- pragma Inline (Set_Defining_Identifier);
- pragma Inline (Set_Defining_Unit_Name);
- pragma Inline (Set_Delay_Alternative);
- pragma Inline (Set_Delay_Statement);
- pragma Inline (Set_Delta_Expression);
- pragma Inline (Set_Digits_Expression);
- pragma Inline (Set_Discr_Check_Funcs_Built);
- pragma Inline (Set_Discrete_Choices);
- pragma Inline (Set_Discrete_Range);
- pragma Inline (Set_Discrete_Subtype_Definition);
- pragma Inline (Set_Discrete_Subtype_Definitions);
- pragma Inline (Set_Discriminant_Specifications);
- pragma Inline (Set_Discriminant_Type);
- pragma Inline (Set_Do_Accessibility_Check);
- pragma Inline (Set_Do_Discriminant_Check);
- pragma Inline (Set_Do_Division_Check);
- pragma Inline (Set_Do_Length_Check);
- pragma Inline (Set_Do_Overflow_Check);
- pragma Inline (Set_Do_Range_Check);
- pragma Inline (Set_Do_Storage_Check);
- pragma Inline (Set_Do_Tag_Check);
- pragma Inline (Set_Elaborate_All_Desirable);
- pragma Inline (Set_Elaborate_All_Present);
- pragma Inline (Set_Elaborate_Desirable);
- pragma Inline (Set_Elaborate_Present);
- pragma Inline (Set_Else_Actions);
- pragma Inline (Set_Else_Statements);
- pragma Inline (Set_Elsif_Parts);
- pragma Inline (Set_Enclosing_Variant);
- pragma Inline (Set_End_Label);
- pragma Inline (Set_End_Span);
- pragma Inline (Set_Entity);
- pragma Inline (Set_Entry_Body_Formal_Part);
- pragma Inline (Set_Entry_Call_Alternative);
- pragma Inline (Set_Entry_Call_Statement);
- pragma Inline (Set_Entry_Direct_Name);
- pragma Inline (Set_Entry_Index);
- pragma Inline (Set_Entry_Index_Specification);
- pragma Inline (Set_Etype);
- pragma Inline (Set_Exception_Choices);
- pragma Inline (Set_Exception_Handlers);
- pragma Inline (Set_Exception_Junk);
- pragma Inline (Set_Exception_Label);
- pragma Inline (Set_Expansion_Delayed);
- pragma Inline (Set_Explicit_Actual_Parameter);
- pragma Inline (Set_Explicit_Generic_Actual_Parameter);
- pragma Inline (Set_Expression);
- pragma Inline (Set_Expression_Copy);
- pragma Inline (Set_Expressions);
- pragma Inline (Set_First_Bit);
- pragma Inline (Set_First_Inlined_Subprogram);
- pragma Inline (Set_First_Name);
- pragma Inline (Set_First_Named_Actual);
- pragma Inline (Set_First_Real_Statement);
- pragma Inline (Set_First_Subtype_Link);
- pragma Inline (Set_Float_Truncate);
- pragma Inline (Set_Formal_Type_Definition);
- pragma Inline (Set_Forwards_OK);
- pragma Inline (Set_From_Aspect_Specification);
- pragma Inline (Set_From_At_End);
- pragma Inline (Set_From_At_Mod);
- pragma Inline (Set_From_Conditional_Expression);
- pragma Inline (Set_From_Default);
- pragma Inline (Set_Generalized_Indexing);
- pragma Inline (Set_Generic_Associations);
- pragma Inline (Set_Generic_Formal_Declarations);
- pragma Inline (Set_Generic_Parent);
- pragma Inline (Set_Generic_Parent_Type);
- pragma Inline (Set_Handled_Statement_Sequence);
- pragma Inline (Set_Handler_List_Entry);
- pragma Inline (Set_Has_Created_Identifier);
- pragma Inline (Set_Has_Dereference_Action);
- pragma Inline (Set_Has_Dynamic_Length_Check);
- pragma Inline (Set_Has_Init_Expression);
- pragma Inline (Set_Has_Local_Raise);
- pragma Inline (Set_Has_No_Elaboration_Code);
- pragma Inline (Set_Has_Pragma_Suppress_All);
- pragma Inline (Set_Has_Private_View);
- pragma Inline (Set_Has_Relative_Deadline_Pragma);
- pragma Inline (Set_Has_Self_Reference);
- pragma Inline (Set_Has_SP_Choice);
- pragma Inline (Set_Has_Storage_Size_Pragma);
- pragma Inline (Set_Has_Target_Names);
- pragma Inline (Set_Has_Wide_Character);
- pragma Inline (Set_Has_Wide_Wide_Character);
- pragma Inline (Set_Header_Size_Added);
- pragma Inline (Set_Hidden_By_Use_Clause);
- pragma Inline (Set_High_Bound);
- pragma Inline (Set_Identifier);
- pragma Inline (Set_Implicit_With);
- pragma Inline (Set_Import_Interface_Present);
- pragma Inline (Set_In_Present);
- pragma Inline (Set_Includes_Infinities);
- pragma Inline (Set_Incomplete_View);
- pragma Inline (Set_Inherited_Discriminant);
- pragma Inline (Set_Instance_Spec);
- pragma Inline (Set_Interface_List);
- pragma Inline (Set_Interface_Present);
- pragma Inline (Set_Intval);
- pragma Inline (Set_Is_Abort_Block);
- pragma Inline (Set_Is_Accessibility_Actual);
- pragma Inline (Set_Is_Analyzed_Pragma);
- pragma Inline (Set_Is_Asynchronous_Call_Block);
- pragma Inline (Set_Is_Boolean_Aspect);
- pragma Inline (Set_Is_Checked);
- pragma Inline (Set_Is_Checked_Ghost_Pragma);
- pragma Inline (Set_Is_Component_Left_Opnd);
- pragma Inline (Set_Is_Component_Right_Opnd);
- pragma Inline (Set_Is_Controlling_Actual);
- pragma Inline (Set_Is_Declaration_Level_Node);
- pragma Inline (Set_Is_Delayed_Aspect);
- pragma Inline (Set_Is_Disabled);
- pragma Inline (Set_Is_Dispatching_Call);
- pragma Inline (Set_Is_Dynamic_Coextension);
- pragma Inline (Set_Is_Effective_Use_Clause);
- pragma Inline (Set_Is_Elaboration_Checks_OK_Node);
- pragma Inline (Set_Is_Elaboration_Code);
- pragma Inline (Set_Is_Elaboration_Warnings_OK_Node);
- pragma Inline (Set_Is_Elsif);
- pragma Inline (Set_Is_Entry_Barrier_Function);
- pragma Inline (Set_Is_Expanded_Build_In_Place_Call);
- pragma Inline (Set_Is_Expanded_Contract);
- pragma Inline (Set_Is_Finalization_Wrapper);
- pragma Inline (Set_Is_Folded_In_Parser);
- pragma Inline (Set_Is_Generic_Contract_Pragma);
- pragma Inline (Set_Is_Homogeneous_Aggregate);
- pragma Inline (Set_Is_Ignored);
- pragma Inline (Set_Is_Ignored_Ghost_Pragma);
- pragma Inline (Set_Is_In_Discriminant_Check);
- pragma Inline (Set_Is_Inherited_Pragma);
- pragma Inline (Set_Is_Initialization_Block);
- pragma Inline (Set_Is_Known_Guaranteed_ABE);
- pragma Inline (Set_Is_Machine_Number);
- pragma Inline (Set_Is_Null_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);
- pragma Inline (Set_Is_Read);
- pragma Inline (Set_Is_Source_Call);
- pragma Inline (Set_Is_SPARK_Mode_On_Node);
- pragma Inline (Set_Is_Static_Coextension);
- pragma Inline (Set_Is_Static_Expression);
- pragma Inline (Set_Is_Subprogram_Descriptor);
- pragma Inline (Set_Is_Task_Allocation_Block);
- 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);
- pragma Inline (Set_Last_Name);
- pragma Inline (Set_Left_Opnd);
- pragma Inline (Set_Library_Unit);
- pragma Inline (Set_Limited_Present);
- pragma Inline (Set_Limited_View_Installed);
- pragma Inline (Set_Literals);
- pragma Inline (Set_Local_Raise_Not_OK);
- pragma Inline (Set_Local_Raise_Statements);
- pragma Inline (Set_Loop_Actions);
- pragma Inline (Set_Loop_Parameter_Specification);
- pragma Inline (Set_Low_Bound);
- pragma Inline (Set_Mod_Clause);
- pragma Inline (Set_More_Ids);
- pragma Inline (Set_Must_Be_Byte_Aligned);
- pragma Inline (Set_Must_Not_Freeze);
- pragma Inline (Set_Must_Not_Override);
- pragma Inline (Set_Must_Override);
- pragma Inline (Set_Name);
- pragma Inline (Set_Names);
- pragma Inline (Set_Next_Entity);
- pragma Inline (Set_Next_Exit_Statement);
- pragma Inline (Set_Next_Implicit_With);
- pragma Inline (Set_Next_Named_Actual);
- pragma Inline (Set_Next_Pragma);
- pragma Inline (Set_Next_Rep_Item);
- pragma Inline (Set_Next_Use_Clause);
- pragma Inline (Set_No_Ctrl_Actions);
- pragma Inline (Set_No_Elaboration_Check);
- pragma Inline (Set_No_Entities_Ref_In_Spec);
- pragma Inline (Set_No_Initialization);
- pragma Inline (Set_No_Minimize_Eliminate);
- pragma Inline (Set_No_Side_Effect_Removal);
- pragma Inline (Set_No_Truncation);
- pragma Inline (Set_Null_Excluding_Subtype);
- pragma Inline (Set_Null_Exclusion_Present);
- pragma Inline (Set_Null_Exclusion_In_Return_Present);
- pragma Inline (Set_Null_Present);
- pragma Inline (Set_Null_Record_Present);
- pragma Inline (Set_Null_Statement);
- pragma Inline (Set_Object_Definition);
- pragma Inline (Set_Of_Present);
- pragma Inline (Set_Original_Discriminant);
- pragma Inline (Set_Original_Entity);
- pragma Inline (Set_Others_Discrete_Choices);
- pragma Inline (Set_Out_Present);
- pragma Inline (Set_Parameter_Associations);
- pragma Inline (Set_Parameter_Specifications);
- pragma Inline (Set_Parameter_Type);
- pragma Inline (Set_Parent_Spec);
- pragma Inline (Set_Parent_With);
- pragma Inline (Set_Position);
- pragma Inline (Set_Pragma_Argument_Associations);
- pragma Inline (Set_Pragma_Identifier);
- pragma Inline (Set_Pragmas_After);
- pragma Inline (Set_Pragmas_Before);
- pragma Inline (Set_Pre_Post_Conditions);
- pragma Inline (Set_Prefix);
- pragma Inline (Set_Premature_Use);
- pragma Inline (Set_Present_Expr);
- pragma Inline (Set_Prev_Ids);
- pragma Inline (Set_Prev_Use_Clause);
- pragma Inline (Set_Print_In_Hex);
- pragma Inline (Set_Private_Declarations);
- pragma Inline (Set_Private_Present);
- pragma Inline (Set_Procedure_To_Call);
- pragma Inline (Set_Proper_Body);
- pragma Inline (Set_Protected_Definition);
- pragma Inline (Set_Protected_Present);
- pragma Inline (Set_Raises_Constraint_Error);
- pragma Inline (Set_Range_Constraint);
- pragma Inline (Set_Range_Expression);
- pragma Inline (Set_Real_Range_Specification);
- pragma Inline (Set_Realval);
- pragma Inline (Set_Reason);
- pragma Inline (Set_Record_Extension_Part);
- pragma Inline (Set_Redundant_Use);
- pragma Inline (Set_Renaming_Exception);
- pragma Inline (Set_Result_Definition);
- pragma Inline (Set_Return_Object_Declarations);
- pragma Inline (Set_Reverse_Present);
- pragma Inline (Set_Right_Opnd);
- pragma Inline (Set_Rounded_Result);
- pragma Inline (Set_Save_Invocation_Graph_Of_Body);
- pragma Inline (Set_SCIL_Controlling_Tag);
- pragma Inline (Set_SCIL_Entity);
- pragma Inline (Set_SCIL_Tag_Value);
- pragma Inline (Set_SCIL_Target_Prim);
- pragma Inline (Set_Scope);
- pragma Inline (Set_Select_Alternatives);
- pragma Inline (Set_Selector_Name);
- pragma Inline (Set_Selector_Names);
- pragma Inline (Set_Shift_Count_OK);
- pragma Inline (Set_Source_Type);
- pragma Inline (Set_Split_PPC);
- pragma Inline (Set_Statements);
- pragma Inline (Set_Storage_Pool);
- pragma Inline (Set_Strval);
- pragma Inline (Set_Subpool_Handle_Name);
- pragma Inline (Set_Subtype_Indication);
- pragma Inline (Set_Subtype_Mark);
- pragma Inline (Set_Subtype_Marks);
- pragma Inline (Set_Suppress_Assignment_Checks);
- pragma Inline (Set_Suppress_Loop_Warnings);
- pragma Inline (Set_Synchronized_Present);
- pragma Inline (Set_TSS_Elist);
- pragma Inline (Set_Tagged_Present);
- pragma Inline (Set_Target);
- pragma Inline (Set_Target_Type);
- pragma Inline (Set_Task_Definition);
- pragma Inline (Set_Task_Present);
- pragma Inline (Set_Then_Actions);
- pragma Inline (Set_Then_Statements);
- pragma Inline (Set_Triggering_Alternative);
- pragma Inline (Set_Triggering_Statement);
- pragma Inline (Set_Type_Definition);
- pragma Inline (Set_Uneval_Old_Accept);
- pragma Inline (Set_Uneval_Old_Warn);
- pragma Inline (Set_Unit);
- pragma Inline (Set_Uninitialized_Variable);
- pragma Inline (Set_Unknown_Discriminants_Present);
- pragma Inline (Set_Unreferenced_In_Spec);
- pragma Inline (Set_Used_Operations);
- pragma Inline (Set_Variant_Part);
- pragma Inline (Set_Variants);
- pragma Inline (Set_Visible_Declarations);
- pragma Inline (Set_Was_Attribute_Reference);
- pragma Inline (Set_Was_Default_Init_Box_Association);
- pragma Inline (Set_Was_Expression_Function);
- pragma Inline (Set_Was_Originally_Stub);
+ -- Chars is set to Error_Name
+ -- Etype
end Sinfo;
diff --git a/gcc/ada/sinput-c.adb b/gcc/ada/sinput-c.adb
index 2a611b9..cbb80b0 100644
--- a/gcc/ada/sinput-c.adb
+++ b/gcc/ada/sinput-c.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute 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 37f4ebf..f2d9f61 100644
--- a/gcc/ada/sinput-c.ads
+++ b/gcc/ada/sinput-c.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute 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 5f449c7..2722913 100644
--- a/gcc/ada/sinput-d.adb
+++ b/gcc/ada/sinput-d.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2002-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2002-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute 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 112fe30..e1eb6ab 100644
--- a/gcc/ada/sinput-d.ads
+++ b/gcc/ada/sinput-d.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2001-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2001-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute 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 ce6ba5f..2d5efb0 100644
--- a/gcc/ada/sinput-l.adb
+++ b/gcc/ada/sinput-l.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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,26 +24,29 @@
------------------------------------------------------------------------------
with Alloc;
-with Atree; use Atree;
-with Debug; use Debug;
-with Einfo; use Einfo;
-with Errout; use Errout;
-with Fname; use Fname;
-with Lib; use Lib;
-with Opt; use Opt;
-with Osint; use Osint;
-with Output; use Output;
-with Prep; use Prep;
-with Prepcomp; use Prepcomp;
-with Scans; use Scans;
-with Scn; use Scn;
-with Sem_Aux; use Sem_Aux;
-with Sem_Util; use Sem_Util;
-with Sinfo; use Sinfo;
-with Snames; use Snames;
-with System; use System;
-
-with System.OS_Lib; use System.OS_Lib;
+with Atree; use Atree;
+with Debug; use Debug;
+with Einfo; use Einfo;
+with Einfo.Entities; use Einfo.Entities;
+with Einfo.Utils; use Einfo.Utils;
+with Errout; use Errout;
+with Fname; use Fname;
+with Lib; use Lib;
+with Opt; use Opt;
+with Osint; use Osint;
+with Output; use Output;
+with Prep; use Prep;
+with Prepcomp; use Prepcomp;
+with Scans; use Scans;
+with Scn; use Scn;
+with Sem_Aux; use Sem_Aux;
+with Sem_Util; use Sem_Util;
+with Sinfo; use Sinfo;
+with Sinfo.Nodes; use Sinfo.Nodes;
+with Snames; use Snames;
+with System; use System;
+
+with System.OS_Lib; use System.OS_Lib;
package body Sinput.L is
@@ -548,19 +551,10 @@ package body Sinput.L is
Set_Source_File_Index_Table (X);
if Opt.List_Preprocessing_Symbols then
- Get_Name_String (N);
-
declare
- Foreword : String (1 .. Foreword_Start'Length +
- Name_Len + Foreword_End'Length);
-
+ Foreword : constant String :=
+ Foreword_Start & Get_Name_String (N) & Foreword_End;
begin
- Foreword (1 .. Foreword_Start'Length) := Foreword_Start;
- Foreword (Foreword_Start'Length + 1 ..
- Foreword_Start'Length + Name_Len) :=
- Name_Buffer (1 .. Name_Len);
- Foreword (Foreword'Last - Foreword_End'Length + 1 ..
- Foreword'Last) := Foreword_End;
Prep.List_Symbols (Foreword);
end;
end if;
@@ -651,14 +645,13 @@ package body Sinput.L is
NB : Integer;
Status : Boolean;
- begin
- Get_Name_String (N);
- Add_Str_To_Name_Buffer (Prep_Suffix);
+ Prep_Filename : constant String :=
+ Get_Name_String (N) & Prep_Suffix;
- Delete_File (Name_Buffer (1 .. Name_Len), Status);
+ begin
+ Delete_File (Prep_Filename, Status);
- FD :=
- Create_New_File (Name_Buffer (1 .. Name_Len), Text);
+ FD := Create_New_File (Prep_Filename, Text);
Status := FD /= Invalid_FD;
diff --git a/gcc/ada/sinput-l.ads b/gcc/ada/sinput-l.ads
index 2437108..f05caf5 100644
--- a/gcc/ada/sinput-l.ads
+++ b/gcc/ada/sinput-l.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute 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 08db0cf..e62bf45 100644
--- a/gcc/ada/sinput.adb
+++ b/gcc/ada/sinput.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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,12 +26,14 @@
pragma Style_Checks (All_Checks);
-- Subprograms not all in alpha order
-with Atree; use Atree;
-with Debug; use Debug;
-with Opt; use Opt;
-with Output; use Output;
-with Scans; use Scans;
-with Widechar; use Widechar;
+with Atree; use Atree;
+with Debug; use Debug;
+with Opt; use Opt;
+with Output; use Output;
+with Scans; use Scans;
+with Sinfo; use Sinfo;
+with Sinfo.Nodes; use Sinfo.Nodes;
+with Widechar; use Widechar;
with GNAT.Byte_Order_Mark; use GNAT.Byte_Order_Mark;
@@ -931,7 +933,7 @@ 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));
+ 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
@@ -943,25 +945,22 @@ package body Sinput is
-------------
function Process (N : Node_Id) return Traverse_Result is
- Orig : constant Node_Id := Original_Node (N);
+ Loc : constant Source_Ptr := Sloc (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
+ if Get_Source_File_Index (Loc) /= Indx then
return Skip;
end if;
- if Sloc (Orig) < Min then
- if Sloc (Orig) > No_Location then
- Min := Sloc (Orig);
- end if;
-
- elsif Sloc (Orig) > Max then
- if Sloc (Orig) > No_Location then
- Max := Sloc (Orig);
+ if Loc > No_Location then
+ if Loc < Min then
+ Min := Loc;
+ elsif Loc > Max then
+ Max := Loc;
end if;
end if;
@@ -972,7 +971,7 @@ package body Sinput is
begin
Min := Sloc (N);
- Max := Sloc (N);
+ Max := Min;
Traverse (N);
end Sloc_Range;
diff --git a/gcc/ada/sinput.ads b/gcc/ada/sinput.ads
index 9e66d09..2926b85 100644
--- a/gcc/ada/sinput.ads
+++ b/gcc/ada/sinput.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/snames.adb-tmpl b/gcc/ada/snames.adb-tmpl
index 132c2ca..a1ea3ee 100644
--- a/gcc/ada/snames.adb-tmpl
+++ b/gcc/ada/snames.adb-tmpl
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/snames.ads-tmpl b/gcc/ada/snames.ads-tmpl
index 715a53a..a67623b 100644
--- a/gcc/ada/snames.ads-tmpl
+++ b/gcc/ada/snames.ads-tmpl
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -145,6 +145,8 @@ package Snames is
Name_Exclusive_Functions : constant Name_Id := N + $;
Name_Full_Access_Only : constant Name_Id := N + $;
Name_Integer_Literal : constant Name_Id := N + $;
+ Name_No_Controlled_Parts : constant Name_Id := N + $;
+ Name_No_Task_Parts : constant Name_Id := N + $;
Name_Real_Literal : constant Name_Id := N + $;
Name_Relaxed_Initialization : constant Name_Id := N + $;
Name_Stable_Properties : constant Name_Id := N + $;
@@ -385,10 +387,6 @@ package Snames is
-- Ada 83, Ada 95, and Ada 2005 mode as well, where they are technically
-- considered to be implementation dependent pragmas.
- -- The entries marked AAMP are AAMP specific pragmas that are recognized
- -- only in GNAT for the AAMP. They are ignored in other versions with
- -- appropriate warnings.
-
First_Pragma_Name : constant Name_Id := N + $;
-- Configuration pragmas are grouped at start. Note that there is a list
@@ -401,7 +399,7 @@ package Snames is
Name_Ada_2005 : constant Name_Id := N + $; -- GNAT
Name_Ada_12 : constant Name_Id := N + $; -- GNAT
Name_Ada_2012 : constant Name_Id := N + $; -- GNAT
- Name_Ada_2020 : constant Name_Id := N + $; -- GNAT
+ Name_Ada_2022 : constant Name_Id := N + $; -- GNAT
Name_Aggregate_Individually_Assign : constant Name_Id := N + $; -- GNAT
Name_Allow_Integer_Address : constant Name_Id := N + $; -- GNAT
Name_Annotate : constant Name_Id := N + $; -- GNAT
@@ -441,6 +439,7 @@ package Snames is
-- correctly recognize and process Fast_Math.
Name_Favor_Top_Level : constant Name_Id := N + $; -- GNAT
+ Name_GNAT_Annotate : constant Name_Id := N + $; -- GNAT
Name_Ignore_Pragma : constant Name_Id := N + $; -- GNAT
Name_Implicit_Packing : constant Name_Id := N + $; -- GNAT
Name_Initialize_Scalars : constant Name_Id := N + $; -- GNAT
@@ -480,7 +479,6 @@ package Snames is
Name_Suppress_Exception_Locations : constant Name_Id := N + $; -- GNAT
Name_Task_Dispatching_Policy : constant Name_Id := N + $;
Name_Unevaluated_Use_Of_Old : constant Name_Id := N + $; -- GNAT
- Name_Universal_Data : constant Name_Id := N + $; -- AAMP
Name_Unsuppress : constant Name_Id := N + $; -- Ada 05
Name_Use_VADS_Size : constant Name_Id := N + $; -- GNAT
Name_Validity_Checks : constant Name_Id := N + $; -- GNAT
@@ -545,7 +543,6 @@ package Snames is
Name_Export_Function : constant Name_Id := N + $; -- GNAT
Name_Export_Object : constant Name_Id := N + $; -- GNAT
Name_Export_Procedure : constant Name_Id := N + $; -- GNAT
- Name_Export_Value : constant Name_Id := N + $; -- GNAT
Name_Export_Valued_Procedure : constant Name_Id := N + $; -- GNAT
Name_Extensions_Visible : constant Name_Id := N + $; -- GNAT
Name_External : constant Name_Id := N + $; -- GNAT
@@ -800,7 +797,6 @@ package Snames is
Name_Gcc : constant Name_Id := N + $;
Name_General : constant Name_Id := N + $;
Name_Gnat : constant Name_Id := N + $;
- Name_Gnat_Annotate : constant Name_Id := N + $;
Name_Gnat_Extended_Ravenscar : constant Name_Id := N + $;
Name_Gnat_Ravenscar_EDF : constant Name_Id := N + $;
Name_Gnatprove : constant Name_Id := N + $;
@@ -831,6 +827,7 @@ package Snames is
Name_No_Access_Parameter_Allocators : constant Name_Id := N + $;
Name_No_Coextensions : constant Name_Id := N + $;
Name_No_Dependence : constant Name_Id := N + $;
+ Name_No_Dynamic_Accessibility_Checks : constant Name_Id := N + $;
Name_No_Dynamic_Attachment : constant Name_Id := N + $;
Name_No_Dynamic_Interrupts : constant Name_Id := N + $;
Name_No_Elaboration_Code : constant Name_Id := N + $;
@@ -1085,6 +1082,7 @@ package Snames is
Name_To_Any : constant Name_Id := N + $; -- GNAT
Name_Truncation : constant Name_Id := N + $;
Name_TypeCode : constant Name_Id := N + $; -- GNAT
+ Name_Valid_Value : constant Name_Id := N + $; -- GNAT
Name_Value : constant Name_Id := N + $;
Name_Wide_Image : constant Name_Id := N + $;
Name_Wide_Wide_Image : constant Name_Id := N + $;
@@ -1333,7 +1331,6 @@ package Snames is
Name_Import_Address : constant Name_Id := N + $;
Name_Import_Largest_Value : constant Name_Id := N + $;
Name_Import_Value : constant Name_Id := N + $;
- Name_Is_Negative : constant Name_Id := N + $;
Name_Line : constant Name_Id := N + $;
Name_Rotate_Left : constant Name_Id := N + $;
Name_Rotate_Right : constant Name_Id := N + $;
@@ -1611,6 +1608,7 @@ package Snames is
Attribute_To_Any,
Attribute_Truncation,
Attribute_TypeCode,
+ Attribute_Valid_Value,
Attribute_Value,
Attribute_Wide_Image,
Attribute_Wide_Wide_Image,
@@ -1705,7 +1703,6 @@ package Snames is
-- in Sem_Prag.
for Convention_Id'Size use 8;
- -- Plenty of space for expansion
subtype Convention_C_Family is Convention_Id
range Convention_C .. Convention_CPP;
@@ -1741,8 +1738,8 @@ package Snames is
Pragma_Ada_2005,
Pragma_Ada_12,
Pragma_Ada_2012,
- Pragma_Ada_2020,
- -- Note that there is no Pragma_Ada_20. Pragma_Ada_05/12 are for
+ Pragma_Ada_2022,
+ -- Note that there is no Pragma_Ada_22. Pragma_Ada_05/12 are for
-- compatibility reasons only; the full year names are preferred.
Pragma_Aggregate_Individually_Assign,
Pragma_Allow_Integer_Address,
@@ -1771,6 +1768,7 @@ package Snames is
Pragma_Extensions_Allowed,
Pragma_External_Name_Casing,
Pragma_Favor_Top_Level,
+ Pragma_GNAT_Annotate,
Pragma_Ignore_Pragma,
Pragma_Implicit_Packing,
Pragma_Initialize_Scalars,
@@ -1810,7 +1808,6 @@ package Snames is
Pragma_Suppress_Exception_Locations,
Pragma_Task_Dispatching_Policy,
Pragma_Unevaluated_Use_Of_Old,
- Pragma_Universal_Data,
Pragma_Unsuppress,
Pragma_Use_VADS_Size,
Pragma_Validity_Checks,
@@ -1861,7 +1858,6 @@ package Snames is
Pragma_Export_Function,
Pragma_Export_Object,
Pragma_Export_Procedure,
- Pragma_Export_Value,
Pragma_Export_Valued_Procedure,
Pragma_Extensions_Visible,
Pragma_External,
diff --git a/gcc/ada/socket.c b/gcc/ada/socket.c
index 8333b6b..82e0c5a 100644
--- a/gcc/ada/socket.c
+++ b/gcc/ada/socket.c
@@ -6,7 +6,7 @@
* *
* C Implementation File *
* *
- * Copyright (C) 2003-2020, Free Software Foundation, Inc. *
+ * Copyright (C) 2003-2021, Free Software Foundation, Inc. *
* *
* GNAT is free software; you can redistribute 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.adb b/gcc/ada/spark_xrefs.adb
index 5b09351..1961106 100644
--- a/gcc/ada/spark_xrefs.adb
+++ b/gcc/ada/spark_xrefs.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2011-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2011-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute 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 ffd7268..86e9fbc 100644
--- a/gcc/ada/spark_xrefs.ads
+++ b/gcc/ada/spark_xrefs.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2011-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2011-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute 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 d71c415..c1f1ede 100644
--- a/gcc/ada/sprint.adb
+++ b/gcc/ada/sprint.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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,29 +23,33 @@
-- --
------------------------------------------------------------------------------
-with Aspects; use Aspects;
-with Atree; use Atree;
-with Casing; use Casing;
-with Csets; use Csets;
-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 Rtsfind; use Rtsfind;
-with Sem_Eval; use Sem_Eval;
-with Sem_Util; use Sem_Util;
-with Sinfo; use Sinfo;
-with Sinput; use Sinput;
-with Sinput.D; use Sinput.D;
-with Snames; use Snames;
-with Stand; use Stand;
-with Stringt; use Stringt;
-with Uintp; use Uintp;
-with Uname; use Uname;
-with Urealp; use Urealp;
+with Aspects; use Aspects;
+with Atree; use Atree;
+with Casing; use Casing;
+with Csets; use Csets;
+with Debug; use Debug;
+with Einfo; use Einfo;
+with Einfo.Entities; use Einfo.Entities;
+with Einfo.Utils; use Einfo.Utils;
+with Lib; use Lib;
+with Namet; use Namet;
+with Nlists; use Nlists;
+with Opt; use Opt;
+with Output; use Output;
+with Rtsfind; use Rtsfind;
+with Sem_Eval; use Sem_Eval;
+with Sem_Util; use Sem_Util;
+with Sinfo; use Sinfo;
+with Sinfo.Nodes; use Sinfo.Nodes;
+with Sinfo.Utils; use Sinfo.Utils;
+with Sinput; use Sinput;
+with Sinput.D; use Sinput.D;
+with Snames; use Snames;
+with Stand; use Stand;
+with Stringt; use Stringt;
+with Uintp; use Uintp;
+with Uname; use Uname;
+with Urealp; use Urealp;
package body Sprint is
Current_Source_File : Source_File_Index;
@@ -1061,16 +1065,12 @@ package body Sprint is
if Present (Expressions (Node)) then
Sprint_Comma_List (Expressions (Node));
- if Present (Component_Associations (Node))
- and then not Is_Empty_List (Component_Associations (Node))
- then
+ if not Is_Empty_List (Component_Associations (Node)) then
Write_Str (", ");
end if;
end if;
- if Present (Component_Associations (Node))
- and then not Is_Empty_List (Component_Associations (Node))
- then
+ if not Is_Empty_List (Component_Associations (Node)) then
Indent_Begin;
declare
@@ -2114,6 +2114,13 @@ package body Sprint is
Write_Indent;
end if;
+ when N_Goto_When_Statement =>
+ Write_Indent_Str_Sloc ("goto ");
+ Sprint_Node (Name (Node));
+ Write_Str (" when ");
+ Sprint_Node (Condition (Node));
+ Write_Char (';');
+
when N_Handled_Sequence_Of_Statements =>
Set_Debug_Sloc;
Sprint_Indented_List (Statements (Node));
@@ -2489,7 +2496,7 @@ package body Sprint is
-- AI12-0275: Object_Renaming_Declaration without explicit subtype
- elsif Ada_Version >= Ada_2020 then
+ elsif Ada_Version >= Ada_2022 then
null;
else
@@ -3065,10 +3072,29 @@ package body Sprint is
Write_Char (';');
+ when N_Raise_When_Statement =>
+ Write_Indent_Str_Sloc ("raise ");
+ Sprint_Node (Name (Node));
+ Write_Str (" when ");
+ Sprint_Node (Condition (Node));
+
+ if Present (Expression (Node)) then
+ Write_Str_With_Col_Check_Sloc (" with ");
+ Sprint_Node (Expression (Node));
+ end if;
+
+ Write_Char (';');
+
when N_Range =>
Sprint_Node (Low_Bound (Node));
Write_Str_Sloc (" .. ");
- Sprint_Node (High_Bound (Node));
+ if Present (Etype (Node))
+ and then Is_Fixed_Lower_Bound_Index_Subtype (Etype (Node))
+ then
+ Write_Str ("<>");
+ else
+ Sprint_Node (High_Bound (Node));
+ end if;
Update_Itype (Node);
when N_Range_Constraint =>
@@ -3132,10 +3158,12 @@ package body Sprint is
Write_Char (';');
- -- Don't we want to print more detail???
-
- -- Doc of this extended syntax belongs in sinfo.ads and/or
- -- sprint.ads ???
+ when N_Return_When_Statement =>
+ Write_Indent_Str_Sloc ("return ");
+ Sprint_Node (Expression (Node));
+ Write_Str (" when ");
+ Sprint_Node (Condition (Node));
+ Write_Char (';');
when N_SCIL_Dispatch_Table_Tag_Init =>
Write_Indent_Str ("[N_SCIL_Dispatch_Table_Tag_Init]");
@@ -4578,7 +4606,8 @@ package body Sprint is
Write_Str (");");
end;
- -- For all other Itypes, print ??? (fill in later)
+ -- For all other Itypes, print a triple ? (fill in later
+ -- if needed).
when others =>
Write_Header (True);
@@ -4841,7 +4870,10 @@ package body Sprint is
Write_Int (Int (L));
Write_Str (": ");
- while Src (Loc) not in Line_Terminator loop
+ -- We need to check for EOF here, in case the last line of the source
+ -- file does not have a Line_Terminator.
+
+ while Src (Loc) not in Line_Terminator | EOF loop
Write_Char (Src (Loc));
Loc := Loc + 1;
end loop;
diff --git a/gcc/ada/sprint.ads b/gcc/ada/sprint.ads
index 5cdf754..f05356e 100644
--- a/gcc/ada/sprint.ads
+++ b/gcc/ada/sprint.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/stand.ads b/gcc/ada/stand.ads
index 848239f..f322656 100644
--- a/gcc/ada/stand.ads
+++ b/gcc/ada/stand.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -335,12 +335,12 @@ package Stand is
-- This is a type used to represent the Etype of exceptions
Standard_A_String : Entity_Id;
- -- An access to String type used for building elements of tables
- -- carrying the enumeration literal names.
+ -- An access to String type used for building elements of tables carrying
+ -- the enumeration literal names.
Standard_A_Char : Entity_Id;
- -- Access to character, used as a component of the exception type to denote
- -- a thin pointer component.
+ -- An access to character type, used as a component of the exception type
+ -- to denote a thin pointer component. Needed for non-GCC back-ends.
Standard_Debug_Renaming_Type : Entity_Id;
-- A zero-size subtype of Integer, used as the type of variables used to
diff --git a/gcc/ada/stringt.adb b/gcc/ada/stringt.adb
index 5cdf12c..d97e60e 100644
--- a/gcc/ada/stringt.adb
+++ b/gcc/ada/stringt.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/stringt.ads b/gcc/ada/stringt.ads
index 77a794e..ff15a0c 100644
--- a/gcc/ada/stringt.ads
+++ b/gcc/ada/stringt.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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,7 +56,7 @@ package Stringt is
--------------------------------------
procedure Initialize;
- -- Initializes the strings table for a new compilation.
+ -- Initializes the strings table for a new compilation
procedure Lock;
-- Lock internal tables before calling back end
diff --git a/gcc/ada/stringt.h b/gcc/ada/stringt.h
index 5cbb301..701b0aa 100644
--- a/gcc/ada/stringt.h
+++ b/gcc/ada/stringt.h
@@ -6,7 +6,7 @@
* *
* C Header File *
* *
- * Copyright (C) 1992-2020, Free Software Foundation, Inc. *
+ * Copyright (C) 1992-2021, Free Software Foundation, Inc. *
* *
* GNAT is free software; you can redistribute 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 4b39fe7..c2bff83 100644
--- a/gcc/ada/style.adb
+++ b/gcc/ada/style.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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,18 +23,22 @@
-- --
------------------------------------------------------------------------------
-with Atree; use Atree;
-with Casing; use Casing;
-with Csets; use Csets;
-with Einfo; use Einfo;
-with Errout; use Errout;
-with Namet; use Namet;
-with Nlists; use Nlists;
-with Opt; use Opt;
-with Sinfo; use Sinfo;
-with Sinput; use Sinput;
-with Stand; use Stand;
-with Stylesw; use Stylesw;
+with Atree; use Atree;
+with Casing; use Casing;
+with Csets; use Csets;
+with Einfo; use Einfo;
+with Einfo.Entities; use Einfo.Entities;
+with Einfo.Utils; use Einfo.Utils;
+with Errout; use Errout;
+with Namet; use Namet;
+with Nlists; use Nlists;
+with Opt; use Opt;
+with Sinfo; use Sinfo;
+with Sinfo.Nodes; use Sinfo.Nodes;
+with Sinfo.Utils; use Sinfo.Utils;
+with Sinput; use Sinput;
+with Stand; use Stand;
+with Stylesw; use Stylesw;
package body Style is
@@ -132,48 +136,42 @@ package body Style is
Tref := Source_Text (Get_Source_File_Index (Sref));
Tdef := Source_Text (Get_Source_File_Index (Sdef));
- -- Ignore operator name case completely. This also catches the
- -- case of where one is an operator and the other is not. This
- -- is a phenomenon from rewriting of operators as functions,
- -- and is to be ignored.
+ -- Ignore case of operator names. This also catches the case
+ -- where one is an operator and the other is not. This is a
+ -- phenomenon from rewriting of operators as functions, and is
+ -- to be ignored.
if Tref (Sref) = '"' or else Tdef (Sdef) = '"' then
return;
else
- while Tref (Sref) = Tdef (Sdef) loop
+ loop
+ -- If end of identifiers, all done. Note that they are the
+ -- same length.
- -- If end of identifier, all done
+ pragma Assert
+ (Identifier_Char (Tref (Sref)) =
+ Identifier_Char (Tdef (Sdef)));
if not Identifier_Char (Tref (Sref)) then
return;
-
- -- Otherwise loop continues
-
- else
- Sref := Sref + 1;
- Sdef := Sdef + 1;
end if;
- end loop;
- -- Fall through loop when mismatch between identifiers
- -- If either identifier is not terminated, error.
+ -- Case mismatch
- if Identifier_Char (Tref (Sref))
- or else
- Identifier_Char (Tdef (Sdef))
- then
- Error_Msg_Node_1 := Def;
- Error_Msg_Sloc := Sloc (Def);
- Error_Msg -- CODEFIX
- ("(style) bad casing of & declared#", Sref, Ref);
- return;
+ if Tref (Sref) /= Tdef (Sdef) then
+ Error_Msg_Node_1 := Def;
+ Error_Msg_Sloc := Sloc (Def);
+ Error_Msg -- CODEFIX
+ ("(style) bad casing of & declared#", Sref, Ref);
+ return;
+ end if;
- -- Else end of identifiers, and they match
+ Sref := Sref + 1;
+ Sdef := Sdef + 1;
+ end loop;
- else
- return;
- end if;
+ pragma Assert (False);
end if;
end if;
@@ -267,11 +265,15 @@ package body Style is
-- indicators were introduced in Ada 2005. We apply Comes_From_Source
-- to Original_Node to catch the case of a procedure body declared with
-- "is null" that has been rewritten as a normal empty body.
+ -- We do not emit a warning on an inherited operation that comes from
+ -- a type derivation.
if Style_Check_Missing_Overriding
and then (Comes_From_Source (Original_Node (N))
or else Is_Generic_Instance (E))
and then Ada_Version_Explicit >= Ada_2005
+ and then Present (Parent (E))
+ and then Nkind (Parent (E)) /= N_Full_Type_Declaration
then
-- If the subprogram is an instantiation, its declaration appears
-- within a wrapper package that precedes the instance node. Place
diff --git a/gcc/ada/style.ads b/gcc/ada/style.ads
index dce4f1e..60f542f 100644
--- a/gcc/ada/style.ads
+++ b/gcc/ada/style.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute 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 565c41a..188af1a 100644
--- a/gcc/ada/styleg.adb
+++ b/gcc/ada/styleg.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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,16 +27,18 @@
-- checking rules. For documentation of these rules, see comments on the
-- individual procedures.
-with Atree; use Atree;
-with Casing; use Casing;
-with Csets; use Csets;
-with Einfo; use Einfo;
-with Err_Vars; use Err_Vars;
-with Opt; use Opt;
-with Scans; use Scans;
-with Sinfo; use Sinfo;
-with Sinput; use Sinput;
-with Stylesw; use Stylesw;
+with Atree; use Atree;
+with Casing; use Casing;
+with Csets; use Csets;
+with Einfo; use Einfo;
+with Einfo.Utils; use Einfo.Utils;
+with Err_Vars; use Err_Vars;
+with Opt; use Opt;
+with Scans; use Scans;
+with Sinfo; use Sinfo;
+with Sinfo.Nodes; use Sinfo.Nodes;
+with Sinput; use Sinput;
+with Stylesw; use Stylesw;
package body Styleg is
@@ -82,7 +84,6 @@ package body Styleg is
function Is_White_Space (C : Character) return Boolean;
pragma Inline (Is_White_Space);
-- Returns True for space or HT, False otherwise
- -- What about VT and FF, should they return True ???
procedure Require_Following_Space;
pragma Inline (Require_Following_Space);
@@ -98,12 +99,13 @@ package body Styleg is
-- Check_Abs_Or_Not --
----------------------
- -- In check token mode (-gnatyt), ABS/NOT must be followed by a space
+ -- In check token mode (-gnatyt), ABS/NOT must be followed by a space or
+ -- a line feed.
procedure Check_Abs_Not is
begin
if Style_Check_Tokens then
- if Source (Scan_Ptr) > ' ' then -- ???
+ if Source (Scan_Ptr) not in ' ' | ASCII.CR | ASCII.LF then
Error_Space_Required (Scan_Ptr);
end if;
end if;
@@ -113,7 +115,7 @@ package body Styleg is
-- Check_Apostrophe --
----------------------
- -- Do not allow space before or after apostrophe -- OR AFTER???
+ -- Do not allow space after apostrophe
procedure Check_Apostrophe is
begin
diff --git a/gcc/ada/styleg.ads b/gcc/ada/styleg.ads
index ef645a8..6930246 100644
--- a/gcc/ada/styleg.ads
+++ b/gcc/ada/styleg.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute 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 43f6e1a..f4e4d9c 100644
--- a/gcc/ada/stylesw.adb
+++ b/gcc/ada/stylesw.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute 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 f78b01d..1a5f1e9 100644
--- a/gcc/ada/stylesw.ads
+++ b/gcc/ada/stylesw.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute 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 4ae5c30..a735978 100644
--- a/gcc/ada/switch-b.adb
+++ b/gcc/ada/switch-b.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2001-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2001-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -369,13 +369,7 @@ package body Switch.B is
Ptr := Ptr + 1;
C := Switch_Chars (Ptr);
- if C in '1' .. '5'
- or else C = '8'
- or else C = 'p'
- or else C = 'f'
- or else C = 'n'
- or else C = 'w'
- then
+ if C in '1' .. '5' | '9' | 'p' | '8' | 'f' | 'n' | 'w' then
Identifier_Character_Set := C;
Ptr := Ptr + 1;
else
diff --git a/gcc/ada/switch-b.ads b/gcc/ada/switch-b.ads
index a1461b5..4acd2fc 100644
--- a/gcc/ada/switch-b.ads
+++ b/gcc/ada/switch-b.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2001-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2001-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute 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 c6eb063..020be63 100644
--- a/gcc/ada/switch-c.adb
+++ b/gcc/ada/switch-c.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2001-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2001-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -112,7 +112,7 @@ package body Switch.C is
when '3' =>
if Standard_Long_Long_Integer_Size /= 64 then
- Bad_Switch ("-gnato3 not implemented for this configuration");
+ Bad_Switch ("-gnato3 requires Long_Long_Integer'Size = 64");
else
return Eliminated;
end if;
@@ -427,7 +427,7 @@ package body Switch.C is
-- The reason for this prohibition is that the rewriting of
-- Sloc values causes strange malfunctions in the tests of
-- whether units belong to the main source. This is really a
- -- bug, but too hard to fix for a marginal capability ???
+ -- bug, but too hard to fix for a marginal capability.
-- The proper fix is to completely redo -gnatD processing so
-- that the tree is not messed with, and instead a separate
@@ -929,14 +929,7 @@ package body Switch.C is
Ptr := Ptr + 1;
C := Switch_Chars (Ptr);
- if C in '1' .. '5'
- or else C = '8'
- or else C = '9'
- or else C = 'p'
- or else C = 'f'
- or else C = 'n'
- or else C = 'w'
- then
+ if C in '1' .. '5' | '8' | 'p' | '9' | 'f' | 'n' | 'w' then
Identifier_Character_Set := C;
Ptr := Ptr + 1;
@@ -1399,9 +1392,8 @@ package body Switch.C is
when 'X' =>
Ptr := Ptr + 1;
- Extensions_Allowed := True;
- Ada_Version := Ada_Version_Type'Last;
- Ada_Version_Explicit := Ada_Version_Type'Last;
+ Ada_Version := Ada_With_Extensions;
+ Ada_Version_Explicit := Ada_With_Extensions;
Ada_Version_Pragma := Empty;
-- -gnaty (style checks)
@@ -1588,8 +1580,10 @@ package body Switch.C is
elsif Switch_Chars (Ptr .. Ptr + 3) = "2012" then
Ada_Version := Ada_2012;
- elsif Switch_Chars (Ptr .. Ptr + 3) = "2020" then
- Ada_Version := Ada_2020;
+ elsif Switch_Chars (Ptr .. Ptr + 3) = "2020"
+ or else Switch_Chars (Ptr .. Ptr + 3) = "2022"
+ then
+ Ada_Version := Ada_2022;
else
Bad_Switch ("-gnat" & Switch_Chars (Ptr .. Ptr + 3));
@@ -1620,11 +1614,6 @@ package body Switch.C is
Ptr := Ptr + 1;
end if;
- -- We ignore '/' in switches, this is historical, still needed???
-
- when '/' =>
- Store_Switch := False;
-
-- Anything else is an error (illegal switch character)
when others =>
diff --git a/gcc/ada/switch-c.ads b/gcc/ada/switch-c.ads
index fd258ca..a9d6ef7 100644
--- a/gcc/ada/switch-c.ads
+++ b/gcc/ada/switch-c.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2001-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2001-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute 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 ec4e3ff..99082fe 100644
--- a/gcc/ada/switch-m.adb
+++ b/gcc/ada/switch-m.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2001-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2001-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute 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 1165dab..9edc50b 100644
--- a/gcc/ada/switch-m.ads
+++ b/gcc/ada/switch-m.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2001-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2001-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute 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 5da63eb..d8aecde 100644
--- a/gcc/ada/switch.adb
+++ b/gcc/ada/switch.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute 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.ads b/gcc/ada/switch.ads
index 7fdfb52..8ea9c27 100644
--- a/gcc/ada/switch.ads
+++ b/gcc/ada/switch.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -79,7 +79,7 @@ package Switch is
-- Returns True iff Switch_Chars represents an internal GCC switch to be
-- 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.
+ -- files and may safely be ignored by non-GCC back ends.
function Switch_Last (Switch_Chars : String) return Natural;
-- Index in Switch_Chars of the last relevant character for later string
diff --git a/gcc/ada/sysdep.c b/gcc/ada/sysdep.c
index 51ffbd5..aa38c5c 100644
--- a/gcc/ada/sysdep.c
+++ b/gcc/ada/sysdep.c
@@ -6,7 +6,7 @@
* *
* C Implementation File *
* *
- * Copyright (C) 1992-2020, Free Software Foundation, Inc. *
+ * Copyright (C) 1992-2021, Free Software Foundation, Inc. *
* *
* GNAT is free software; you can redistribute it and/or modify it under *
* terms of the GNU General Public License as published by the Free Soft- *
diff --git a/gcc/ada/table.adb b/gcc/ada/table.adb
index 316d35e..02f8f79 100644
--- a/gcc/ada/table.adb
+++ b/gcc/ada/table.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/table.ads b/gcc/ada/table.ads
index 8d1b8d7..e934c27 100644
--- a/gcc/ada/table.ads
+++ b/gcc/ada/table.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/targext.c b/gcc/ada/targext.c
index 2dea975..90174a1 100644
--- a/gcc/ada/targext.c
+++ b/gcc/ada/targext.c
@@ -6,7 +6,7 @@
* *
* C Implementation File *
* *
- * Copyright (C) 2005-2020, Free Software Foundation, Inc. *
+ * Copyright (C) 2005-2021, Free Software Foundation, Inc. *
* *
* GNAT is free software; you can redistribute 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 cbc3f89..4390c0e 100644
--- a/gcc/ada/targparm.adb
+++ b/gcc/ada/targparm.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1999-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1999-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute 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.ads b/gcc/ada/targparm.ads
index 5195a39..302247f 100644
--- a/gcc/ada/targparm.ads
+++ b/gcc/ada/targparm.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1999-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1999-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -177,12 +177,12 @@ package Targparm is
-- The default values here are used if no value is found in system.ads.
-- This should normally happen if the special version of system.ads used
-- by the compiler itself is in use or if the value is only relevant to a
- -- particular target (e.g. AAMP). The default values are suitable for use
- -- in normal environments. This approach allows the possibility of new
- -- versions of the compiler (possibly with new system parameters added)
- -- being used to compile older versions of the compiler sources, as well as
- -- avoiding duplicating values in all system-*.ads files for flags that are
- -- used on a few platforms only.
+ -- particular target. The default values are suitable for use in normal
+ -- environments. This approach allows the possibility of new versions of
+ -- the compiler (possibly with new system parameters added) being used to
+ -- compile older versions of the compiler sources, as well as avoiding
+ -- duplicating values in all system-*.ads files for flags that are used on
+ -- a few platforms only.
-- All these parameters should be regarded as read only by all clients
-- of the package. The only way they get modified is by calling the
@@ -365,12 +365,12 @@ package Targparm is
-- this flag is False, and the use of aggregates is not permitted.
Support_Atomic_Primitives_On_Target : Boolean := False;
- -- If this flag is True, then the back-end support GCC built-in atomic
- -- operations for memory model such as atomic load or atomic compare
+ -- If this flag is True, then the back end supports GCC built-in atomic
+ -- operations for memory model, such as atomic load or atomic compare
-- exchange (see the GCC manual for more information). If the flag is
- -- False, then the back-end doesn't provide this support. Note this flag is
- -- set to True only if the target supports all atomic primitives up to 64
- -- bits. ??? To be modified.
+ -- False, then the back end doesn't provide this support. Note that this
+ -- flag is set to True only if the target supports all atomic primitives
+ -- up to 64 bits.
Support_Composite_Assign_On_Target : Boolean := True;
-- The assignment of composite objects other than small records and
@@ -469,10 +469,10 @@ package Targparm is
-- Command Line Arguments --
----------------------------
- -- For most ports of GNAT, command line arguments are supported. The
- -- following flag is set to False for targets that do not support
- -- command line arguments (VxWorks and AAMP). Note that support of
- -- command line arguments is not required on such targets (RM A.15(13)).
+ -- Command line arguments are supported on most targets. The following flag
+ -- is set to False for targets that do not support command line arguments
+ -- (i.e. VxWorks). Note that support for command line arguments is not
+ -- required on such targets (RM A.15(13)).
Command_Line_Args_On_Target : Boolean := True;
-- Set False if no command line arguments on target. Note that if this
@@ -480,8 +480,8 @@ package Targparm is
-- this causes suppression of generation of the argv/argc variables
-- used to record command line arguments.
- -- Similarly, most ports support the use of an exit status, but AAMP
- -- is an exception (as allowed by RM A.15(18-20))
+ -- Similarly, most targets support the use of an exit status, but other
+ -- targets might not, as allowed by RM A.15(18-20).
Exit_Status_Supported_On_Target : Boolean := True;
-- Set False if returning of an exit status is not supported on target.
diff --git a/gcc/ada/tbuild.adb b/gcc/ada/tbuild.adb
index 3b33ee7..4d9c1c4 100644
--- a/gcc/ada/tbuild.adb
+++ b/gcc/ada/tbuild.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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,22 +23,24 @@
-- --
------------------------------------------------------------------------------
-with Atree; use Atree;
-with Aspects; use Aspects;
-with Csets; use Csets;
-with Einfo; use Einfo;
-with Elists; use Elists;
-with Lib; use Lib;
-with Nlists; use Nlists;
-with Nmake; use Nmake;
-with Opt; use Opt;
-with Restrict; use Restrict;
-with Rident; use Rident;
-with Sem_Aux; use Sem_Aux;
-with Snames; use Snames;
-with Stand; use Stand;
-with Stringt; use Stringt;
-with Urealp; use Urealp;
+with Atree; use Atree;
+with Aspects; use Aspects;
+with Csets; use Csets;
+with Einfo; use Einfo;
+with Einfo.Entities; use Einfo.Entities;
+with Einfo.Utils; use Einfo.Utils;
+with Lib; use Lib;
+with Nlists; use Nlists;
+with Nmake; use Nmake;
+with Opt; use Opt;
+with Restrict; use Restrict;
+with Rident; use Rident;
+with Sinfo.Utils; use Sinfo.Utils;
+with Sem_Util; use Sem_Util;
+with Snames; use Snames;
+with Stand; use Stand;
+with Stringt; use Stringt;
+with Urealp; use Urealp;
package body Tbuild is
@@ -113,6 +115,7 @@ package body Tbuild is
----------------
function Convert_To (Typ : Entity_Id; Expr : Node_Id) return Node_Id is
+ pragma Assert (Is_Type (Typ));
Result : Node_Id;
begin
@@ -181,32 +184,6 @@ package body Tbuild is
return N;
end Make_Byte_Aligned_Attribute_Reference;
- --------------------
- -- Make_DT_Access --
- --------------------
-
- function Make_DT_Access
- (Loc : Source_Ptr;
- Rec : Node_Id;
- Typ : Entity_Id) return Node_Id
- is
- Full_Type : Entity_Id := Typ;
-
- begin
- if Is_Private_Type (Typ) then
- Full_Type := Underlying_Type (Typ);
- end if;
-
- return
- Unchecked_Convert_To (
- New_Occurrence_Of
- (Etype (Node (First_Elmt (Access_Disp_Table (Full_Type)))), Loc),
- Make_Selected_Component (Loc,
- Prefix => New_Copy (Rec),
- Selector_Name =>
- New_Occurrence_Of (First_Tag_Component (Full_Type), Loc)));
- end Make_DT_Access;
-
------------------------
-- Make_Float_Literal --
------------------------
@@ -348,14 +325,42 @@ package body Tbuild is
Has_Created_Identifier : Boolean := False;
End_Label : Node_Id := Empty) return Node_Id
is
- begin
- Check_Restriction (No_Implicit_Loops, Node);
+ P : Node_Id;
+ Check_Restrictions : Boolean := True;
+ begin
+ -- Do not check restrictions if the implicit loop statement is part
+ -- of a dead branch: False and then ...
+ -- This will occur in particular as part of the expansion of pragma
+ -- Assert when assertions are disabled.
+
+ P := Parent (Node);
+ while Present (P) loop
+ if Nkind (P) = N_And_Then then
+ if Nkind (Left_Opnd (P)) = N_Identifier
+ and then Entity (Left_Opnd (P)) = Standard_False
+ then
+ Check_Restrictions := False;
+ exit;
+ end if;
- 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);
+ -- Prevent the search from going too far
+
+ elsif Is_Body_Or_Package_Declaration (P) then
+ exit;
+ end if;
+
+ P := Parent (P);
+ end loop;
+
+ if Check_Restrictions then
+ 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);
+ end if;
end if;
return Make_Loop_Statement (Sloc (Node),
@@ -874,26 +879,34 @@ package body Tbuild is
(Typ : Entity_Id;
Expr : Node_Id) return Node_Id
is
+ pragma Assert (Ekind (Typ) in E_Void | Type_Kind);
+ -- We don't really want to allow E_Void here, but existing code passes
+ -- it.
+
Loc : constant Source_Ptr := Sloc (Expr);
Result : Node_Id;
- Expr_Parent : Node_Id;
begin
-- If the expression is already of the correct type, then nothing
- -- to do, except for relocating the node in case this is required.
+ -- to do, except for relocating the node
if Present (Etype (Expr))
- and then (Base_Type (Etype (Expr)) = Typ
- or else Etype (Expr) = Typ)
+ and then (Base_Type (Etype (Expr)) = Typ or else Etype (Expr) = Typ)
then
return Relocate_Node (Expr);
- -- Case where the expression is itself an unchecked conversion to
- -- the same type, and we can thus eliminate the outer conversion.
+ -- Case where the expression is already an unchecked conversion. We
+ -- replace the type being converted to, to avoid creating an unchecked
+ -- conversion of an unchecked conversion. Extra unchecked conversions
+ -- make the .dg output less readable. We can't do this in cases
+ -- involving bitfields, because the sizes might not match. The
+ -- Is_Composite_Type checks avoid such cases.
elsif Nkind (Expr) = N_Unchecked_Type_Conversion
- and then Entity (Subtype_Mark (Expr)) = Typ
+ and then Is_Composite_Type (Etype (Expr))
+ and then Is_Composite_Type (Typ)
then
+ Set_Subtype_Mark (Expr, New_Occurrence_Of (Typ, Loc));
Result := Relocate_Node (Expr);
elsif Nkind (Expr) = N_Null
@@ -906,18 +919,15 @@ package body Tbuild is
-- All other cases
else
- -- Capture the parent of the expression before relocating it and
- -- creating the conversion, so the conversion's parent can be set
- -- to the original parent below.
-
- Expr_Parent := Parent (Expr);
-
- Result :=
- Make_Unchecked_Type_Conversion (Loc,
- Subtype_Mark => New_Occurrence_Of (Typ, Loc),
- Expression => Relocate_Node (Expr));
-
- Set_Parent (Result, Expr_Parent);
+ declare
+ Expr_Parent : constant Node_Id := Parent (Expr);
+ begin
+ Result :=
+ Make_Unchecked_Type_Conversion (Loc,
+ Subtype_Mark => New_Occurrence_Of (Typ, Loc),
+ Expression => Relocate_Node (Expr));
+ Set_Parent (Result, Expr_Parent);
+ end;
end if;
Set_Etype (Result, Typ);
diff --git a/gcc/ada/tbuild.ads b/gcc/ada/tbuild.ads
index 70bf653..eb17865 100644
--- a/gcc/ada/tbuild.ads
+++ b/gcc/ada/tbuild.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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,10 +26,11 @@
-- This package contains various utility procedures to assist in building
-- specific types of tree nodes.
-with Namet; use Namet;
-with Sinfo; use Sinfo;
-with Types; use Types;
-with Uintp; use Uintp;
+with Namet; use Namet;
+with Sinfo; use Sinfo;
+with Sinfo.Nodes; use Sinfo.Nodes;
+with Types; use Types;
+with Uintp; use Uintp;
package Tbuild is
@@ -40,19 +41,16 @@ package Tbuild is
-- except that it will be analyzed and resolved with checks off.
function Convert_To (Typ : Entity_Id; Expr : Node_Id) return Node_Id;
- -- Returns an expression that represents the result of a checked convert
- -- of expression Exp to type T. If the base type of Exp is T, then no
- -- conversion is required, and Exp is returned unchanged. Otherwise an
- -- N_Type_Conversion node is constructed to convert the expression.
- -- If an N_Type_Conversion node is required, Relocate_Node is used on
- -- Exp. This means that it is safe to replace a node by a Convert_To
- -- of itself to some other type.
+ -- Returns an expression that is a type conversion of expression Expr to
+ -- type Typ. If the type of Expr is Typ, then no conversion is required.
+ -- Otherwise an N_Type_Conversion node is constructed to convert the
+ -- expression. Relocate_Node is applied to Expr, so that it is safe to
+ -- replace a node by a Convert_To of itself to some other type.
procedure Convert_To_And_Rewrite (Typ : Entity_Id; Expr : Node_Id);
pragma Inline (Convert_To_And_Rewrite);
-- Like the function, except that there is an extra step of calling
-- Rewrite on the Expr node and replacing it with the converted result.
- -- As noted above, this is safe, because Relocate_Node is called.
procedure Discard_Node (N : Node_Or_Entity_Id);
pragma Inline (Discard_Node);
@@ -77,11 +75,6 @@ package Tbuild is
-- Must_Be_Byte_Aligned is set in the attribute reference node. The
-- Attribute_Name must be Name_Address or Name_Unrestricted_Access.
- function Make_DT_Access
- (Loc : Source_Ptr; Rec : Node_Id; Typ : Entity_Id) return Node_Id;
- -- Create an access to the Dispatch Table by using the Tag field of a
- -- tagged record : Acc_Dt (Rec.tag).all
-
function Make_Float_Literal
(Loc : Source_Ptr;
Radix : Uint;
@@ -318,13 +311,12 @@ package Tbuild is
function New_Occurrence_Of
(Def_Id : Entity_Id;
Loc : Source_Ptr) return Node_Id;
- -- New_Occurrence_Of creates an N_Identifier node which is an occurrence
- -- of the defining identifier which is passed as its argument. The Entity
- -- and Etype of the result are set from the given defining identifier as
- -- follows: Entity is simply a copy of Def_Id. Etype is a copy of Def_Id
- -- for types, and a copy of the Etype of Def_Id for other entities. Note
- -- that Is_Static_Expression is set if this call creates an occurrence of
- -- an enumeration literal.
+ -- New_Occurrence_Of creates an N_Identifier node that is an occurrence of
+ -- the defining identifier Def_Id. The Entity and Etype of the result are
+ -- set from the given defining identifier as follows: Entity is a copy of
+ -- Def_Id. Etype is a copy of Def_Id for types, and a copy of the Etype of
+ -- Def_Id for other entities. Note that Is_Static_Expression is set if this
+ -- call creates an occurrence of an enumeration literal.
function New_Suffixed_Name
(Related_Id : Name_Id;
@@ -348,7 +340,10 @@ package Tbuild is
(Typ : Entity_Id;
Expr : Node_Id) return Node_Id;
-- Like Convert_To, but if a conversion is actually needed, constructs an
- -- N_Unchecked_Type_Conversion node to do the required conversion.
+ -- N_Unchecked_Type_Conversion node to do the required conversion. Unlike
+ -- Convert_To, a new node is not required if Expr is already of the correct
+ -- BASE type, and if a new node is created, the Parent of Expr is copied to
+ -- it.
-------------------------------------
-- Subprograms for Use by Gnat1drv --
diff --git a/gcc/ada/tempdir.adb b/gcc/ada/tempdir.adb
index c707395..0273496 100644
--- a/gcc/ada/tempdir.adb
+++ b/gcc/ada/tempdir.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2003-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2003-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute 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 dbd6564..c1ac5a7 100644
--- a/gcc/ada/tempdir.ads
+++ b/gcc/ada/tempdir.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2003-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2003-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute 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 ec9db3a..a2dd489 100644
--- a/gcc/ada/terminals.c
+++ b/gcc/ada/terminals.c
@@ -6,7 +6,7 @@
* *
* C Implementation File *
* *
- * Copyright (C) 2008-2020, AdaCore *
+ * Copyright (C) 2008-2021, 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/tracebak.c b/gcc/ada/tracebak.c
index 23ed8da..4f1699f 100644
--- a/gcc/ada/tracebak.c
+++ b/gcc/ada/tracebak.c
@@ -6,7 +6,7 @@
* *
* C Implementation File *
* *
- * Copyright (C) 2000-2020, Free Software Foundation, Inc. *
+ * Copyright (C) 2000-2021, Free Software Foundation, Inc. *
* *
* GNAT is free software; you can redistribute it and/or modify it under *
* terms of the GNU General Public License as published by the Free Soft- *
diff --git a/gcc/ada/treepr.adb b/gcc/ada/treepr.adb
index ee1b3ba..054d06c 100644
--- a/gcc/ada/treepr.adb
+++ b/gcc/ada/treepr.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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,36 +23,35 @@
-- --
------------------------------------------------------------------------------
-with Aspects; use Aspects;
-with Atree; use Atree;
-with Csets; use Csets;
-with Debug; use Debug;
-with Einfo; use Einfo;
-with Elists; use Elists;
-with Lib; use Lib;
-with Namet; use Namet;
-with Nlists; use Nlists;
-with Output; use Output;
-with Sem_Mech; use Sem_Mech;
-with Sinfo; use Sinfo;
-with Snames; use Snames;
-with Sinput; use Sinput;
-with Stand; use Stand;
-with Stringt; use Stringt;
-with SCIL_LL; use SCIL_LL;
-with Treeprs; use Treeprs;
-with Uintp; use Uintp;
-with Urealp; use Urealp;
-with Uname; use Uname;
+with Aspects; use Aspects;
+with Atree; use Atree;
+with Csets; use Csets;
+with Debug; use Debug;
+with Einfo; use Einfo;
+with Einfo.Entities; use Einfo.Entities;
+with Einfo.Utils; use Einfo.Utils;
+with Elists; use Elists;
+with Lib; use Lib;
+with Namet; use Namet;
+with Nlists; use Nlists;
+with Output; use Output;
+with Seinfo; use Seinfo;
+with Sinfo; use Sinfo;
+with Sinfo.Nodes; use Sinfo.Nodes;
+with Sinfo.Utils; use Sinfo.Utils;
+with Snames; use Snames;
+with Sinput; use Sinput;
+with Stand; use Stand;
+with Stringt; use Stringt;
+with SCIL_LL; use SCIL_LL;
+with Uintp; use Uintp;
+with Urealp; use Urealp;
+with Uname; use Uname;
+with Unchecked_Conversion;
with Unchecked_Deallocation;
package body Treepr is
- use Atree.Unchecked_Access;
- -- This module uses the unchecked access functions in package Atree
- -- since it does an untyped traversal of the tree (we do not want to
- -- count on the structure of the tree being correct in this routine).
-
----------------------------------
-- Approach Used for Tree Print --
----------------------------------
@@ -77,6 +76,10 @@ package body Treepr is
-- Global Variables --
----------------------
+ Print_Low_Level_Info : Boolean := False with Warnings => Off;
+ -- Set True to print low-level information useful for debugging Atree and
+ -- the like.
+
type Hash_Record is record
Serial : Nat;
-- Serial number for hash table entry. A value of zero means that
@@ -120,14 +123,24 @@ package body Treepr is
-- Local Procedures --
----------------------
- procedure Print_End_Span (N : Node_Id);
- -- Special routine to print contents of End_Span field of node N.
- -- The format includes the implicit source location as well as the
- -- value of the field.
+ function From_Union is new Unchecked_Conversion (Union_Id, Uint);
+ function From_Union is new Unchecked_Conversion (Union_Id, Ureal);
+
+ function Capitalize (S : String) return String;
+ procedure Capitalize (S : in out String);
+ -- Turns an identifier into Mixed_Case
+
+ function Image (F : Node_Field) return String;
+
+ function Image (F : Entity_Field) return String;
procedure Print_Init;
-- Initialize for printing of tree with descendants
+ procedure Print_End_Span (N : Node_Id);
+ -- Print contents of End_Span field of node N. The format includes the
+ -- implicit source location as well as the value of the field.
+
procedure Print_Term;
-- Clean up after printing of tree with descendants
@@ -172,10 +185,30 @@ package body Treepr is
-- extension, using routines in Einfo to get the field names and flags.
procedure Print_Field (Val : Union_Id; Format : UI_Format := Auto);
+ procedure Print_Field
+ (Prefix : String;
+ Field : String;
+ N : Node_Or_Entity_Id;
+ FD : Field_Descriptor;
+ Format : UI_Format);
-- Print representation of Field value (name, tree, string, uint, charcode)
-- The format parameter controls the format of printing in the case of an
-- integer value (see UI_Write for details).
+ procedure Print_Node_Field
+ (Prefix : String;
+ Field : Node_Field;
+ N : Node_Id;
+ FD : Field_Descriptor;
+ Format : UI_Format := Auto);
+
+ procedure Print_Entity_Field
+ (Prefix : String;
+ Field : Entity_Field;
+ N : Entity_Id;
+ FD : Field_Descriptor;
+ Format : UI_Format := Auto);
+
procedure Print_Flag (F : Boolean);
-- Print True or False
@@ -215,6 +248,159 @@ package body Treepr is
-- descendants are to be printed. Prefix_Str is to be added to all
-- printed lines.
+ ----------------
+ -- Capitalize --
+ ----------------
+
+ procedure Capitalize (S : in out String) is
+ Cap : Boolean := True;
+ begin
+ for J in S'Range loop
+ declare
+ Old : constant Character := S (J);
+ begin
+ if Cap then
+ S (J) := Fold_Upper (S (J));
+ else
+ S (J) := Fold_Lower (S (J));
+ end if;
+
+ Cap := Old = '_';
+ end;
+ end loop;
+ end Capitalize;
+
+ function Capitalize (S : String) return String is
+ begin
+ return Result : String (S'Range) := S do
+ Capitalize (Result);
+ end return;
+ end Capitalize;
+
+ -----------
+ -- Image --
+ -----------
+
+ function Image (F : Node_Field) return String is
+ begin
+ case F is
+ when F_Alloc_For_BIP_Return =>
+ return "Alloc_For_BIP_Return";
+ when F_Assignment_OK =>
+ return "Assignment_OK";
+ when F_Backwards_OK =>
+ return "Backwards_OK";
+ when F_Conversion_OK =>
+ return "Conversion_OK";
+ when F_Forwards_OK =>
+ return "Forwards_OK";
+ when F_Has_SP_Choice =>
+ return "Has_SP_Choice";
+ when F_Is_Elaboration_Checks_OK_Node =>
+ return "Is_Elaboration_Checks_OK_Node";
+ when F_Is_Elaboration_Warnings_OK_Node =>
+ return "Is_Elaboration_Warnings_OK_Node";
+ when F_Is_Known_Guaranteed_ABE =>
+ return "Is_Known_Guaranteed_ABE";
+ when F_Is_SPARK_Mode_On_Node =>
+ return "Is_SPARK_Mode_On_Node";
+ when F_Local_Raise_Not_OK =>
+ return "Local_Raise_Not_OK";
+ when F_SCIL_Controlling_Tag =>
+ return "SCIL_Controlling_Tag";
+ when F_SCIL_Entity =>
+ return "SCIL_Entity";
+ when F_SCIL_Tag_Value =>
+ return "SCIL_Tag_Value";
+ when F_SCIL_Target_Prim =>
+ return "SCIL_Target_Prim";
+ when F_Shift_Count_OK =>
+ return "Shift_Count_OK";
+ when F_Split_PPC =>
+ return "Split_PPC";
+ when F_TSS_Elist =>
+ return "TSS_Elist";
+
+ when others =>
+ declare
+ Result : constant String := Capitalize (F'Img);
+ begin
+ return Result (3 .. Result'Last); -- Remove "F_"
+ end;
+ end case;
+ end Image;
+
+ function Image (F : Entity_Field) return String is
+ begin
+ case F is
+ when F_BIP_Initialization_Call =>
+ return "BIP_Initialization_Call";
+ when F_Body_Needed_For_SAL =>
+ return "Body_Needed_For_SAL";
+ when F_CR_Discriminant =>
+ return "CR_Discriminant";
+ when F_DT_Entry_Count =>
+ return "DT_Entry_Count";
+ when F_DT_Offset_To_Top_Func =>
+ return "DT_Offset_To_Top_Func";
+ when F_DT_Position =>
+ return "DT_Position";
+ when F_DTC_Entity =>
+ return "DTC_Entity";
+ when F_Has_Inherited_DIC =>
+ return "Has_Inherited_DIC";
+ when F_Has_Own_DIC =>
+ return "Has_Own_DIC";
+ when F_Has_RACW =>
+ return "Has_RACW";
+ when F_Ignore_SPARK_Mode_Pragmas =>
+ return "Ignore_SPARK_Mode_Pragmas";
+ when F_Is_Constr_Subt_For_UN_Aliased =>
+ return "Is_Constr_Subt_For_UN_Aliased";
+ when F_Is_CPP_Class =>
+ return "Is_CPP_Class";
+ when F_Is_CUDA_Kernel =>
+ return "Is_CUDA_Kernel";
+ when F_Is_DIC_Procedure =>
+ return "Is_DIC_Procedure";
+ when F_Is_Discrim_SO_Function =>
+ return "Is_Discrim_SO_Function";
+ when F_Is_Elaboration_Checks_OK_Id =>
+ return "Is_Elaboration_Checks_OK_Id";
+ when F_Is_Elaboration_Warnings_OK_Id =>
+ return "Is_Elaboration_Warnings_OK_Id";
+ when F_Is_RACW_Stub_Type =>
+ return "Is_RACW_Stub_Type";
+ when F_LSP_Subprogram =>
+ return "LSP_Subprogram";
+ when F_OK_To_Rename =>
+ return "OK_To_Rename";
+ when F_Referenced_As_LHS =>
+ return "Referenced_As_LHS";
+ when F_RM_Size =>
+ return "RM_Size";
+ when F_SPARK_Aux_Pragma =>
+ return "SPARK_Aux_Pragma";
+ when F_SPARK_Aux_Pragma_Inherited =>
+ return "SPARK_Aux_Pragma_Inherited";
+ when F_SPARK_Pragma =>
+ return "SPARK_Pragma";
+ when F_SPARK_Pragma_Inherited =>
+ return "SPARK_Pragma_Inherited";
+ when F_SSO_Set_High_By_Default =>
+ return "SSO_Set_High_By_Default";
+ when F_SSO_Set_Low_By_Default =>
+ return "SSO_Set_Low_By_Default";
+
+ when others =>
+ declare
+ Result : constant String := Capitalize (F'Img);
+ begin
+ return Result (3 .. Result'Last); -- Remove "F_"
+ end;
+ end case;
+ end Image;
+
-------
-- p --
-------
@@ -226,7 +412,7 @@ package body Treepr is
return Nlists.Parent (List_Id (N));
when Node_Range =>
- return Atree.Parent (Node_Or_Entity_Id (N));
+ return Parent (Node_Or_Entity_Id (N));
when others =>
Write_Int (Int (N));
@@ -425,7 +611,7 @@ package body Treepr is
begin
UI_Write (Val);
Write_Str (" (Uint = ");
- Write_Int (Int (Field5 (N)));
+ Write_Str (UI_Image (Val));
Write_Str (") ");
if Val /= No_Uint then
@@ -438,22 +624,6 @@ package body Treepr is
-----------------------
procedure Print_Entity_Info (Ent : Entity_Id; Prefix : String) is
- function Field_Present (U : Union_Id) return Boolean;
- -- Returns False unless the value U represents a missing value
- -- (Empty, No_Elist, No_Uint, No_Ureal or No_String)
-
- function Field_Present (U : Union_Id) return Boolean is
- begin
- return
- U /= Union_Id (Empty) and then
- U /= Union_Id (No_Elist) and then
- U /= To_Union (No_Uint) and then
- U /= To_Union (No_Ureal) and then
- U /= Union_Id (No_String);
- end Field_Present;
-
- -- Start of processing for Print_Entity_Info
-
begin
Print_Str (Prefix);
Print_Str ("Ekind = ");
@@ -480,340 +650,106 @@ package body Treepr is
end;
end if;
- if Field_Present (Field6 (Ent)) then
- Print_Str (Prefix);
- Write_Field6_Name (Ent);
- Write_Str (" = ");
- Print_Field (Field6 (Ent));
- Print_Eol;
- end if;
-
- if Field_Present (Field7 (Ent)) then
- Print_Str (Prefix);
- Write_Field7_Name (Ent);
- Write_Str (" = ");
- Print_Field (Field7 (Ent));
- Print_Eol;
- end if;
-
- if Field_Present (Field8 (Ent)) then
- Print_Str (Prefix);
- Write_Field8_Name (Ent);
- Write_Str (" = ");
- Print_Field (Field8 (Ent));
- Print_Eol;
- end if;
-
- if Field_Present (Field9 (Ent)) then
- Print_Str (Prefix);
- Write_Field9_Name (Ent);
- Write_Str (" = ");
- Print_Field (Field9 (Ent));
- Print_Eol;
- end if;
-
- if Field_Present (Field10 (Ent)) then
- Print_Str (Prefix);
- Write_Field10_Name (Ent);
- Write_Str (" = ");
- Print_Field (Field10 (Ent));
- Print_Eol;
- end if;
-
- if Field_Present (Field11 (Ent)) then
- Print_Str (Prefix);
- Write_Field11_Name (Ent);
- Write_Str (" = ");
- Print_Field (Field11 (Ent));
- Print_Eol;
- end if;
-
- if Field_Present (Field12 (Ent)) then
- Print_Str (Prefix);
- Write_Field12_Name (Ent);
- Write_Str (" = ");
- Print_Field (Field12 (Ent));
- Print_Eol;
- end if;
-
- if Field_Present (Field13 (Ent)) then
- Print_Str (Prefix);
- Write_Field13_Name (Ent);
- Write_Str (" = ");
- Print_Field (Field13 (Ent));
- Print_Eol;
- end if;
-
- if Field_Present (Field14 (Ent)) then
- Print_Str (Prefix);
- Write_Field14_Name (Ent);
- Write_Str (" = ");
- Print_Field (Field14 (Ent));
- Print_Eol;
- end if;
-
- if Field_Present (Field15 (Ent)) then
- Print_Str (Prefix);
- Write_Field15_Name (Ent);
- Write_Str (" = ");
- Print_Field (Field15 (Ent));
- Print_Eol;
- end if;
-
- if Field_Present (Field16 (Ent)) then
- Print_Str (Prefix);
- Write_Field16_Name (Ent);
- Write_Str (" = ");
- Print_Field (Field16 (Ent));
- Print_Eol;
- end if;
-
- if Field_Present (Field17 (Ent)) then
- Print_Str (Prefix);
- Write_Field17_Name (Ent);
- Write_Str (" = ");
- Print_Field (Field17 (Ent));
- Print_Eol;
- end if;
-
- if Field_Present (Field18 (Ent)) then
- Print_Str (Prefix);
- Write_Field18_Name (Ent);
- Write_Str (" = ");
- Print_Field (Field18 (Ent));
- Print_Eol;
- end if;
+ declare
+ Fields : Entity_Field_Array renames
+ Entity_Field_Table (Ekind (Ent)).all;
+ Should_Print : constant Entity_Field_Set :=
+ -- Set of fields that should be printed. False for fields that were
+ -- already printed above.
+ (F_Ekind
+ | F_Basic_Convention => False, -- Convention was printed
+ others => True);
+ begin
+ -- Outer loop makes flags come out last
+
+ for Print_Flags in Boolean loop
+ for Field_Index in Fields'Range loop
+ declare
+ FD : Field_Descriptor renames
+ Entity_Field_Descriptors (Fields (Field_Index));
+ begin
+ if Should_Print (Fields (Field_Index))
+ and then (FD.Kind = Flag_Field) = Print_Flags
+ then
+ Print_Entity_Field
+ (Prefix, Fields (Field_Index), Ent, FD);
+ end if;
+ end;
+ end loop;
+ end loop;
+ end;
+ end Print_Entity_Info;
- if Field_Present (Field19 (Ent)) then
- Print_Str (Prefix);
- Write_Field19_Name (Ent);
- Write_Str (" = ");
- Print_Field (Field19 (Ent));
- Print_Eol;
- end if;
+ ---------------
+ -- Print_Eol --
+ ---------------
- if Field_Present (Field20 (Ent)) then
- Print_Str (Prefix);
- Write_Field20_Name (Ent);
- Write_Str (" = ");
- Print_Field (Field20 (Ent));
- Print_Eol;
+ procedure Print_Eol is
+ begin
+ if Phase = Printing then
+ Write_Eol;
end if;
+ end Print_Eol;
- if Field_Present (Field21 (Ent)) then
- Print_Str (Prefix);
- Write_Field21_Name (Ent);
- Write_Str (" = ");
- Print_Field (Field21 (Ent));
- Print_Eol;
- end if;
+ -----------------
+ -- Print_Field --
+ -----------------
- if Field_Present (Field22 (Ent)) then
- Print_Str (Prefix);
- Write_Field22_Name (Ent);
- Write_Str (" = ");
+ -- Instantiations of low-level getters and setters that take offsets
+ -- in units of the size of the field.
- -- Mechanism case has to be handled specially
+ use Atree.Atree_Private_Part;
- if Ekind (Ent) = E_Function or else Is_Formal (Ent) then
- declare
- M : constant Mechanism_Type := Mechanism (Ent);
+ function Get_Flag is new Get_1_Bit_Field
+ (Boolean) with Inline;
- begin
- case M is
- when Default_Mechanism =>
- Write_Str ("Default");
+ function Get_Node_Id is new Get_32_Bit_Field
+ (Node_Id) with Inline;
- when By_Copy =>
- Write_Str ("By_Copy");
+ function Get_List_Id is new Get_32_Bit_Field
+ (List_Id) with Inline;
- when By_Reference =>
- Write_Str ("By_Reference");
+ function Get_Elist_Id is new Get_32_Bit_Field_With_Default
+ (Elist_Id, No_Elist) with Inline;
- when 1 .. Mechanism_Type'Last =>
- Write_Str ("By_Copy if size <= ");
- Write_Int (Int (M));
- end case;
- end;
+ function Get_Name_Id is new Get_32_Bit_Field
+ (Name_Id) with Inline;
- -- Normal case (not Mechanism)
+ function Get_String_Id is new Get_32_Bit_Field
+ (String_Id) with Inline;
- else
- Print_Field (Field22 (Ent));
- end if;
+ function Get_Uint is new Get_32_Bit_Field_With_Default
+ (Uint, Uint_0) with Inline;
- Print_Eol;
- end if;
+ function Get_Valid_Uint is new Get_32_Bit_Field
+ (Uint) with Inline;
+ -- Used for both Valid_Uint and other subtypes of Uint. Note that we don't
+ -- instantiate Get_Valid_32_Bit_Field; we don't want to blow up if the
+ -- value is wrong.
- if Field_Present (Field23 (Ent)) then
- Print_Str (Prefix);
- Write_Field23_Name (Ent);
- Write_Str (" = ");
- Print_Field (Field23 (Ent));
- Print_Eol;
- end if;
+ function Get_Ureal is new Get_32_Bit_Field
+ (Ureal) with Inline;
- if Field_Present (Field24 (Ent)) then
- Print_Str (Prefix);
- Write_Field24_Name (Ent);
- Write_Str (" = ");
- Print_Field (Field24 (Ent));
- Print_Eol;
- end if;
+ function Get_Node_Kind_Type is new Get_8_Bit_Field
+ (Node_Kind) with Inline;
- if Field_Present (Field25 (Ent)) then
- Print_Str (Prefix);
- Write_Field25_Name (Ent);
- Write_Str (" = ");
- Print_Field (Field25 (Ent));
- Print_Eol;
- end if;
+ function Get_Entity_Kind_Type is new Get_8_Bit_Field
+ (Entity_Kind) with Inline;
- if Field_Present (Field26 (Ent)) then
- Print_Str (Prefix);
- Write_Field26_Name (Ent);
- Write_Str (" = ");
- Print_Field (Field26 (Ent));
- Print_Eol;
- end if;
+ function Get_Source_Ptr is new Get_32_Bit_Field
+ (Source_Ptr) with Inline, Unreferenced;
- if Field_Present (Field27 (Ent)) then
- Print_Str (Prefix);
- Write_Field27_Name (Ent);
- Write_Str (" = ");
- Print_Field (Field27 (Ent));
- Print_Eol;
- end if;
+ function Get_Small_Paren_Count_Type is new Get_2_Bit_Field
+ (Small_Paren_Count_Type) with Inline, Unreferenced;
- if Field_Present (Field28 (Ent)) then
- Print_Str (Prefix);
- Write_Field28_Name (Ent);
- Write_Str (" = ");
- Print_Field (Field28 (Ent));
- Print_Eol;
- end if;
+ function Get_Union_Id is new Get_32_Bit_Field
+ (Union_Id) with Inline;
- if Field_Present (Field29 (Ent)) then
- Print_Str (Prefix);
- Write_Field29_Name (Ent);
- Write_Str (" = ");
- Print_Field (Field29 (Ent));
- Print_Eol;
- end if;
+ function Get_Convention_Id is new Get_8_Bit_Field
+ (Convention_Id) with Inline, Unreferenced;
- if Field_Present (Field30 (Ent)) then
- Print_Str (Prefix);
- Write_Field30_Name (Ent);
- Write_Str (" = ");
- Print_Field (Field30 (Ent));
- Print_Eol;
- end if;
-
- if Field_Present (Field31 (Ent)) then
- Print_Str (Prefix);
- Write_Field31_Name (Ent);
- Write_Str (" = ");
- Print_Field (Field31 (Ent));
- Print_Eol;
- end if;
-
- if Field_Present (Field32 (Ent)) then
- Print_Str (Prefix);
- Write_Field32_Name (Ent);
- Write_Str (" = ");
- Print_Field (Field32 (Ent));
- Print_Eol;
- end if;
-
- if Field_Present (Field33 (Ent)) then
- Print_Str (Prefix);
- Write_Field33_Name (Ent);
- Write_Str (" = ");
- Print_Field (Field33 (Ent));
- Print_Eol;
- end if;
-
- if Field_Present (Field34 (Ent)) then
- Print_Str (Prefix);
- Write_Field34_Name (Ent);
- Write_Str (" = ");
- Print_Field (Field34 (Ent));
- Print_Eol;
- end if;
-
- if Field_Present (Field35 (Ent)) then
- Print_Str (Prefix);
- Write_Field35_Name (Ent);
- Write_Str (" = ");
- Print_Field (Field35 (Ent));
- Print_Eol;
- end if;
-
- if Field_Present (Field36 (Ent)) then
- Print_Str (Prefix);
- Write_Field36_Name (Ent);
- Write_Str (" = ");
- Print_Field (Field36 (Ent));
- Print_Eol;
- end if;
-
- if Field_Present (Field37 (Ent)) then
- Print_Str (Prefix);
- Write_Field37_Name (Ent);
- Write_Str (" = ");
- Print_Field (Field37 (Ent));
- Print_Eol;
- end if;
-
- if Field_Present (Field38 (Ent)) then
- Print_Str (Prefix);
- Write_Field38_Name (Ent);
- Write_Str (" = ");
- Print_Field (Field38 (Ent));
- Print_Eol;
- end if;
-
- if Field_Present (Field39 (Ent)) then
- Print_Str (Prefix);
- Write_Field39_Name (Ent);
- Write_Str (" = ");
- Print_Field (Field39 (Ent));
- Print_Eol;
- end if;
-
- if Field_Present (Field40 (Ent)) then
- Print_Str (Prefix);
- Write_Field40_Name (Ent);
- Write_Str (" = ");
- Print_Field (Field40 (Ent));
- Print_Eol;
- end if;
-
- if Field_Present (Field41 (Ent)) then
- Print_Str (Prefix);
- Write_Field41_Name (Ent);
- Write_Str (" = ");
- Print_Field (Field41 (Ent));
- Print_Eol;
- end if;
-
- Write_Entity_Flags (Ent, Prefix);
- end Print_Entity_Info;
-
- ---------------
- -- Print_Eol --
- ---------------
-
- procedure Print_Eol is
- begin
- if Phase = Printing then
- Write_Eol;
- end if;
- end Print_Eol;
-
- -----------------
- -- Print_Field --
- -----------------
+ function Get_Mechanism_Type is new Get_32_Bit_Field
+ (Mechanism_Type) with Inline, Unreferenced;
procedure Print_Field (Val : Union_Id; Format : UI_Format := Auto) is
begin
@@ -860,6 +796,272 @@ package body Treepr is
end if;
end Print_Field;
+ procedure Print_Field
+ (Prefix : String;
+ Field : String;
+ N : Node_Or_Entity_Id;
+ FD : Field_Descriptor;
+ Format : UI_Format)
+ is
+ Printed : Boolean := False;
+
+ procedure Print_Initial;
+ -- Print the initial stuff that goes before the value
+
+ procedure Print_Initial is
+ begin
+ Printed := True;
+ Print_Str (Prefix);
+ Print_Str (Field);
+
+ if Print_Low_Level_Info then
+ Write_Str (" at ");
+ Write_Int (Int (FD.Offset));
+ end if;
+
+ Write_Str (" = ");
+ end Print_Initial;
+
+ begin
+ if Phase /= Printing then
+ return;
+ end if;
+
+ case FD.Kind is
+ when Flag_Field =>
+ declare
+ Val : constant Boolean := Get_Flag (N, FD.Offset);
+ begin
+ if Val then
+ Print_Initial;
+ Print_Flag (Val);
+ end if;
+ end;
+
+ when Node_Id_Field =>
+ declare
+ Val : constant Node_Id := Get_Node_Id (N, FD.Offset);
+ begin
+ if Present (Val) then
+ Print_Initial;
+ Print_Node_Ref (Val);
+ end if;
+ end;
+
+ when List_Id_Field =>
+ declare
+ Val : constant List_Id := Get_List_Id (N, FD.Offset);
+ begin
+ if Present (Val) then
+ Print_Initial;
+ Print_List_Ref (Val);
+ end if;
+ end;
+
+ when Elist_Id_Field =>
+ declare
+ Val : constant Elist_Id := Get_Elist_Id (N, FD.Offset);
+ begin
+ if Present (Val) then
+ Print_Initial;
+ Print_Elist_Ref (Val);
+ end if;
+ end;
+
+ when Name_Id_Field =>
+ declare
+ Val : constant Name_Id := Get_Name_Id (N, FD.Offset);
+ begin
+ if Present (Val) then
+ Print_Initial;
+ Print_Name (Val);
+ Write_Str (" (Name_Id=");
+ Write_Int (Int (Val));
+ Write_Char (')');
+ end if;
+ end;
+
+ when String_Id_Field =>
+ declare
+ Val : constant String_Id := Get_String_Id (N, FD.Offset);
+ begin
+ if Val /= No_String then
+ Print_Initial;
+ Write_String_Table_Entry (Val);
+ Write_Str (" (String_Id=");
+ Write_Int (Int (Val));
+ Write_Char (')');
+ end if;
+ end;
+
+ when Uint_Field =>
+ declare
+ Val : constant Uint := Get_Uint (N, FD.Offset);
+ function Cast is new Unchecked_Conversion (Uint, Int);
+ begin
+ -- Do this even if Val = No_Uint, because Uint fields default
+ -- to Uint_0.
+
+ Print_Initial;
+ UI_Write (Val, Format);
+ Write_Str (" (Uint = ");
+ Write_Int (Cast (Val));
+ Write_Char (')');
+ end;
+
+ when Valid_Uint_Field | Unat_Field | Upos_Field
+ | Nonzero_Uint_Field =>
+ declare
+ Val : constant Uint := Get_Valid_Uint (N, FD.Offset);
+ function Cast is new Unchecked_Conversion (Uint, Int);
+ begin
+ Print_Initial;
+ UI_Write (Val, Format);
+
+ case FD.Kind is
+ when Valid_Uint_Field => Write_Str (" v");
+ when Unat_Field => Write_Str (" n");
+ when Upos_Field => Write_Str (" p");
+ when Nonzero_Uint_Field => Write_Str (" nz");
+ when others => raise Program_Error;
+ end case;
+
+ Write_Str (" (Uint = ");
+ Write_Int (Cast (Val));
+ Write_Char (')');
+ end;
+
+ when Ureal_Field =>
+ declare
+ Val : constant Ureal := Get_Ureal (N, FD.Offset);
+ function Cast is new Unchecked_Conversion (Ureal, Int);
+ begin
+ if Val /= No_Ureal then
+ Print_Initial;
+ UR_Write (Val);
+ Write_Str (" (Ureal = ");
+ Write_Int (Cast (Val));
+ Write_Char (')');
+ end if;
+ end;
+
+ when Node_Kind_Type_Field =>
+ declare
+ Val : constant Node_Kind := Get_Node_Kind_Type (N, FD.Offset);
+ begin
+ Print_Initial;
+ Print_Str_Mixed_Case (Node_Kind'Image (Val));
+ end;
+
+ when Entity_Kind_Type_Field =>
+ declare
+ Val : constant Entity_Kind :=
+ Get_Entity_Kind_Type (N, FD.Offset);
+ begin
+ Print_Initial;
+ Print_Str_Mixed_Case (Entity_Kind'Image (Val));
+ end;
+
+ when Union_Id_Field =>
+ declare
+ Val : constant Union_Id := Get_Union_Id (N, FD.Offset);
+ begin
+ if Val /= Empty_List_Or_Node then
+ Print_Initial;
+
+ if Val in Node_Range then
+ Print_Node_Ref (Node_Id (Val));
+
+ elsif Val in List_Range then
+ Print_List_Ref (List_Id (Val));
+
+ else
+ Print_Str ("<invalid union id>");
+ end if;
+ end if;
+ end;
+
+ when others =>
+ Print_Initial;
+ Print_Str ("<unknown ");
+ Print_Str (Field_Kind'Image (FD.Kind));
+ Print_Str (">");
+ end case;
+
+ if Printed then
+ Print_Eol;
+ end if;
+
+ -- If an exception is raised while printing, we try to print some low-level
+ -- information that is useful for debugging.
+
+ exception
+ when others =>
+ declare
+ function Cast is new Unchecked_Conversion (Field_Size_32_Bit, Int);
+ begin
+ Write_Eol;
+ Print_Initial;
+ Write_Str ("exception raised in Print_Field -- int val = ");
+ Write_Eol;
+
+ case Field_Size (FD.Kind) is
+ when 1 => Write_Int (Int (Get_1_Bit_Val (N, FD.Offset)));
+ when 2 => Write_Int (Int (Get_2_Bit_Val (N, FD.Offset)));
+ when 4 => Write_Int (Int (Get_4_Bit_Val (N, FD.Offset)));
+ when 8 => Write_Int (Int (Get_8_Bit_Val (N, FD.Offset)));
+ when others => -- 32
+ Write_Int (Cast (Get_32_Bit_Val (N, FD.Offset)));
+ end case;
+
+ Write_Str (", ");
+ Write_Str (FD.Kind'Img);
+ Write_Str (" ");
+ Write_Int (Int (Field_Size (FD.Kind)));
+ Write_Str (" bits");
+ Write_Eol;
+ exception
+ when others =>
+ Write_Eol;
+ Write_Str ("double exception raised in Print_Field");
+ Write_Eol;
+ end;
+ end Print_Field;
+
+ ----------------------
+ -- Print_Node_Field --
+ ----------------------
+
+ procedure Print_Node_Field
+ (Prefix : String;
+ Field : Node_Field;
+ N : Node_Id;
+ FD : Field_Descriptor;
+ Format : UI_Format := Auto)
+ is
+ begin
+ if not Field_Is_Initial_Zero (N, Field) then
+ Print_Field (Prefix, Image (Field), N, FD, Format);
+ end if;
+ end Print_Node_Field;
+
+ ------------------------
+ -- Print_Entity_Field --
+ ------------------------
+
+ procedure Print_Entity_Field
+ (Prefix : String;
+ Field : Entity_Field;
+ N : Entity_Id;
+ FD : Field_Descriptor;
+ Format : UI_Format := Auto)
+ is
+ begin
+ if not Field_Is_Initial_Zero (N, Field) then
+ Print_Field (Prefix, Image (Field), N, FD, Format);
+ end if;
+ end Print_Entity_Field;
+
----------------
-- Print_Flag --
----------------
@@ -979,7 +1181,7 @@ package body Treepr is
Print_Char ('"');
else
- Print_Str ("<invalid name ???>");
+ Print_Str ("<invalid name>");
end if;
end if;
end Print_Name;
@@ -993,11 +1195,7 @@ package body Treepr is
Prefix_Str : String;
Prefix_Char : Character)
is
- F : Fchar;
- P : Natural;
-
- Field_To_Be_Printed : Boolean;
- Prefix_Str_Char : String (Prefix_Str'First .. Prefix_Str'Last + 1);
+ Prefix : constant String := Prefix_Str & Prefix_Char;
Sfile : Source_File_Index;
Fmt : UI_Format;
@@ -1010,25 +1208,13 @@ package body Treepr is
-- If there is no such node, indicate that. Skip the rest, so we don't
-- crash getting fields of the nonexistent node.
- if N > Atree_Private_Part.Nodes.Last then
+ if not Is_Valid_Node (Union_Id (N)) then
Print_Str ("No such node: ");
Print_Int (Int (N));
Print_Eol;
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;
-
-- Print header line
Print_Str (Prefix_Str);
@@ -1041,6 +1227,10 @@ package body Treepr is
Print_Eol;
end if;
+ if Print_Low_Level_Info then
+ Print_Atree_Info (N);
+ end if;
+
if N = Empty then
return;
end if;
@@ -1055,7 +1245,7 @@ package body Treepr is
-- Print Sloc field if it is set
if Sloc (N) /= No_Location then
- Print_Str (Prefix_Str_Char);
+ Print_Str (Prefix);
Print_Str ("Sloc = ");
if Sloc (N) = Standard_Location then
@@ -1077,7 +1267,7 @@ package body Treepr is
-- Print Chars field if present
if Nkind (N) in N_Has_Chars and then Chars (N) /= No_Name then
- Print_Str (Prefix_Str_Char);
+ Print_Str (Prefix);
Print_Str ("Chars = ");
Print_Name (Chars (N));
Write_Str (" (Name_Id=");
@@ -1099,7 +1289,7 @@ package body Treepr is
-- Print Left_Opnd if present
if Nkind (N) not in N_Unary_Op then
- Print_Str (Prefix_Str_Char);
+ Print_Str (Prefix);
Print_Str ("Left_Opnd = ");
Print_Node_Ref (Left_Opnd (N));
Print_Eol;
@@ -1107,20 +1297,28 @@ package body Treepr is
-- Print Right_Opnd
- Print_Str (Prefix_Str_Char);
+ Print_Str (Prefix);
Print_Str ("Right_Opnd = ");
Print_Node_Ref (Right_Opnd (N));
Print_Eol;
end if;
- -- Print Entity field if operator (other cases of Entity
- -- are in the table, so are handled in the normal circuit)
+ -- Deal with Entity_Or_Associated_Node. If N has both, then just
+ -- print Entity; they are the same thing.
- if Nkind (N) in N_Op and then Present (Entity (N)) then
- Print_Str (Prefix_Str_Char);
+ if N in N_Inclusive_Has_Entity and then Present (Entity (N)) then
+ Print_Str (Prefix);
Print_Str ("Entity = ");
Print_Node_Ref (Entity (N));
Print_Eol;
+
+ elsif N in N_Has_Associated_Node
+ and then Present (Associated_Node (N))
+ then
+ Print_Str (Prefix);
+ Print_Str ("Associated_Node = ");
+ Print_Node_Ref (Associated_Node (N));
+ Print_Eol;
end if;
-- Print special fields if we have a subexpression
@@ -1128,62 +1326,62 @@ package body Treepr is
if Nkind (N) in N_Subexpr then
if Assignment_OK (N) then
- Print_Str (Prefix_Str_Char);
+ Print_Str (Prefix);
Print_Str ("Assignment_OK = True");
Print_Eol;
end if;
if Do_Range_Check (N) then
- Print_Str (Prefix_Str_Char);
+ Print_Str (Prefix);
Print_Str ("Do_Range_Check = True");
Print_Eol;
end if;
if Has_Dynamic_Length_Check (N) then
- Print_Str (Prefix_Str_Char);
+ Print_Str (Prefix);
Print_Str ("Has_Dynamic_Length_Check = True");
Print_Eol;
end if;
if Has_Aspects (N) then
- Print_Str (Prefix_Str_Char);
+ Print_Str (Prefix);
Print_Str ("Has_Aspects = True");
Print_Eol;
end if;
if Is_Controlling_Actual (N) then
- Print_Str (Prefix_Str_Char);
+ Print_Str (Prefix);
Print_Str ("Is_Controlling_Actual = True");
Print_Eol;
end if;
if Is_Overloaded (N) then
- Print_Str (Prefix_Str_Char);
+ Print_Str (Prefix);
Print_Str ("Is_Overloaded = True");
Print_Eol;
end if;
if Is_Static_Expression (N) then
- Print_Str (Prefix_Str_Char);
+ Print_Str (Prefix);
Print_Str ("Is_Static_Expression = True");
Print_Eol;
end if;
if Must_Not_Freeze (N) then
- Print_Str (Prefix_Str_Char);
+ Print_Str (Prefix);
Print_Str ("Must_Not_Freeze = True");
Print_Eol;
end if;
if Paren_Count (N) /= 0 then
- Print_Str (Prefix_Str_Char);
+ Print_Str (Prefix);
Print_Str ("Paren_Count = ");
Print_Int (Int (Paren_Count (N)));
Print_Eol;
end if;
if Raises_Constraint_Error (N) then
- Print_Str (Prefix_Str_Char);
+ Print_Str (Prefix);
Print_Str ("Raises_Constraint_Error = True");
Print_Eol;
end if;
@@ -1193,7 +1391,7 @@ package body Treepr is
-- Print Do_Overflow_Check field if present
if Nkind (N) in N_Op and then Do_Overflow_Check (N) then
- Print_Str (Prefix_Str_Char);
+ Print_Str (Prefix);
Print_Str ("Do_Overflow_Check = True");
Print_Eol;
end if;
@@ -1202,132 +1400,85 @@ package body Treepr is
-- is handled by the Print_Entity_Info procedure).
if Nkind (N) in N_Has_Etype and then Present (Etype (N)) then
- Print_Str (Prefix_Str_Char);
+ Print_Str (Prefix);
Print_Str ("Etype = ");
Print_Node_Ref (Etype (N));
Print_Eol;
end if;
end if;
- -- Loop to print fields included in Pchars array
-
- P := Pchar_Pos (Nkind (N));
-
if Nkind (N) = N_Integer_Literal and then Print_In_Hex (N) then
Fmt := Hex;
else
Fmt := Auto;
end if;
- while P < Pchar_Pos (Node_Kind'Succ (Nkind (N))) loop
- F := Pchars (P);
- P := P + 1;
-
- -- Check for case of False flag, which we never print, or an Empty
- -- field, which is also never printed.
-
- case F is
- when F_Field1 =>
- Field_To_Be_Printed := Field1 (N) /= Union_Id (Empty);
-
- when F_Field2 =>
- Field_To_Be_Printed := Field2 (N) /= Union_Id (Empty);
-
- when F_Field3 =>
- Field_To_Be_Printed := Field3 (N) /= Union_Id (Empty);
-
- when F_Field4 =>
- Field_To_Be_Printed := Field4 (N) /= Union_Id (Empty);
-
- when F_Field5 =>
- Field_To_Be_Printed := Field5 (N) /= Union_Id (Empty);
-
- when F_Flag1 => Field_To_Be_Printed := Flag1 (N);
- when F_Flag2 => Field_To_Be_Printed := Flag2 (N);
- when F_Flag3 => Field_To_Be_Printed := Flag3 (N);
- when F_Flag4 => Field_To_Be_Printed := Flag4 (N);
- when F_Flag5 => Field_To_Be_Printed := Flag5 (N);
- when F_Flag6 => Field_To_Be_Printed := Flag6 (N);
- when F_Flag7 => Field_To_Be_Printed := Flag7 (N);
- when F_Flag8 => Field_To_Be_Printed := Flag8 (N);
- when F_Flag9 => Field_To_Be_Printed := Flag9 (N);
- when F_Flag10 => Field_To_Be_Printed := Flag10 (N);
- when F_Flag11 => Field_To_Be_Printed := Flag11 (N);
- when F_Flag12 => Field_To_Be_Printed := Flag12 (N);
- when F_Flag13 => Field_To_Be_Printed := Flag13 (N);
- when F_Flag14 => Field_To_Be_Printed := Flag14 (N);
- when F_Flag15 => Field_To_Be_Printed := Flag15 (N);
- when F_Flag16 => Field_To_Be_Printed := Flag16 (N);
- when F_Flag17 => Field_To_Be_Printed := Flag17 (N);
- when F_Flag18 => Field_To_Be_Printed := Flag18 (N);
- end case;
-
- -- Print field if it is to be printed
-
- if Field_To_Be_Printed then
- Print_Str (Prefix_Str_Char);
-
- while P < Pchar_Pos (Node_Kind'Succ (Nkind (N)))
- and then Pchars (P) not in Fchar
- loop
- Print_Char (Pchars (P));
- P := P + 1;
- end loop;
-
- Print_Str (" = ");
-
- case F is
- when F_Field1 => Print_Field (Field1 (N), Fmt);
- when F_Field2 => Print_Field (Field2 (N), Fmt);
- when F_Field3 => Print_Field (Field3 (N), Fmt);
- when F_Field4 => Print_Field (Field4 (N), Fmt);
+ declare
+ Fields : Node_Field_Array renames Node_Field_Table (Nkind (N)).all;
+ Should_Print : constant Node_Field_Set :=
+ -- Set of fields that should be printed. False for fields that were
+ -- already printed above, and for In_List, which we don't bother
+ -- printing.
+ (F_Nkind
+ | F_Chars
+ | F_Comes_From_Source
+ | F_Analyzed
+ | F_Error_Posted
+ | F_Is_Ignored_Ghost_Node
+ | F_Check_Actuals
+ | F_Link -- Parent was printed
+ | F_Sloc
+ | F_Left_Opnd
+ | F_Right_Opnd
+ | F_Entity_Or_Associated_Node -- one of them was printed
+ | F_Assignment_OK
+ | F_Do_Range_Check
+ | F_Has_Dynamic_Length_Check
+ | F_Has_Aspects
+ | F_Is_Controlling_Actual
+ | F_Is_Overloaded
+ | F_Is_Static_Expression
+ | F_Must_Not_Freeze
+ | F_Small_Paren_Count -- Paren_Count was printed
+ | F_Raises_Constraint_Error
+ | F_Do_Overflow_Check
+ | F_Etype
+ | F_In_List
+ => False,
+
+ others => True);
+ begin
+ -- Outer loop makes flags come out last
+
+ for Print_Flags in Boolean loop
+ for Field_Index in Fields'Range loop
+ declare
+ FD : Field_Descriptor renames
+ Node_Field_Descriptors (Fields (Field_Index));
+ begin
+ if Should_Print (Fields (Field_Index))
+ and then (FD.Kind = Flag_Field) = Print_Flags
+ then
+ -- Special case for End_Span, which also prints the
+ -- End_Location.
- -- Special case End_Span = Uint5
+ if Fields (Field_Index) = F_End_Span then
+ Print_End_Span (N);
- when F_Field5 =>
- if Nkind (N) in N_Case_Statement | N_If_Statement then
- Print_End_Span (N);
- else
- Print_Field (Field5 (N), Fmt);
+ else
+ Print_Node_Field
+ (Prefix, Fields (Field_Index), N, FD, Fmt);
+ end if;
end if;
-
- when F_Flag1 => Print_Flag (Flag1 (N));
- when F_Flag2 => Print_Flag (Flag2 (N));
- when F_Flag3 => Print_Flag (Flag3 (N));
- when F_Flag4 => Print_Flag (Flag4 (N));
- when F_Flag5 => Print_Flag (Flag5 (N));
- when F_Flag6 => Print_Flag (Flag6 (N));
- when F_Flag7 => Print_Flag (Flag7 (N));
- when F_Flag8 => Print_Flag (Flag8 (N));
- when F_Flag9 => Print_Flag (Flag9 (N));
- when F_Flag10 => Print_Flag (Flag10 (N));
- when F_Flag11 => Print_Flag (Flag11 (N));
- when F_Flag12 => Print_Flag (Flag12 (N));
- when F_Flag13 => Print_Flag (Flag13 (N));
- when F_Flag14 => Print_Flag (Flag14 (N));
- when F_Flag15 => Print_Flag (Flag15 (N));
- when F_Flag16 => Print_Flag (Flag16 (N));
- when F_Flag17 => Print_Flag (Flag17 (N));
- when F_Flag18 => Print_Flag (Flag18 (N));
- end case;
-
- Print_Eol;
-
- -- Field is not to be printed (False flag field)
-
- else
- while P < Pchar_Pos (Node_Kind'Succ (Nkind (N)))
- and then Pchars (P) not in Fchar
- loop
- P := P + 1;
+ end;
end loop;
- end if;
- end loop;
+ end loop;
+ end;
-- Print aspects if present
if Has_Aspects (N) then
- Print_Str (Prefix_Str_Char);
+ Print_Str (Prefix);
Print_Str ("Aspect_Specifications = ");
Print_Field (Union_Id (Aspect_Specifications (N)));
Print_Eol;
@@ -1336,13 +1487,13 @@ package body Treepr is
-- Print entity information for entities
if Nkind (N) in N_Entity then
- Print_Entity_Info (N, Prefix_Str_Char);
+ Print_Entity_Info (N, Prefix);
end if;
-- Print the SCIL node (if available)
if Present (Get_SCIL_Node (N)) then
- Print_Str (Prefix_Str_Char);
+ Print_Str (Prefix);
Print_Str ("SCIL_Node = ");
Print_Node_Ref (Get_SCIL_Node (N));
Print_Eol;
@@ -1393,7 +1544,7 @@ package body Treepr is
begin
Print_Node_Ref (N);
- if N > Atree_Private_Part.Nodes.Last then
+ if not Is_Valid_Node (Union_Id (N)) then
Print_Str (" (no such node)");
Print_Eol;
return;
@@ -1433,25 +1584,9 @@ package body Treepr is
---------------------
procedure Print_Node_Kind (N : Node_Id) is
- Ucase : Boolean;
- S : constant String := Node_Kind'Image (Nkind (N));
-
begin
if Phase = Printing then
- Ucase := True;
-
- -- Note: the call to Fold_Upper in this loop is to get past the GNAT
- -- bug of 'Image returning lower case instead of upper case.
-
- for J in S'Range loop
- if Ucase then
- Write_Char (Fold_Upper (S (J)));
- else
- Write_Char (Fold_Lower (S (J)));
- end if;
-
- Ucase := (S (J) = '_');
- end loop;
+ Print_Str_Mixed_Case (Node_Kind'Image (Nkind (N)));
end if;
end Print_Node_Kind;
@@ -2060,13 +2195,8 @@ package body Treepr is
Visit_Elist (Elist_Id (D), New_Prefix);
end if;
- -- For all other kinds of descendants (strings, names, uints etc),
- -- there is nothing to visit (the contents of the field will be
- -- printed when we print the containing node, but what concerns
- -- us now is looking for descendants in the tree.
-
else
- null;
+ raise Program_Error;
end if;
end Visit_Descendant;
@@ -2129,42 +2259,49 @@ package body Treepr is
-- Visit all descendants of this node
- if Nkind (N) not in N_Entity then
- Visit_Descendant (Field1 (N));
- Visit_Descendant (Field2 (N));
- Visit_Descendant (Field3 (N));
- Visit_Descendant (Field4 (N));
- Visit_Descendant (Field5 (N));
-
- if Has_Aspects (N) then
- Visit_Descendant (Union_Id (Aspect_Specifications (N)));
- end if;
+ declare
+ A : Node_Field_Array renames Node_Field_Table (Nkind (N)).all;
+ begin
+ for Field_Index in A'Range loop
+ declare
+ F : constant Node_Field := A (Field_Index);
+ FD : Field_Descriptor renames Node_Field_Descriptors (F);
+ begin
+ if FD.Kind in Node_Id_Field | List_Id_Field | Elist_Id_Field
+ -- For all other kinds of descendants (strings, names, uints
+ -- etc), there is nothing to visit (the contents of the
+ -- field will be printed when we print the containing node,
+ -- but what concerns us now is looking for descendants in
+ -- the tree.
+
+ and then F /= F_Next_Entity -- See below for why we skip this
+ then
+ Visit_Descendant (Get_Union_Id (N, FD.Offset));
+ end if;
+ end;
+ end loop;
+ end;
- -- Entity case
+ if Has_Aspects (N) then
+ Visit_Descendant (Union_Id (Aspect_Specifications (N)));
+ end if;
- else
- Visit_Descendant (Field1 (N));
- Visit_Descendant (Field3 (N));
- Visit_Descendant (Field4 (N));
- Visit_Descendant (Field5 (N));
- Visit_Descendant (Field6 (N));
- Visit_Descendant (Field7 (N));
- Visit_Descendant (Field8 (N));
- Visit_Descendant (Field9 (N));
- Visit_Descendant (Field10 (N));
- Visit_Descendant (Field11 (N));
- Visit_Descendant (Field12 (N));
- Visit_Descendant (Field13 (N));
- Visit_Descendant (Field14 (N));
- Visit_Descendant (Field15 (N));
- Visit_Descendant (Field16 (N));
- Visit_Descendant (Field17 (N));
- Visit_Descendant (Field18 (N));
- Visit_Descendant (Field19 (N));
- Visit_Descendant (Field20 (N));
- Visit_Descendant (Field21 (N));
- Visit_Descendant (Field22 (N));
- Visit_Descendant (Field23 (N));
+ if Nkind (N) in N_Entity then
+ declare
+ A : Entity_Field_Array renames Entity_Field_Table (Ekind (N)).all;
+ begin
+ for Field_Index in A'Range loop
+ declare
+ F : constant Entity_Field := A (Field_Index);
+ FD : Field_Descriptor renames Entity_Field_Descriptors (F);
+ begin
+ if FD.Kind in Node_Id_Field | List_Id_Field | Elist_Id_Field
+ then
+ Visit_Descendant (Get_Union_Id (N, FD.Offset));
+ end if;
+ end;
+ end loop;
+ end;
-- Now an interesting special case. Normally parents are always
-- printed since we traverse the tree in a downwards direction.
@@ -2176,12 +2313,11 @@ package body Treepr is
Visit_Descendant (Union_Id (Parent (N)));
end if;
- -- You may be wondering why we omitted Field2 above. The answer
- -- is that this is the Next_Entity field, and we want to treat
- -- it rather specially. Why? Because a Next_Entity link does not
- -- correspond to a level deeper in the tree, and we do not want
- -- the tree to march off to the right of the page due to bogus
- -- indentations coming from this effect.
+ -- You may be wondering why we omitted Next_Entity above. The answer
+ -- is that we want to treat it rather specially. Why? Because a
+ -- Next_Entity link does not correspond to a level deeper in the
+ -- tree, and we do not want the tree to march off to the right of the
+ -- page due to bogus indentations coming from this effect.
-- To prevent this, what we do is to control references via
-- Next_Entity only from the first entity on a given scope chain,
diff --git a/gcc/ada/treepr.ads b/gcc/ada/treepr.ads
index b8a086e..8c496cb 100644
--- a/gcc/ada/treepr.ads
+++ b/gcc/ada/treepr.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -80,7 +80,8 @@ package Treepr is
pragma Export (Ada, pe);
-- Print a node, node list, uint, or anything else that falls under
-- the definition of Union_Id. Historically this was only for printing
- -- nodes, hence the name.
+ -- nodes, hence the name pn. These are all the same, but the renamings
+ -- need to be in the body, or else the debugger can't find them.
procedure ppar (N : Union_Id);
pragma Export (Ada, ppar);
diff --git a/gcc/ada/treeprs.adt b/gcc/ada/treeprs.adt
deleted file mode 100644
index b65d6c2..0000000
--- a/gcc/ada/treeprs.adt
+++ /dev/null
@@ -1,107 +0,0 @@
-------------------------------------------------------------------------------
--- --
--- GNAT COMPILER COMPONENTS --
--- --
--- T R E E P R S --
--- --
--- T e m p l a t e --
--- --
--- Copyright (C) 1992-2013, Free Software Foundation, Inc. --
--- --
--- GNAT is 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 file is a template used as input to the utility program XTreeprs,
--- which reads this template, and the spec of Sinfo (sinfo.ads) and generates
--- the spec for the Treeprs package (file treeprs.ads)
-
--- This package contains the declaration of the string used by the Tree_Print
--- package. It must be updated whenever the arrangements of the field names
--- in package Sinfo is changed. The utility program XTREEPRS is used to
--- do this update correctly using the template treeprs.adt as input.
-
-with Sinfo; use Sinfo;
-
-package Treeprs is
-
- --------------------------------
- -- String Data for Node Print --
- --------------------------------
-
- -- String data for print out. The Pchars array is a long string with the
- -- the entry for each node type consisting of a single blank, followed by
- -- a series of entries, one for each Op or Flag field used for the node.
- -- Each entry has a single character which identifies the field, followed
- -- by the synonym name. The starting location for a given node type is
- -- found from the corresponding entry in the Pchars_Pos_Array.
-
- -- The following characters identify the field. These are characters which
- -- could never occur in a field name, so they also mark the end of the
- -- previous name.
-
- -- Note the following definitions do not include Flag0. This will have to
- -- be addressed if we ever need to use Flag0 (it's not currently used).
-
- subtype Fchar is Character range '#' .. '9';
-
- F_Field1 : constant Fchar := '#'; -- Character'Val (16#23#)
- F_Field2 : constant Fchar := '$'; -- Character'Val (16#24#)
- F_Field3 : constant Fchar := '%'; -- Character'Val (16#25#)
- F_Field4 : constant Fchar := '&'; -- Character'Val (16#26#)
- F_Field5 : constant Fchar := '''; -- Character'Val (16#27#)
- F_Flag1 : constant Fchar := '('; -- Character'Val (16#28#)
- F_Flag2 : constant Fchar := ')'; -- Character'Val (16#29#)
- F_Flag3 : constant Fchar := '*'; -- Character'Val (16#2A#)
- F_Flag4 : constant Fchar := '+'; -- Character'Val (16#2B#)
- F_Flag5 : constant Fchar := ','; -- Character'Val (16#2C#)
- F_Flag6 : constant Fchar := '-'; -- Character'Val (16#2D#)
- F_Flag7 : constant Fchar := '.'; -- Character'Val (16#2E#)
- F_Flag8 : constant Fchar := '/'; -- Character'Val (16#2F#)
- F_Flag9 : constant Fchar := '0'; -- Character'Val (16#30#)
- F_Flag10 : constant Fchar := '1'; -- Character'Val (16#31#)
- F_Flag11 : constant Fchar := '2'; -- Character'Val (16#32#)
- F_Flag12 : constant Fchar := '3'; -- Character'Val (16#33#)
- F_Flag13 : constant Fchar := '4'; -- Character'Val (16#34#)
- F_Flag14 : constant Fchar := '5'; -- Character'Val (16#35#)
- F_Flag15 : constant Fchar := '6'; -- Character'Val (16#36#)
- F_Flag16 : constant Fchar := '7'; -- Character'Val (16#37#)
- F_Flag17 : constant Fchar := '8'; -- Character'Val (16#38#)
- F_Flag18 : constant Fchar := '9'; -- Character'Val (16#39#)
-
- -- Note this table does not include entity field and flags whose access
- -- functions are in Einfo (these are handled by the Print_Entity_Info
- -- procedure in Treepr, which uses the routines in Einfo to get the proper
- -- symbolic information). In addition, the following fields are handled by
- -- Treepr, and do not appear in the Pchars array:
-
- -- Analyzed
- -- Cannot_Be_Constant
- -- Chars
- -- Comes_From_Source
- -- Error_Posted
- -- Etype
- -- Is_Controlling_Actual
- -- Is_Overloaded
- -- Is_Static_Expression
- -- Left_Opnd
- -- Must_Check_Expr
- -- Must_Not_Freeze
- -- No_Overflow_Expr
- -- Paren_Count
- -- Raises_Constraint_Error
- -- Right_Opnd
-
-!!TEMPLATE INSERTION POINT
-
-end Treeprs;
diff --git a/gcc/ada/ttypes.ads b/gcc/ada/ttypes.ads
index 46f9698..5f59607 100644
--- a/gcc/ada/ttypes.ads
+++ b/gcc/ada/ttypes.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -210,7 +210,7 @@ package Ttypes is
Set_Targ.Strict_Alignment /= 0;
-- True if instructions will fail if data is misaligned. Note that this
-- is a variable rather than a constant since it can be modified (set to
- -- True) if the debug flag -gnatd.A is used.
+ -- True) if the debug flag -gnatd.a is used.
Target_Double_Float_Alignment : constant Nat :=
Set_Targ.Double_Float_Alignment;
diff --git a/gcc/ada/types.adb b/gcc/ada/types.adb
index a6d829e..46ca369 100644
--- a/gcc/ada/types.adb
+++ b/gcc/ada/types.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute 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 175ffb2..a74bfb6 100644
--- a/gcc/ada/types.ads
+++ b/gcc/ada/types.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -218,6 +218,16 @@ package Types is
-- which source it refers to. Note that negative numbers are allowed to
-- accommodate the following special values.
+ type Source_Span is record
+ Ptr, First, Last : Source_Ptr;
+ end record;
+ -- Type used to represent a source span, consisting in a main location Ptr,
+ -- with a First and Last location, such that Ptr in First .. Last
+
+ function To_Span (Loc : Source_Ptr) return Source_Span is ((others => Loc));
+ function To_Span (Ptr, First, Last : Source_Ptr) return Source_Span is
+ ((Ptr, First, Last));
+
No_Location : constant Source_Ptr := -1;
-- Value used to indicate no source position set in a node. A test for a
-- Source_Ptr value being > No_Location is the approved way to test for a
@@ -302,8 +312,7 @@ package Types is
-- The tree Id values start at zero, because we use zero for Empty (to
-- allow a zero test for Empty).
- Node_High_Bound : constant :=
- (if Standard'Address_Size = 32 then 299_999_999 else 1_999_999_999);
+ Node_High_Bound : constant := 1_999_999_999;
Elist_Low_Bound : constant := -199_999_999;
-- The Elist_Id values are subscripts into an array of elist headers which
@@ -377,7 +386,7 @@ package Types is
-- the special values Empty and Error are subscripts into this table.
-- See package Atree for further details.
- type Node_Id is range Node_Low_Bound .. Node_High_Bound;
+ type Node_Id is range Node_Low_Bound .. Node_High_Bound with Size => 32;
-- Type used to identify nodes in the tree
subtype Entity_Id is Node_Id;
@@ -426,7 +435,7 @@ package Types is
-- attempt to apply list operations to No_List will cause a (detected)
-- error.
- type List_Id is range List_Low_Bound .. List_High_Bound;
+ type List_Id is range List_Low_Bound .. List_High_Bound with Size => 32;
-- Type used to identify a node list
No_List : constant List_Id := List_High_Bound;
@@ -451,7 +460,7 @@ package Types is
-- of the tree, allowing nodes to be members of more than one such list
-- (see package Elists for further details).
- type Elist_Id is range Elist_Low_Bound .. Elist_High_Bound;
+ type Elist_Id is range Elist_Low_Bound .. Elist_High_Bound with Size => 32;
-- Type used to identify an element list (Elist header table subscript)
No_Elist : constant Elist_Id := Elist_Low_Bound;
@@ -481,7 +490,8 @@ package Types is
-- String_Id values are used to identify entries in the strings table. They
-- are subscripts into the Strings table defined in package Stringt.
- type String_Id is range Strings_Low_Bound .. Strings_High_Bound;
+ type String_Id is range Strings_Low_Bound .. Strings_High_Bound
+ with Size => 32;
-- Type used to identify entries in the strings table
No_String : constant String_Id := Strings_Low_Bound;
@@ -763,7 +773,7 @@ package Types is
Overflow_Mode_Assertions : Overflow_Mode_Type;
-- This field indicates the mode for handling code generation and
-- overflow checking (if enabled) for intermediate expression values.
- -- This applies to any expression occuring inside assertions.
+ -- This applies to any expression occurring inside assertions.
end record;
-----------------------------------
@@ -807,6 +817,39 @@ package Types is
-- then Default_C_Record_Mechanism is set to 32, and the meaning is to use
-- By_Reference if the size is greater than 32, and By_Copy otherwise.
+ ---------------------------------
+ -- Component_Alignment Control --
+ ---------------------------------
+
+ -- There are four types of alignment possible for array and record
+ -- types, and a field in the type entities contains a value of the
+ -- following type indicating which alignment choice applies. For full
+ -- details of the meaning of these alignment types, see description
+ -- of the Component_Alignment pragma.
+
+ type Component_Alignment_Kind is (
+ Calign_Default, -- default alignment
+ Calign_Component_Size, -- natural alignment for component size
+ Calign_Component_Size_4, -- natural for size <= 4, 4 for size >= 4
+ Calign_Storage_Unit); -- all components byte aligned
+
+ -----------------------------------
+ -- Floating Point Representation --
+ -----------------------------------
+
+ type Float_Rep_Kind is (IEEE_Binary);
+ -- The only one supported now is IEEE 754p conforming binary format, but
+ -- other formats were supported in the past, and could conceivably be
+ -- supported in the future, so we keep this singleton enumeration type.
+
+ ----------------------------
+ -- Small_Paren_Count_Type --
+ ----------------------------
+
+ -- See Paren_Count in Atree for documentation
+
+ subtype Small_Paren_Count_Type is Nat range 0 .. 3;
+
------------------------------
-- Run-Time Exception Codes --
------------------------------
@@ -888,6 +931,7 @@ package Types is
SE_Object_Too_Large, -- 35
PE_Stream_Operation_Not_Allowed, -- 36
PE_Build_In_Place_Mismatch); -- 37
+ pragma Convention (C, RT_Exception_Code);
Last_Reason_Code : constant :=
RT_Exception_Code'Pos (RT_Exception_Code'Last);
@@ -938,4 +982,25 @@ package Types is
SE_Infinite_Recursion => SE_Reason,
SE_Object_Too_Large => SE_Reason);
+ -- Types for field offsets/sizes used in Seinfo, Sinfo.Nodes and
+ -- Einfo.Entities:
+
+ type Field_Offset is new Nat;
+ -- Offset of a node field, in units of the size of the field, which is
+ -- always a power of 2.
+
+ subtype Slot_Count is Field_Offset;
+ -- Count of number of slots. Same type as Field_Offset to avoid
+ -- proliferation of type conversions.
+
+ subtype Field_Size_In_Bits is Field_Offset with Predicate =>
+ Field_Size_In_Bits in 1 | 2 | 4 | 8 | 32;
+
+ subtype Opt_Field_Offset is Field_Offset'Base range -1 .. Field_Offset'Last;
+ No_Field_Offset : constant Opt_Field_Offset := Opt_Field_Offset'First;
+
+ type Offset_Array_Index is new Nat;
+ type Offset_Array is
+ array (Offset_Array_Index range <>) of Opt_Field_Offset;
+
end Types;
diff --git a/gcc/ada/types.h b/gcc/ada/types.h
index 76cf950..2806e50 100644
--- a/gcc/ada/types.h
+++ b/gcc/ada/types.h
@@ -6,7 +6,7 @@
* *
* C Header File *
* *
- * Copyright (C) 1992-2020, Free Software Foundation, Inc. *
+ * Copyright (C) 1992-2021, Free Software Foundation, Inc. *
* *
* GNAT is 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,7 +122,7 @@ typedef Char *Text_Buffer_Ptr;
typedef Int Line_Number_Type;
/* Column number type, used for storing all column numbers. */
-typedef Int Column_Number_Type;
+typedef Short Column_Number_Type;
/* Type used to store text of a source file. */
typedef Text_Buffer Source_Buffer;
@@ -261,6 +261,10 @@ typedef Int String_Id;
/* Type used for representation of universal integers. */
typedef Int Uint;
+typedef Int Valid_Uint;
+typedef Int Unat;
+typedef Int Upos;
+typedef Int Nonzero_Uint;
/* Used to indicate missing Uint value. */
#define No_Uint Uint_Low_Bound
@@ -360,46 +364,75 @@ typedef Int Mechanism_Type;
#define By_Short_Descriptor_NCA (-18)
#define By_Short_Descriptor_Last (-18)
-/* Definitions of Reason codes for Raise_xxx_Error nodes */
-#define CE_Access_Check_Failed 0
-#define CE_Access_Parameter_Is_Null 1
-#define CE_Discriminant_Check_Failed 2
-#define CE_Divide_By_Zero 3
-#define CE_Explicit_Raise 4
-#define CE_Index_Check_Failed 5
-#define CE_Invalid_Data 6
-#define CE_Length_Check_Failed 7
-#define CE_Null_Exception_Id 8
-#define CE_Null_Not_Allowed 9
-#define CE_Overflow_Check_Failed 10
-#define CE_Partition_Check_Failed 11
-#define CE_Range_Check_Failed 12
-#define CE_Tag_Check_Failed 13
-
-#define PE_Access_Before_Elaboration 14
-#define PE_Accessibility_Check_Failed 15
-#define PE_Address_Of_Intrinsic 16
-#define PE_Aliased_Parameters 17
-#define PE_All_Guards_Closed 18
-#define PE_Bad_Predicated_Generic_Type 19
-#define PE_Build_In_Place_Mismatch 37
-#define PE_Current_Task_In_Entry_Body 20
-#define PE_Duplicated_Entry_Address 21
-#define PE_Explicit_Raise 22
-#define PE_Finalize_Raised_Exception 23
-#define PE_Implicit_Return 24
-#define PE_Misaligned_Address_Value 25
-#define PE_Missing_Return 26
-#define PE_Non_Transportable_Actual 31
-#define PE_Overlaid_Controlled_Object 27
-#define PE_Potentially_Blocking_Operation 28
-#define PE_Stream_Operation_Not_Allowed 36
-#define PE_Stubbed_Subprogram_Called 29
-#define PE_Unchecked_Union_Restriction 30
-
-#define SE_Empty_Storage_Pool 32
-#define SE_Explicit_Raise 33
-#define SE_Infinite_Recursion 34
-#define SE_Object_Too_Large 35
-
-#define LAST_REASON_CODE 37
+typedef char Component_Alignment_Kind;
+#define Calign_Default 0
+#define Calign_Component_Size 1
+#define Calign_Component_Size_4 2
+#define Calign_Storage_Unit 3
+
+typedef char Float_Rep_Kind;
+#define IEEE_Binary 0
+#define AAMP 1
+
+typedef Nat Small_Paren_Count_Type;
+
+typedef Nat Field_Offset;
+
+typedef unsigned int any_slot;
+
+#define Slot_Size (sizeof (any_slot) * 8)
+
+/* Slots are 32 bits (for now, but we might want to make that 64).
+ The first bootstrap stage uses -std=gnu++98, so we cannot use
+ static_assert in that case. */
+#if __cplusplus >= 201402L
+static_assert (Slot_Size == 32);
+#endif
+
+/* Definitions of Reason codes for Raise_xxx_Error nodes. */
+enum RT_Exception_Code
+{
+ CE_Access_Check_Failed = 0,
+ CE_Access_Parameter_Is_Null = 1,
+ CE_Discriminant_Check_Failed = 2,
+ CE_Divide_By_Zero = 3,
+ CE_Explicit_Raise = 4,
+ CE_Index_Check_Failed = 5,
+ CE_Invalid_Data = 6,
+ CE_Length_Check_Failed = 7,
+ CE_Null_Exception_Id = 8,
+ CE_Null_Not_Allowed = 9,
+
+ CE_Overflow_Check_Failed = 10,
+ CE_Partition_Check_Failed = 11,
+ CE_Range_Check_Failed = 12,
+ CE_Tag_Check_Failed = 13,
+ PE_Access_Before_Elaboratio = 14,
+ PE_Accessibility_Check_Failed = 15,
+ PE_Address_Of_Intrinsic = 16,
+ PE_Aliased_Parameters = 17,
+ PE_All_Guards_Closed = 18,
+ PE_Bad_Predicated_Generic_Type = 19,
+
+ PE_Current_Task_In_Entry_Body = 20,
+ PE_Duplicated_Entry_Address = 21,
+ PE_Explicit_Raise = 22,
+ PE_Finalize_Raised_Exception = 23,
+ PE_Implicit_Return = 24,
+ PE_Misaligned_Address_Value = 25,
+ PE_Missing_Return = 26,
+ PE_Overlaid_Controlled_Object = 27,
+ PE_Potentially_Blocking_Operation = 28,
+ PE_Stubbed_Subprogram_Called = 29,
+
+ PE_Unchecked_Union_Restriction = 30,
+ PE_Non_Transportable_Actual = 31,
+ SE_Empty_Storage_Pool = 32,
+ SE_Explicit_Raise = 33,
+ SE_Infinite_Recursion = 34,
+ SE_Object_Too_Large = 35,
+ PE_Stream_Operation_Not_Allowed = 36,
+ PE_Build_In_Place_Mismatch = 37
+};
+
+#define LAST_REASON_CODE 37
diff --git a/gcc/ada/uintp.adb b/gcc/ada/uintp.adb
index 10adaaa..8183469 100644
--- a/gcc/ada/uintp.adb
+++ b/gcc/ada/uintp.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -2179,9 +2179,9 @@ package body Uintp is
end if;
end UI_To_CC;
- ----------------
+ ---------------
-- UI_To_Int --
- ----------------
+ ---------------
function UI_To_Int (Input : Uint) return Int is
pragma Assert (Input /= No_Uint);
@@ -2230,6 +2230,46 @@ package body Uintp is
end if;
end UI_To_Int;
+ -----------------
+ -- UI_To_Uns64 --
+ -----------------
+
+ function UI_To_Unsigned_64 (Input : Uint) return Unsigned_64 is
+ pragma Assert (Input /= No_Uint);
+
+ begin
+ if Input < Uint_0 then
+ raise Constraint_Error;
+ end if;
+
+ if Direct (Input) then
+ return Unsigned_64 (Direct_Val (Input));
+
+ -- Case of input is more than one digit
+
+ else
+ if Input >= Uint_2**Int'(64) then
+ raise Constraint_Error;
+ end if;
+
+ declare
+ In_Length : constant Int := N_Digits (Input);
+ In_Vec : UI_Vector (1 .. In_Length);
+ Ret_Int : Unsigned_64 := 0;
+
+ begin
+ Init_Operand (Input, In_Vec);
+
+ for Idx in In_Vec'Range loop
+ Ret_Int :=
+ Ret_Int * Unsigned_64 (Base) + Unsigned_64 (In_Vec (Idx));
+ end loop;
+
+ return Ret_Int;
+ end;
+ end if;
+ end UI_To_Unsigned_64;
+
--------------
-- UI_Write --
--------------
diff --git a/gcc/ada/uintp.ads b/gcc/ada/uintp.ads
index 5f1f759..b2f2315 100644
--- a/gcc/ada/uintp.ads
+++ b/gcc/ada/uintp.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -90,6 +90,11 @@ package Uintp is
Uint_Minus_127 : constant Uint;
Uint_Minus_128 : constant Uint;
+ subtype Valid_Uint is Uint with Predicate => Valid_Uint /= No_Uint;
+ subtype Unat is Valid_Uint with Predicate => Unat >= Uint_0;
+ subtype Upos is Valid_Uint with Predicate => Upos >= Uint_0;
+ subtype Nonzero_Uint is Valid_Uint with Predicate => Nonzero_Uint /= Uint_0;
+
type UI_Vector is array (Pos range <>) of Int;
-- Vector containing the integer values of a Uint value
@@ -252,6 +257,11 @@ package Uintp is
-- Converts universal integer value to Int. Constraint_Error if value is
-- not in appropriate range.
+ type Unsigned_64 is mod 2**64;
+ function UI_To_Unsigned_64 (Input : Uint) return Unsigned_64;
+ -- Converts universal integer value to Unsigned_64. Constraint_Error if
+ -- value is not in appropriate range.
+
function UI_To_CC (Input : Uint) return Char_Code;
-- Converts universal integer value to Char_Code. Constraint_Error if value
-- is not in Char_Code range.
@@ -531,10 +541,10 @@ private
-- used for converting from one to the other are defined.
type Uint_Entry is record
- Length : Pos;
+ Length : aliased Pos;
-- Length of entry in Udigits table in digits (i.e. in words)
- Loc : Int;
+ Loc : aliased Int;
-- Starting location in Udigits table of this Uint value
end record;
diff --git a/gcc/ada/uintp.h b/gcc/ada/uintp.h
index 222ff07..5ca1560 100644
--- a/gcc/ada/uintp.h
+++ b/gcc/ada/uintp.h
@@ -6,7 +6,7 @@
* *
* C Header File *
* *
- * Copyright (C) 1992-2020, Free Software Foundation, Inc. *
+ * Copyright (C) 1992-2021, Free Software Foundation, Inc. *
* *
* GNAT is 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,14 +99,13 @@ extern Boolean UI_Lt (Uint, Uint);
For efficiency, this method is used only for integer values larger than the
constant Uint_Bias. If a Uint is less than this constant, then it contains
- the integer value itself. The origin of the Uints_Ptr table is adjusted so
- that a Uint value of Uint_Bias indexes the first element. */
+ the integer value itself. */
-#define Uints_Ptr (uintp__uints__table - Uint_Table_Start)
-extern struct Uint_Entry *uintp__uints__table;
+#define Uints_Ptr uintp__uints__table
+extern struct Uint_Entry (*Uints_Ptr)[];
#define Udigits_Ptr uintp__udigits__table
-extern int *uintp__udigits__table;
+extern int (*Udigits_Ptr)[];
#ifdef __cplusplus
}
diff --git a/gcc/ada/uname.adb b/gcc/ada/uname.adb
index a9b9947..18cb6d1 100644
--- a/gcc/ada/uname.adb
+++ b/gcc/ada/uname.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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,15 +23,18 @@
-- --
------------------------------------------------------------------------------
-with Atree; use Atree;
-with Casing; use Casing;
-with Einfo; use Einfo;
+with Atree; use Atree;
+with Casing; use Casing;
+with Einfo; use Einfo;
+with Einfo.Utils; use Einfo.Utils;
with Hostparm;
-with Lib; use Lib;
-with Nlists; use Nlists;
-with Output; use Output;
-with Sinfo; use Sinfo;
-with Sinput; use Sinput;
+with Lib; use Lib;
+with Nlists; use Nlists;
+with Output; use Output;
+with Sinfo; use Sinfo;
+with Sinfo.Nodes; use Sinfo.Nodes;
+with Sinfo.Utils; use Sinfo.Utils;
+with Sinput; use Sinput;
package body Uname is
@@ -44,15 +47,18 @@ package body Uname is
-------------------
function Get_Body_Name (N : Unit_Name_Type) return Unit_Name_Type is
+ Buffer : Bounded_String;
begin
- Get_Name_String (N);
+ Append (Buffer, N);
+
+ pragma Assert
+ (Buffer.Length > 2
+ and then Buffer.Chars (Buffer.Length - 1) = '%'
+ and then Buffer.Chars (Buffer.Length) = 's');
- pragma Assert (Name_Len > 2
- and then Name_Buffer (Name_Len - 1) = '%'
- and then Name_Buffer (Name_Len) = 's');
+ Buffer.Chars (Buffer.Length) := 'b';
- Name_Buffer (Name_Len) := 'b';
- return Name_Find;
+ return Name_Find (Buffer);
end Get_Body_Name;
-----------------------------------
@@ -108,19 +114,19 @@ package body Uname is
--------------------------
function Get_Parent_Body_Name (N : Unit_Name_Type) return Unit_Name_Type is
+ Buffer : Bounded_String;
begin
- Get_Name_String (N);
+ Append (Buffer, N);
- while Name_Buffer (Name_Len) /= '.' loop
- pragma Assert (Name_Len > 1); -- not a child or subunit name
- Name_Len := Name_Len - 1;
+ while Buffer.Chars (Buffer.Length) /= '.' loop
+ pragma Assert (Buffer.Length > 1); -- not a child or subunit name
+ Buffer.Length := Buffer.Length - 1;
end loop;
- Name_Buffer (Name_Len) := '%';
- Name_Len := Name_Len + 1;
- Name_Buffer (Name_Len) := 'b';
- return Name_Find;
+ Buffer.Chars (Buffer.Length) := '%';
+ Append (Buffer, 'b');
+ return Name_Find (Buffer);
end Get_Parent_Body_Name;
--------------------------
@@ -128,22 +134,22 @@ package body Uname is
--------------------------
function Get_Parent_Spec_Name (N : Unit_Name_Type) return Unit_Name_Type is
+ Buffer : Bounded_String;
begin
- Get_Name_String (N);
+ Append (Buffer, N);
- while Name_Buffer (Name_Len) /= '.' loop
- if Name_Len = 1 then
+ while Buffer.Chars (Buffer.Length) /= '.' loop
+ if Buffer.Length = 1 then
return No_Unit_Name;
else
- Name_Len := Name_Len - 1;
+ Buffer.Length := Buffer.Length - 1;
end if;
end loop;
- Name_Buffer (Name_Len) := '%';
- Name_Len := Name_Len + 1;
- Name_Buffer (Name_Len) := 's';
- return Name_Find;
+ Buffer.Chars (Buffer.Length) := '%';
+ Append (Buffer, 's');
+ return Name_Find (Buffer);
end Get_Parent_Spec_Name;
-------------------
@@ -151,15 +157,18 @@ package body Uname is
-------------------
function Get_Spec_Name (N : Unit_Name_Type) return Unit_Name_Type is
+ Buffer : Bounded_String;
begin
- Get_Name_String (N);
+ Append (Buffer, N);
+
+ pragma Assert
+ (Buffer.Length > 2
+ and then Buffer.Chars (Buffer.Length - 1) = '%'
+ and then Buffer.Chars (Buffer.Length) = 'b');
- pragma Assert (Name_Len > 2
- and then Name_Buffer (Name_Len - 1) = '%'
- and then Name_Buffer (Name_Len) = 'b');
+ Buffer.Chars (Buffer.Length) := 's';
- Name_Buffer (Name_Len) := 's';
- return Name_Find;
+ return Name_Find (Buffer);
end Get_Spec_Name;
-------------------
@@ -168,13 +177,8 @@ package body Uname is
function Get_Unit_Name (N : Node_Id) return Unit_Name_Type is
- Unit_Name_Buffer : String (1 .. Hostparm.Max_Name_Length);
- -- Buffer used to build name of unit. Note that we cannot use the
- -- Name_Buffer in package Name_Table because we use it to read
- -- component names.
-
- Unit_Name_Length : Natural := 0;
- -- Length of name stored in Unit_Name_Buffer
+ Unit_Name_Buffer : Bounded_String;
+ -- Buffer used to build name of unit
Node : Node_Id;
-- Program unit node
@@ -197,9 +201,7 @@ package body Uname is
procedure Add_Char (C : Character) is
begin
- -- Should really check for max length exceeded here???
- Unit_Name_Length := Unit_Name_Length + 1;
- Unit_Name_Buffer (Unit_Name_Length) := C;
+ Append (Unit_Name_Buffer, C);
end Add_Char;
--------------
@@ -208,11 +210,7 @@ package body Uname is
procedure Add_Name (Name : Name_Id) is
begin
- Get_Name_String (Name);
-
- for J in 1 .. Name_Len loop
- Add_Char (Name_Buffer (J));
- end loop;
+ Append (Unit_Name_Buffer, Name);
end Add_Name;
-------------------
@@ -220,8 +218,6 @@ package body Uname is
-------------------
procedure Add_Node_Name (Node : Node_Id) is
- Kind : constant Node_Kind := Nkind (Node);
-
begin
-- Just ignore an error node (someone else will give a message)
@@ -231,7 +227,7 @@ package body Uname is
-- Otherwise see what kind of node we have
else
- case Kind is
+ case Nkind (Node) is
when N_Defining_Identifier
| N_Defining_Operator_Symbol
| N_Identifier
@@ -364,8 +360,8 @@ package body Uname is
Node := Declaration_Node (Entity (Node));
end if;
- if Nkind (Node) = N_Package_Specification
- or else Nkind (Node) in N_Subprogram_Specification
+ if Nkind (Node) in N_Package_Specification
+ | N_Subprogram_Specification
then
Node := Parent (Node);
end if;
@@ -407,11 +403,7 @@ package body Uname is
raise Program_Error;
end case;
- Name_Buffer (1 .. Unit_Name_Length) :=
- Unit_Name_Buffer (1 .. Unit_Name_Length);
- Name_Len := Unit_Name_Length;
- return Name_Find;
-
+ return Name_Find (Unit_Name_Buffer);
end Get_Unit_Name;
--------------------------
@@ -488,11 +480,12 @@ package body Uname is
------------------
function Is_Body_Name (N : Unit_Name_Type) return Boolean is
+ Buffer : Bounded_String;
begin
- Get_Name_String (N);
- return Name_Len > 2
- and then Name_Buffer (Name_Len - 1) = '%'
- and then Name_Buffer (Name_Len) = 'b';
+ Append (Buffer, N);
+ return Buffer.Length > 2
+ and then Buffer.Chars (Buffer.Length - 1) = '%'
+ and then Buffer.Chars (Buffer.Length) = 'b';
end Is_Body_Name;
-------------------
@@ -500,17 +493,16 @@ package body Uname is
-------------------
function Is_Child_Name (N : Unit_Name_Type) return Boolean is
- J : Natural;
+ Buffer : Bounded_String;
begin
- Get_Name_String (N);
- J := Name_Len;
+ Append (Buffer, N);
- while Name_Buffer (J) /= '.' loop
- if J = 1 then
+ while Buffer.Chars (Buffer.Length) /= '.' loop
+ if Buffer.Length = 1 then
return False; -- not a child or subunit name
else
- J := J - 1;
+ Buffer.Length := Buffer.Length - 1;
end if;
end loop;
@@ -588,11 +580,12 @@ package body Uname is
------------------
function Is_Spec_Name (N : Unit_Name_Type) return Boolean is
+ Buffer : Bounded_String;
begin
- Get_Name_String (N);
- return Name_Len > 2
- and then Name_Buffer (Name_Len - 1) = '%'
- and then Name_Buffer (Name_Len) = 's';
+ Append (Buffer, N);
+ return Buffer.Length > 2
+ and then Buffer.Chars (Buffer.Length - 1) = '%'
+ and then Buffer.Chars (Buffer.Length) = 's';
end Is_Spec_Name;
-----------------------
@@ -600,12 +593,11 @@ package body Uname is
-----------------------
function Name_To_Unit_Name (N : Name_Id) return Unit_Name_Type is
+ Buffer : Bounded_String;
begin
- Get_Name_String (N);
- Name_Buffer (Name_Len + 1) := '%';
- Name_Buffer (Name_Len + 2) := 's';
- Name_Len := Name_Len + 2;
- return Name_Find;
+ Append (Buffer, N);
+ Append (Buffer, "%s");
+ return Name_Find (Buffer);
end Name_To_Unit_Name;
---------------
diff --git a/gcc/ada/uname.ads b/gcc/ada/uname.ads
index a7ede02..60f46f9 100644
--- a/gcc/ada/uname.ads
+++ b/gcc/ada/uname.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute 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 88cb681..1367ad3 100644
--- a/gcc/ada/urealp.adb
+++ b/gcc/ada/urealp.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -174,16 +174,30 @@ package body Urealp is
return UI_Decimal_Digits_Hi (Val.Num) -
UI_Decimal_Digits_Lo (Val.Den);
- -- For based numbers, just subtract the decimal exponent from the
- -- high estimate of the number of digits in the numerator and add
- -- one to accommodate possible round off errors for non-decimal
- -- bases. For example:
+ -- For based numbers, get the maximum number of digits in the numerator
+ -- minus one and the either exact or floor value of the decimal exponent
+ -- of the denominator, and subtract. For example:
- -- 1_500_000 / 10**4 = 1.50E-2
+ -- 321 / 10**3 = 3.21E-1
+ -- 435 / 5**7 = 5.57E-3
- else -- Val.Rbase /= 0
- return UI_Decimal_Digits_Hi (Val.Num) -
- Equivalent_Decimal_Exponent (Val) + 1;
+ else
+ declare
+ E : Int;
+
+ begin
+ if Val.Rbase = 10 then
+ E := UI_To_Int (Val.Den);
+
+ else
+ E := Equivalent_Decimal_Exponent (Val);
+ if E < 0 then
+ E := E - 1;
+ end if;
+ end if;
+
+ return UI_Decimal_Digits_Hi (Val.Num) - 1 - E;
+ end;
end if;
end Decimal_Exponent_Hi;
@@ -213,16 +227,30 @@ package body Urealp is
return UI_Decimal_Digits_Lo (Val.Num) -
UI_Decimal_Digits_Hi (Val.Den) - 1;
- -- For based numbers, just subtract the decimal exponent from the
- -- low estimate of the number of digits in the numerator and subtract
- -- one to accommodate possible round off errors for non-decimal
- -- bases. For example:
+ -- For based numbers, get the minimum number of digits in the numerator
+ -- minus one and the either exact or ceil value of the decimal exponent
+ -- of the denominator, and subtract. For example:
- -- 1_500_000 / 10**4 = 1.50E-2
+ -- 321 / 10**3 = 3.21E-1
+ -- 435 / 5**7 = 5.57E-3
- else -- Val.Rbase /= 0
- return UI_Decimal_Digits_Lo (Val.Num) -
- Equivalent_Decimal_Exponent (Val) - 1;
+ else
+ declare
+ E : Int;
+
+ begin
+ if Val.Rbase = 10 then
+ E := UI_To_Int (Val.Den);
+
+ else
+ E := Equivalent_Decimal_Exponent (Val);
+ if E > 0 then
+ E := E + 1;
+ end if;
+ end if;
+
+ return UI_Decimal_Digits_Lo (Val.Num) - 1 - E;
+ end;
end if;
end Decimal_Exponent_Lo;
@@ -270,23 +298,21 @@ package body Urealp is
15 => (Num => 53_385_559, Den => 45_392_361), -- 1.176091259055681
16 => (Num => 78_897_839, Den => 65_523_237)); -- 1.204119982655924
- function Scale (X : Int; R : Ratio) return Int;
+ function Scale (X : Uint; R : Ratio) return Int;
-- Compute the value of X scaled by R
-----------
-- Scale --
-----------
- function Scale (X : Int; R : Ratio) return Int is
- type Wide_Int is range -2**63 .. 2**63 - 1;
-
+ function Scale (X : Uint; R : Ratio) return Int is
begin
- return Int (Wide_Int (X) * Wide_Int (R.Num) / Wide_Int (R.Den));
+ return UI_To_Int (X * R.Num / R.Den);
end Scale;
begin
pragma Assert (U.Rbase /= 0);
- return Scale (UI_To_Int (U.Den), Logs (U.Rbase));
+ return Scale (U.Den, Logs (U.Rbase));
end Equivalent_Decimal_Exponent;
----------------
@@ -376,7 +402,7 @@ package body Urealp is
Tmp : Uint;
Num : Uint;
Den : Uint;
- M : constant Uintp.Save_Mark := Uintp.Mark;
+ M : constant Uintp.Save_Mark := Mark;
begin
-- Start by setting J to the greatest of the absolute values of the
@@ -1488,6 +1514,80 @@ package body Urealp is
end if;
end UR_Write;
+ ----------------------
+ -- UR_Write_To_JSON --
+ ----------------------
+
+ -- We defer to the implementation of UR_Write in all cases, either directly
+ -- for values that are naturally written in a JSON compatible format, or by
+ -- first computing a decimal approxixmation for other values.
+
+ procedure UR_Write_To_JSON (Real : Ureal) is
+ Val : constant Ureal_Entry := Ureals.Table (Real);
+ Imrk : constant Uintp.Save_Mark := Mark;
+ Rmrk : constant Urealp.Save_Mark := Mark;
+
+ T : Ureal;
+
+ begin
+ -- Zero is zero
+
+ if Val.Num = 0 then
+ T := Real;
+
+ -- For constants with a denominator of zero, the value is simply the
+ -- numerator value, since we are dividing by base**0, which is 1.
+
+ elsif Val.Den = 0 then
+ T := Real;
+
+ -- Small powers of 2 get written in decimal fixed-point format
+
+ elsif Val.Rbase = 2
+ and then Val.Den <= 3
+ and then Val.Den >= -16
+ then
+ T := Real;
+
+ -- Constants in base 10 can be written in normal Ada literal style
+
+ elsif Val.Rbase = 10 then
+ T := Real;
+
+ -- Rationals where numerator is divisible by denominator can be output
+ -- as literals after we do the division. This includes the common case
+ -- where the denominator is 1.
+
+ elsif Val.Rbase = 0 and then Val.Num mod Val.Den = 0 then
+ T := Real;
+
+ -- For other constants, compute an approxixmation in base 10
+
+ else
+ declare
+ A : constant Ureal := UR_Abs (Real);
+ -- The absolute value
+
+ E : constant Uint :=
+ (if A < Ureal_1
+ then UI_From_Int (3 - Decimal_Exponent_Lo (Real))
+ else Uint_3);
+ -- The exponent for at least 3 digits after the decimal point
+
+ Num : constant Uint :=
+ UR_To_Uint (UR_Mul (A, UR_Exponentiate (Ureal_10, E)));
+ -- The numerator appropriately rounded
+
+ begin
+ T := UR_From_Components (Num, E, 10, Val.Negative);
+ end;
+ end if;
+
+ UR_Write (T);
+ Release (Imrk);
+ Release (Rmrk);
+ end UR_Write_To_JSON;
+
-------------
-- Ureal_0 --
-------------
diff --git a/gcc/ada/urealp.ads b/gcc/ada/urealp.ads
index 3f74735..5c625f9 100644
--- a/gcc/ada/urealp.ads
+++ b/gcc/ada/urealp.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -288,6 +288,10 @@ package Urealp is
-- In the case where an expression is output, if Brackets is set to True,
-- the expression is surrounded by square brackets.
+ procedure UR_Write_To_JSON (Real : Ureal);
+ -- Writes value of Real to standard output in the JSON data interchange
+ -- format specified by the ECMA-404 standard, for the -gnatRj output.
+
procedure pr (Real : Ureal);
pragma Export (Ada, pr);
-- Writes value of Real to standard output with a terminating line return,
diff --git a/gcc/ada/urealp.h b/gcc/ada/urealp.h
index a87e3ca..e98ad85 100644
--- a/gcc/ada/urealp.h
+++ b/gcc/ada/urealp.h
@@ -6,7 +6,7 @@
* *
* C Header File *
* *
- * Copyright (C) 1992-2020, Free Software Foundation, Inc. *
+ * Copyright (C) 1992-2021, Free Software Foundation, Inc. *
* *
* GNAT is free software; you can redistribute 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 f986484..c88ccec 100644
--- a/gcc/ada/usage.adb
+++ b/gcc/ada/usage.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -532,8 +532,10 @@ begin
"but not read");
Write_Line (" M* turn off warnings for variable assigned " &
"but not read");
- Write_Line (" .m*+ turn on warnings for suspicious modulus value");
- Write_Line (" .M turn off warnings for suspicious modulus value");
+ Write_Line (" .m*+ turn on warnings for suspicious usage " &
+ "of modular type");
+ Write_Line (" .M turn off warnings for suspicious usage " &
+ "of modular type");
Write_Line (" n* normal warning mode (cancels -gnatws/-gnatwe)");
Write_Line (" .n turn on info messages for atomic " &
"synchronization");
@@ -696,22 +698,12 @@ begin
-- Line for -gnat95 switch
Write_Switch_Char ("95");
-
- if Ada_Version_Default = Ada_95 then
- Write_Line ("Ada 95 mode (default)");
- else
- Write_Line ("Ada 95 mode");
- end if;
+ Write_Line ("Ada 95 mode");
-- Line for -gnat2005 switch
Write_Switch_Char ("2005");
-
- if Ada_Version_Default = Ada_2005 then
- Write_Line ("Ada 2005 mode (default)");
- else
- Write_Line ("Ada 2005 mode");
- end if;
+ Write_Line ("Ada 2005 mode");
end if;
-- Line for -gnat2012 switch
@@ -724,6 +716,16 @@ begin
Write_Line ("Ada 2012 mode");
end if;
+ -- Line for -gnat2022 switch
+
+ Write_Switch_Char ("2022");
+
+ if Ada_Version_Default = Ada_2022 then
+ Write_Line ("Ada 2022 mode (default)");
+ else
+ Write_Line ("Ada 2022 mode");
+ end if;
+
-- Line for -gnat-p switch
Write_Switch_Char ("-p");
diff --git a/gcc/ada/usage.ads b/gcc/ada/usage.ads
index 9d842c0..20e3bc4 100644
--- a/gcc/ada/usage.ads
+++ b/gcc/ada/usage.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute 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 2f8d769..790fe5e 100644
--- a/gcc/ada/validsw.adb
+++ b/gcc/ada/validsw.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2001-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2001-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute 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 6af95d4..cd2f957 100644
--- a/gcc/ada/validsw.ads
+++ b/gcc/ada/validsw.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2001-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2001-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/vast.adb b/gcc/ada/vast.adb
index 16519c8..62099a6 100644
--- a/gcc/ada/vast.adb
+++ b/gcc/ada/vast.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2020-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/vast.ads b/gcc/ada/vast.ads
index 5c8226a..77e9e15 100644
--- a/gcc/ada/vast.ads
+++ b/gcc/ada/vast.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2020-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/version.c b/gcc/ada/version.c
new file mode 100644
index 0000000..5e64edd
--- /dev/null
+++ b/gcc/ada/version.c
@@ -0,0 +1,34 @@
+/****************************************************************************
+ * *
+ * GNAT COMPILER COMPONENTS *
+ * *
+ * V E R S I O N *
+ * *
+ * C Implementation File *
+ * *
+ * Copyright (C) 2021, Free Software Foundation, Inc. *
+ * *
+ * GNAT is 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. *
+ * *
+ ****************************************************************************/
+
+#include "version.h"
+
+char gnat_version_string[] = version_string;
diff --git a/gcc/ada/warnsw.adb b/gcc/ada/warnsw.adb
index 0701cfc..912ceea 100644
--- a/gcc/ada/warnsw.adb
+++ b/gcc/ada/warnsw.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1999-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1999-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute 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 6c0a448..340a752 100644
--- a/gcc/ada/warnsw.ads
+++ b/gcc/ada/warnsw.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1999-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1999-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/widechar.adb b/gcc/ada/widechar.adb
index 0c31b75..183870d 100644
--- a/gcc/ada/widechar.adb
+++ b/gcc/ada/widechar.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/widechar.ads b/gcc/ada/widechar.ads
index b0b593e..4604f09 100644
--- a/gcc/ada/widechar.ads
+++ b/gcc/ada/widechar.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/xeinfo.adb b/gcc/ada/xeinfo.adb
deleted file mode 100644
index 170a5c6..0000000
--- a/gcc/ada/xeinfo.adb
+++ /dev/null
@@ -1,551 +0,0 @@
-------------------------------------------------------------------------------
--- --
--- GNAT SYSTEM UTILITIES --
--- --
--- X E I N F O --
--- --
--- 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. 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. --
--- --
-------------------------------------------------------------------------------
-
--- Program to construct C header file einfo.h (C version of einfo.ads spec)
--- for use by Gigi. This header file contains all definitions and access
--- functions, but does not contain set procedures, since Gigi is not allowed
--- to modify the GNAT tree.
-
--- Input files:
-
--- einfo.ads spec of Einfo package
--- einfo.adb body of Einfo package
-
--- Output files:
-
--- einfo.h corresponding C header file
-
--- Note: It is assumed that the input files have been compiled without errors
-
--- An optional argument allows the specification of an output file name to
--- override the default einfo.h file name for the generated output file.
-
--- Most, but not all of the functions in Einfo can be inlined in the C header.
--- They are the functions identified by pragma Inline in the spec. Functions
--- that cannot be inlined are simply defined in the header.
-
-with Ada.Command_Line; use Ada.Command_Line;
-with Ada.Strings.Unbounded; use Ada.Strings.Unbounded;
-with Ada.Strings.Unbounded.Text_IO; use Ada.Strings.Unbounded.Text_IO;
-with Ada.Strings.Maps; use Ada.Strings.Maps;
-with Ada.Strings.Maps.Constants; use Ada.Strings.Maps.Constants;
-with Ada.Text_IO; use Ada.Text_IO;
-
-with GNAT.Spitbol; use GNAT.Spitbol;
-with GNAT.Spitbol.Patterns; use GNAT.Spitbol.Patterns;
-with GNAT.Spitbol.Table_Boolean; use GNAT.Spitbol.Table_Boolean;
-
-with CEinfo;
-
-procedure XEinfo is
-
- package TB renames GNAT.Spitbol.Table_Boolean;
-
- Err : exception;
-
- A : VString := Nul;
- B : VString := Nul;
- C : VString := Nul;
- Expr : VString := Nul;
- Filler : VString := Nul;
- Fline : VString := Nul;
- Formal : VString := Nul;
- Formaltyp : VString := Nul;
- FN : VString := Nul;
- Line : VString := Nul;
- N : VString := Nul;
- N1 : VString := Nul;
- N2 : VString := Nul;
- N3 : VString := Nul;
- Nam : VString := Nul;
- Name : VString := Nul;
- NewS : VString := Nul;
- Nextlin : VString := Nul;
- OldS : VString := Nul;
- Rtn : VString := Nul;
- Term : VString := Nul;
-
- InB : File_Type;
- -- Used to read initial header from body
-
- InF : File_Type;
- -- Used to read full text of both spec and body
-
- Ofile : File_Type;
- -- Used to write output file
-
- wsp : constant Pattern := NSpan (' ' & ASCII.HT);
- Comment : constant Pattern := wsp & "--";
- For_Rep : constant Pattern := wsp & "for";
- Get_Func : constant Pattern := wsp * A & "function" & wsp
- & Break (' ') * Name;
- Inline : constant Pattern := wsp & "pragma Inline (" & Break (')') * Name;
- Get_Pack : constant Pattern := wsp & "package ";
- Get_Enam : constant Pattern := wsp & Break (',') * N & ',';
- Find_Fun : constant Pattern := wsp & "function";
- F_Subtyp : constant Pattern := wsp * A & "subtype " & Break (' ') * N;
- G_Subtyp : constant Pattern := wsp & "subtype" & wsp & Break (' ') * NewS
- & wsp & "is" & wsp & Break (" ;") * OldS
- & wsp & ';' & wsp & Rtab (0);
- F_Typ : constant Pattern := wsp * A & "type " & Break (' ') * N &
- " is (";
- Get_Nam : constant Pattern := wsp * A & Break (",)") * Nam
- & Len (1) * Term;
- Get_Styp : constant Pattern := wsp * A & "subtype " & Break (' ') * N;
- Get_N1 : constant Pattern := wsp & Break (' ') * N1;
- Get_N2 : constant Pattern := wsp & "-- " & Rest * N2;
- Get_N3 : constant Pattern := wsp & Break (';') * N3;
- Get_FN : constant Pattern := wsp * C & "function" & wsp
- & Break (" (") * FN;
- Is_Rturn : constant Pattern := BreakX ('r') & "return";
- Is_Begin : constant Pattern := wsp & "begin";
- Get_Asrt : constant Pattern := wsp & "pragma Assert";
- Semicoln : constant Pattern := BreakX (';');
- 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;
- To_Paren : constant Pattern := wsp * Filler & '(';
- Get_Fml : constant Pattern := Break (" :") * Formal & wsp & ':' & wsp
- & BreakX (" );") * Formaltyp;
- Nxt_Fml : constant Pattern := wsp & "; ";
- Get_Rtn : constant Pattern := wsp & "return" & wsp & BreakX (" ;") * Rtn;
- Rem_Prn : constant Pattern := wsp & ')';
-
- M : Match_Result;
-
- Lineno : Natural := 0;
- -- Line number in spec
-
- V : Natural;
- Ctr : Natural;
-
- Inlined : TB.Table (200);
- -- Inlined<N> = True for inlined function, False otherwise
-
- Lastinlined : Boolean;
-
- procedure Badfunc;
- pragma No_Return (Badfunc);
- -- Signal bad function in body
-
- function Getlin return VString;
- -- Get non-comment line (comment lines skipped, also skips FOR rep clauses)
- -- Fatal error (raises End_Error exception) if end of file encountered
-
- procedure Must (B : Boolean);
- -- Raises Err if the argument (a Match) call, returns False
-
- 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 --
- -------------
-
- procedure Badfunc is
- begin
- Put_Line
- (Standard_Error,
- "Body for function " & FN & " does not meet requirements");
- raise Err;
- end Badfunc;
-
- -------------
- -- Getlin --
- -------------
-
- function Getlin return VString is
- Lin : VString;
-
- begin
- loop
- Lin := Get_Line (InF);
- Lineno := Lineno + 1;
-
- if Lin /= ""
- and then not Match (Lin, Comment)
- and then not Match (Lin, For_Rep)
- then
- return Lin;
- end if;
- end loop;
- end Getlin;
-
- ----------
- -- Must --
- ----------
-
- procedure Must (B : Boolean) is
- begin
- if not B then
- raise Err;
- end if;
- end Must;
-
- -------------
- -- Sethead --
- -------------
-
- procedure Sethead (Line : in out VString; Term : String) is
- Args : VString;
-
- begin
- Must (Match (Line, Get_Func, ""));
- Args := Nul;
-
- if Match (Line, To_Paren, "") then
- Args := Filler & '(';
-
- loop
- Must (Match (Line, Get_Fml, ""));
- Append (Args, Formaltyp & ' ' & Formal);
- exit when not Match (Line, Nxt_Fml);
- Append (Args, ",");
- end loop;
-
- Match (Line, Rem_Prn, "");
- Append (Args, ')');
- end if;
-
- Must (Match (Line, Get_Rtn));
-
- if Present (Inlined, Name) then
- Put_Line (Ofile, A & "INLINE " & Rtn & ' ' & Name & Args & Term);
- else
- Put_Line (Ofile, A & Rtn & ' ' & Name & Args & Term);
- 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
- -- First run CEinfo to check for errors. Note that CEinfo is also a
- -- stand-alone program that can be run separately.
-
- CEinfo;
-
- Anchored_Mode := True;
-
- if Argument_Count > 0 then
- Create (Ofile, Out_File, Argument (1));
- else
- Create (Ofile, Out_File, "einfo.h");
- end if;
-
- Open (InB, In_File, "einfo.adb");
- Open (InF, In_File, "einfo.ads");
-
- Lineno := 0;
- loop
- Line := Get_Line (InF);
- Lineno := Lineno + 1;
- exit when Line = "";
-
- Match (Line,
- "-- S p e c ",
- "-- C Header File ");
- Match (Line, "--", "/*");
- Match (Line, Rtab (2) * A & "--", M);
- Replace (M, A & "*/");
- Put_Line (Ofile, Line);
- end loop;
-
- Put_Line (Ofile, "");
-
- Put_Line (Ofile, "#ifdef __cplusplus");
- Put_Line (Ofile, "extern ""C"" {");
- Put_Line (Ofile, "#endif");
-
- -- Find and record pragma Inlines
-
- loop
- Line := Get_Line (InF);
- exit when Match (Line, " -- END XEINFO INLINES");
-
- if Match (Line, Inline) then
- Set (Inlined, Name, True);
- end if;
- end loop;
-
- -- Skip to package line
-
- Reset (InF, In_File);
- Lineno := 0;
-
- loop
- Line := Getlin;
- exit when Match (Line, Get_Pack);
- end loop;
-
- V := 0;
- Line := Getlin;
- Must (Match (Line, wsp & "type Entity_Kind"));
-
- -- Process entity kind code definitions
-
- loop
- Line := Getlin;
- exit when not Match (Line, Get_Enam);
- Put_Line (Ofile, " #define " & Rpad (N, 32) & " " & V);
- V := V + 1;
- end loop;
-
- Must (Match (Line, wsp & Rest * N));
- Put_Line (Ofile, " #define " & Rpad (N, 32) & ' ' & V);
- Line := Getlin;
-
- Must (Match (Line, wsp & ");"));
- Put_Line (Ofile, "");
-
- -- Loop through subtype and type declarations
-
- loop
- Line := Getlin;
- exit when Match (Line, Find_Fun);
-
- -- Case of a subtype declaration
-
- if Match (Line, F_Subtyp) then
-
- -- Case of a subtype declaration that is an abbreviation of the
- -- form subtype x is y, and if so generate the appropriate typedef
-
- if Match (Line, G_Subtyp) then
- Put_Line (Ofile, A & "typedef " & OldS & ' ' & NewS & ';');
-
- -- Otherwise the subtype must be declaring a subrange of Entity_Id
-
- else
- Must (Match (Line, Get_Styp));
- Line := Getlin;
- Must (Match (Line, Get_N1));
-
- loop
- Line := Get_Line (InF);
- Lineno := Lineno + 1;
- exit when not Match (Line, Get_N2);
- end loop;
-
- Must (Match (Line, Get_N3));
- Put_Line (Ofile, A & "SUBTYPE (" & N & ", Entity_Kind, ");
- Put_Line (Ofile, A & " " & N1 & ", " & N3 & ')');
- Put_Line (Ofile, "");
- end if;
-
- -- Case of type declaration
-
- elsif Match (Line, F_Typ) then
-
- -- Process type declaration (must be enumeration type)
-
- Ctr := 0;
- Put_Line (Ofile, A & "typedef char " & N & ';');
-
- loop
- Line := Getlin;
- Must (Match (Line, Get_Nam));
- Put_Line (Ofile, A & "#define " & Rpad (Nam, 25) & Ctr);
- Ctr := Ctr + 1;
- exit when Term /= ",";
- end loop;
-
- Put_Line (Ofile, "");
-
- -- Neither subtype nor type declaration
-
- else
- raise Err;
- end if;
- end loop;
-
- -- Process function declarations
-
- -- Note: Lastinlined used to control blank lines
-
- Put_Line (Ofile, "");
- Lastinlined := True;
-
- -- Loop through function declarations
-
- while Match (Line, Get_FN) loop
-
- -- Non-inlined function
-
- if not Present (Inlined, FN) then
- Put_Line (Ofile, "");
- Put_Line
- (Ofile,
- " #define " & FN & " einfo__" & Translate (FN, Lower_Case_Map));
-
- -- Inlined function
-
- else
- if not Lastinlined then
- Put_Line (Ofile, "");
- end if;
- end if;
-
- -- Merge here to output spec
-
- Sethead (Line, ";");
- Lastinlined := Get (Inlined, FN);
- Line := Getlin;
- end loop;
-
- Put_Line (Ofile, "");
-
- -- Read body to find inlined functions
-
- Close (InB);
- Close (InF);
- Open (InF, In_File, "einfo.adb");
- Lineno := 0;
-
- -- Loop through input lines to find bodies of inlined functions
-
- while not End_Of_File (InF) loop
- Fline := Get_Line (InF);
-
- if Match (Fline, Get_FN)
- and then Get (Inlined, FN)
- then
- -- Here we have an inlined function
-
- if not Match (Fline, Is_Rturn) then
- Line := Fline;
- Badfunc;
- end if;
-
- Line := Getlin;
-
- if not Match (Line, Is_Begin) then
- Badfunc;
- end if;
-
- -- Skip past pragma Asserts
-
- loop
- Line := Getlin;
- exit when not Match (Line, Get_Asrt);
-
- -- Pragma assert found, get its continuation lines
-
- loop
- exit when Match (Line, Semicoln);
- Line := Getlin;
- end loop;
- end loop;
-
- -- Process return statement
-
- Match (Line, Get_Cmnt, M);
- Replace (M, A);
-
- -- Get continuations of return statement
-
- while not Match (Line, Semicoln) loop
- Nextlin := Getlin;
- Match (Nextlin, wsp, " ");
- Append (Line, Nextlin);
- end loop;
-
- if not Match (Line, Get_Expr) then
- Badfunc;
- end if;
-
- Line := Getlin;
-
- if not Match (Line, Chek_End) then
- Badfunc;
- end if;
-
- -- 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 & "; }");
- end if;
- end loop;
-
- Put_Line (Ofile, "");
-
- Put_Line (Ofile, "#ifdef __cplusplus");
- Put_Line (Ofile, "}");
- Put_Line (Ofile, "#endif");
-
- Put_Line
- (Ofile,
- "/* End of einfo.h (C version of Einfo package specification) */");
-
- Close (InF);
- Close (Ofile);
-
-exception
- when Err =>
- Put_Line (Standard_Error, Lineno & ". " & Line);
- Put_Line (Standard_Error, "**** fatal error ****");
- Set_Exit_Status (1);
-
- when End_Error =>
- Put_Line (Standard_Error, "unexpected end of file");
- Put_Line (Standard_Error, "**** fatal error ****");
-
-end XEinfo;
diff --git a/gcc/ada/xnmake.adb b/gcc/ada/xnmake.adb
deleted file mode 100644
index 0a18538..0000000
--- a/gcc/ada/xnmake.adb
+++ /dev/null
@@ -1,467 +0,0 @@
-------------------------------------------------------------------------------
--- --
--- GNAT SYSTEM UTILITIES --
--- --
--- X N M A K E --
--- --
--- 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. 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. --
--- --
-------------------------------------------------------------------------------
-
--- Program to construct the spec and body of the Nmake package
-
--- Input files:
-
--- sinfo.ads Spec of Sinfo package
--- nmake.adt Template for Nmake package
-
--- Output files:
-
--- nmake.ads Spec of Nmake package
--- nmake.adb Body of Nmake package
-
--- Note: this program assumes that sinfo.ads has passed the error checks that
--- are carried out by the csinfo utility, so it does not duplicate these
--- checks and assumes that sinfo.ads has the correct form.
-
--- In the absence of any switches, both the ads and adb files are output.
--- The switch -s or /s indicates that only the ads file is to be output.
--- The switch -b or /b indicates that only the adb file is to be output.
-
--- If a file name argument is given, then the output is written to this file
--- rather than to nmake.ads or nmake.adb. A file name can only be given if
--- exactly one of the -s or -b options is present.
-
-with Ada.Command_Line; use Ada.Command_Line;
-with Ada.Strings.Unbounded; use Ada.Strings.Unbounded;
-with Ada.Strings.Unbounded.Text_IO; use Ada.Strings.Unbounded.Text_IO;
-with Ada.Strings.Maps; use Ada.Strings.Maps;
-with Ada.Strings.Maps.Constants; use Ada.Strings.Maps.Constants;
-with Ada.Streams.Stream_IO; use Ada.Streams.Stream_IO;
-with Ada.Text_IO; use Ada.Text_IO;
-
-with GNAT.Spitbol; use GNAT.Spitbol;
-with GNAT.Spitbol.Patterns; use GNAT.Spitbol.Patterns;
-
-with XUtil;
-
-procedure XNmake is
-
- Err : exception;
- -- Raised to terminate execution
-
- A : VString := Nul;
- Arg : VString := Nul;
- Arg_List : VString := Nul;
- Comment : VString := Nul;
- Default : VString := Nul;
- Field : VString := Nul;
- Line : VString := Nul;
- Node : VString := Nul;
- Op_Name : VString := Nul;
- Prevl : VString := Nul;
- Synonym : VString := Nul;
- X : VString := Nul;
-
- NWidth : Natural;
-
- FileS : VString := V ("nmake.ads");
- FileB : VString := V ("nmake.adb");
- -- Set to null if corresponding file not to be generated
-
- Given_File : VString := Nul;
- -- File name given by command line argument
-
- subtype Sfile is Ada.Streams.Stream_IO.File_Type;
-
- InS, InT : Ada.Text_IO.File_Type;
- OutS, OutB : Sfile;
-
- wsp : constant Pattern := Span (' ' & ASCII.HT);
-
- Body_Only : constant Pattern := BreakX (' ') * X
- & Span (' ') & "-- body only";
- Spec_Only : constant Pattern := BreakX (' ') * X
- & Span (' ') & "-- spec only";
-
- Node_Hdr : constant Pattern := wsp & "-- N_" & Rest * Node;
- Punc : constant Pattern := BreakX (" .,");
-
- Binop : constant Pattern := wsp
- & "-- plus fields for binary operator";
- Unop : constant Pattern := wsp
- & "-- plus fields for unary operator";
- Syn : constant Pattern := wsp & "-- " & Break (' ') * Synonym
- & " (" & Break (')') * Field
- & Rest * Comment;
-
- Templ : constant Pattern := BreakX ('T') * A & "T e m p l a t e";
- Spec : constant Pattern := BreakX ('S') * A & "S p e c";
-
- Sem_Field : constant Pattern := BreakX ('-') & "-Sem";
- Lib_Field : constant Pattern := BreakX ('-') & "-Lib";
-
- Get_Field : constant Pattern := BreakX (Decimal_Digit_Set) * Field;
-
- Get_Dflt : constant Pattern := BreakX ('(') & "(set to "
- & Break (" ") * Default & " if";
-
- Next_Arg : constant Pattern := Break (',') * Arg & ',';
-
- Op_Node : constant Pattern := "Op_" & Rest * Op_Name;
-
- Shft_Rot : constant Pattern := "Shift_" or "Rotate_";
-
- No_Ent : constant Pattern := "Or_Else" or "And_Then"
- or "In" or "Not_In";
-
- M : Match_Result;
-
- V_String_Id : constant VString := V ("String_Id");
- V_Node_Id : constant VString := V ("Node_Id");
- V_Name_Id : constant VString := V ("Name_Id");
- V_List_Id : constant VString := V ("List_Id");
- V_Elist_Id : constant VString := V ("Elist_Id");
- V_Boolean : constant VString := V ("Boolean");
-
- procedure Put_Line (F : Sfile; S : String) renames XUtil.Put_Line;
- procedure Put_Line (F : Sfile; S : VString) renames XUtil.Put_Line;
- -- Local version of Put_Line ensures Unix style line endings
-
- procedure WriteS (S : String);
- procedure WriteB (S : String);
- procedure WriteBS (S : String);
- procedure WriteS (S : VString);
- procedure WriteB (S : VString);
- procedure WriteBS (S : VString);
- -- Write given line to spec or body file or both if active
-
- procedure WriteB (S : String) is
- begin
- if FileB /= Nul then
- Put_Line (OutB, S);
- end if;
- end WriteB;
-
- procedure WriteB (S : VString) is
- begin
- if FileB /= Nul then
- Put_Line (OutB, S);
- end if;
- end WriteB;
-
- procedure WriteBS (S : String) is
- begin
- if FileB /= Nul then
- Put_Line (OutB, S);
- end if;
-
- if FileS /= Nul then
- Put_Line (OutS, S);
- end if;
- end WriteBS;
-
- procedure WriteBS (S : VString) is
- begin
- if FileB /= Nul then
- Put_Line (OutB, S);
- end if;
-
- if FileS /= Nul then
- Put_Line (OutS, S);
- end if;
- end WriteBS;
-
- procedure WriteS (S : String) is
- begin
- if FileS /= Nul then
- Put_Line (OutS, S);
- end if;
- end WriteS;
-
- procedure WriteS (S : VString) is
- begin
- if FileS /= Nul then
- Put_Line (OutS, S);
- end if;
- end WriteS;
-
--- Start of processing for XNmake
-
-begin
- NWidth := 28;
- Anchored_Mode := True;
-
- for ArgN in 1 .. Argument_Count loop
- declare
- Arg : constant String := Argument (ArgN);
-
- begin
- if Arg (1) = '-' then
- if Arg'Length = 2
- and then (Arg (2) = 'b' or else Arg (2) = 'B')
- then
- FileS := Nul;
-
- elsif Arg'Length = 2
- and then (Arg (2) = 's' or else Arg (2) = 'S')
- then
- FileB := Nul;
-
- else
- raise Err;
- end if;
-
- else
- if Given_File /= Nul then
- raise Err;
- else
- Given_File := V (Arg);
- end if;
- end if;
- end;
- end loop;
-
- if FileS = Nul and then FileB = Nul then
- raise Err;
-
- elsif Given_File /= Nul then
- if FileB = Nul then
- FileS := Given_File;
-
- elsif FileS = Nul then
- FileB := Given_File;
-
- else
- raise Err;
- end if;
- end if;
-
- Open (InS, In_File, "sinfo.ads");
- Open (InT, In_File, "nmake.adt");
-
- if FileS /= Nul then
- Create (OutS, Out_File, S (FileS));
- end if;
-
- if FileB /= Nul then
- Create (OutB, Out_File, S (FileB));
- end if;
-
- Anchored_Mode := True;
-
- -- Copy initial part of template to spec and body
-
- loop
- Line := Get_Line (InT);
-
- -- Skip lines describing the template
-
- if Match (Line, "-- This file is a template") then
- loop
- Line := Get_Line (InT);
- exit when Line = "";
- end loop;
- end if;
-
- -- Loop keeps going until "package" keyword written
-
- exit when Match (Line, "package");
-
- -- Deal with WITH lines, writing to body or spec as appropriate
-
- if Match (Line, Body_Only, M) then
- Replace (M, X);
- WriteB (Line);
-
- elsif Match (Line, Spec_Only, M) then
- Replace (M, X);
- WriteS (Line);
-
- -- Change header from Template to Spec and write to spec file
-
- else
- if Match (Line, Templ, M) then
- Replace (M, A & " S p e c ");
- end if;
-
- WriteS (Line);
-
- -- Write header line to body file
-
- if Match (Line, Spec, M) then
- Replace (M, A & "B o d y");
- end if;
-
- WriteB (Line);
- end if;
- end loop;
-
- -- Package line reached
-
- WriteS ("package Nmake is");
- WriteB ("package body Nmake is");
- WriteB ("");
-
- -- Copy rest of lines up to template insert point to spec only
-
- loop
- Line := Get_Line (InT);
- exit when Match (Line, "!!TEMPLATE INSERTION POINT");
- WriteS (Line);
- end loop;
-
- -- Here we are doing the actual insertions, loop through node types
-
- loop
- Line := Get_Line (InS);
-
- if Match (Line, Node_Hdr)
- and then not Match (Node, Punc)
- and then Node /= "Unused"
- then
- exit when Node = "Empty";
- Prevl := " function Make_" & Node & " (Sloc : Source_Ptr";
- Arg_List := Nul;
-
- -- Loop through fields of one node
-
- loop
- Line := Get_Line (InS);
- exit when Line = "";
-
- if Match (Line, Binop) then
- WriteBS (Prevl & ';');
- Append (Arg_List, "Left_Opnd,Right_Opnd,");
- WriteBS (
- " " & Rpad ("Left_Opnd", NWidth) & " : Node_Id;");
- Prevl :=
- " " & Rpad ("Right_Opnd", NWidth) & " : Node_Id";
-
- elsif Match (Line, Unop) then
- WriteBS (Prevl & ';');
- Append (Arg_List, "Right_Opnd,");
- Prevl := " " & Rpad ("Right_Opnd", NWidth) & " : Node_Id";
-
- elsif Match (Line, Syn) then
- if Synonym /= "Prev_Ids"
- and then Synonym /= "More_Ids"
- and then Synonym /= "Comes_From_Source"
- and then Synonym /= "Paren_Count"
- and then not Match (Field, Sem_Field)
- and then not Match (Field, Lib_Field)
- then
- Match (Field, Get_Field);
-
- if Field = "Str" then
- Field := V_String_Id;
- elsif Field = "Node" then
- Field := V_Node_Id;
- elsif Field = "Name" then
- Field := V_Name_Id;
- elsif Field = "List" then
- Field := V_List_Id;
- elsif Field = "Elist" then
- Field := V_Elist_Id;
- elsif Field = "Flag" then
- Field := V_Boolean;
- end if;
-
- if Field = "Boolean" then
- Default := V ("False");
- else
- Default := Nul;
- end if;
-
- Match (Comment, Get_Dflt);
-
- WriteBS (Prevl & ';');
- Append (Arg_List, Synonym & ',');
- Rpad (Synonym, NWidth);
-
- if Default = "" then
- Prevl := " " & Synonym & " : " & Field;
- else
- Prevl :=
- " " & Synonym & " : " & Field & " := " & Default;
- end if;
- end if;
- end if;
- end loop;
-
- WriteBS (Prevl & ')');
- WriteS (" return Node_Id;");
- WriteS (" pragma Inline (Make_" & Node & ");");
- WriteB (" return Node_Id");
- WriteB (" is");
- WriteB (" N : constant Node_Id :=");
-
- if Match (Node, "Defining_Identifier") or else
- Match (Node, "Defining_Character") or else
- Match (Node, "Defining_Operator")
- then
- WriteB (" New_Entity (N_" & Node & ", Sloc);");
- else
- WriteB (" New_Node (N_" & Node & ", Sloc);");
- end if;
-
- WriteB (" begin");
-
- while Match (Arg_List, Next_Arg, "") loop
- if Length (Arg) < NWidth then
- WriteB (" Set_" & Arg & " (N, " & Arg & ");");
- else
- WriteB (" Set_" & Arg);
- WriteB (" (N, " & Arg & ");");
- end if;
- end loop;
-
- if Match (Node, Op_Node) then
- if Node = "Op_Plus" then
- WriteB (" Set_Chars (N, Name_Op_Add);");
-
- elsif Node = "Op_Minus" then
- WriteB (" Set_Chars (N, Name_Op_Subtract);");
-
- elsif Match (Op_Name, Shft_Rot) then
- WriteB (" Set_Chars (N, Name_" & Op_Name & ");");
-
- else
- WriteB (" Set_Chars (N, Name_" & Node & ");");
- end if;
-
- if not Match (Op_Name, No_Ent) then
- WriteB (" Set_Entity (N, Standard_" & Node & ");");
- end if;
- end if;
-
- WriteB (" return N;");
- WriteB (" end Make_" & Node & ';');
- WriteBS ("");
- end if;
- end loop;
-
- WriteBS ("end Nmake;");
-
-exception
-
- when Err =>
- Put_Line (Standard_Error, "usage: xnmake [-b] [-s] [filename]");
- Set_Exit_Status (1);
-
-end XNmake;
diff --git a/gcc/ada/xoscons.adb b/gcc/ada/xoscons.adb
index f92b627..37dd85a 100644
--- a/gcc/ada/xoscons.adb
+++ b/gcc/ada/xoscons.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2008-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 2008-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/xr_tabls.adb b/gcc/ada/xr_tabls.adb
index b2e7c02..a4c52d0 100644
--- a/gcc/ada/xr_tabls.adb
+++ b/gcc/ada/xr_tabls.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1998-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1998-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -106,10 +106,16 @@ package body Xr_Tabls is
-- when sorting the table.
Longest_File_Name_In_Table : Natural := 0;
- Unvisited_Files : Unvisited_Files_Access := null;
- Directories : Project_File_Ptr;
- Default_Match : Boolean := False;
- -- The above need commenting ???
+ -- The length of the longest file name stored
+
+ Unvisited_Files : Unvisited_Files_Access := null;
+ -- Linked list of unvisited files
+
+ Directories : Project_File_Ptr;
+ -- Store the list of directories to visit
+
+ Default_Match : Boolean := False;
+ -- Default value for match in declarations
function Parse_Gnatls_Src return String;
-- Return the standard source directories (taking into account the
@@ -482,9 +488,8 @@ package body Xr_Tabls is
-------------------
function ALI_File_Name (Ada_File_Name : String) return String is
-
- -- ??? Should ideally be based on the naming scheme defined in
- -- project files.
+ -- Should ideally be based on the naming scheme defined in
+ -- project files but this is too late for an obsolescent feature.
Index : constant Natural :=
Ada.Strings.Fixed.Index
@@ -762,7 +767,7 @@ package body Xr_Tabls is
Strip : Natural := 0) return String
is
pragma Annotate (CodePeer, Skip_Analysis);
- -- ??? To disable false positives currently generated
+ -- Disable CodePeer false positives
Tmp : GNAT.OS_Lib.String_Access;
@@ -1385,8 +1390,8 @@ package body Xr_Tabls is
begin
File_Ref.Visited := False;
- -- ??? Do not add a source file to the list. This is true at
- -- least for gnatxref, and probably for gnatfind as well
+ -- Do not add a source file to the list. This is true for gnatxref
+ -- gnatfind, so good enough.
if F'Length > 4
and then F (F'Last - 3 .. F'Last) = "." & Osint.ALI_Suffix.all
diff --git a/gcc/ada/xr_tabls.ads b/gcc/ada/xr_tabls.ads
index 3a29823..2f4dea0 100644
--- a/gcc/ada/xr_tabls.ads
+++ b/gcc/ada/xr_tabls.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1998-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1998-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is 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,7 @@
-- --
------------------------------------------------------------------------------
--- We need comment here saying what this package is???
+-- Cross reference utilities used by gnatxref and gnatfind
with GNAT.OS_Lib;
diff --git a/gcc/ada/xref_lib.adb b/gcc/ada/xref_lib.adb
index 8d29f6e..9a584a4 100644
--- a/gcc/ada/xref_lib.adb
+++ b/gcc/ada/xref_lib.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1998-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1998-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -786,7 +786,7 @@ package body Xref_Lib is
-- line and column in the dependent unit number Eun. For this we need
-- to parse the ali file again because the parent entity is not in
-- the declaration table if it did not match the search pattern.
- -- If the symbol is not found, we return "???".
+ -- If the symbol is not found, we return (1 .. 3 => '?').
procedure Skip_To_Matching_Closing_Bracket;
-- When Ptr points to an opening square bracket, moves it to the
diff --git a/gcc/ada/xref_lib.ads b/gcc/ada/xref_lib.ads
index aa78d09..3bc06d0 100644
--- a/gcc/ada/xref_lib.ads
+++ b/gcc/ada/xref_lib.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1998-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1998-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute 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
deleted file mode 100644
index a717d72..0000000
--- a/gcc/ada/xsinfo.adb
+++ /dev/null
@@ -1,262 +0,0 @@
-------------------------------------------------------------------------------
--- --
--- GNAT SYSTEM UTILITIES --
--- --
--- X S I N F O --
--- --
--- 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. 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. --
--- --
-------------------------------------------------------------------------------
-
--- Program to construct C header file sinfo.h (C version of sinfo.ads spec,
--- for use by Gigi, contains all definitions and access functions, but does
--- not contain set procedures, since Gigi never modifies the GNAT tree)
-
--- Input files:
-
--- sinfo.ads Spec of Sinfo package
-
--- Output files:
-
--- sinfo.h Corresponding c header file
-
--- An optional argument allows the specification of an output file name to
--- override the default sinfo.h file name for the generated output file.
-
-with Ada.Command_Line; use Ada.Command_Line;
-with Ada.Strings.Unbounded; use Ada.Strings.Unbounded;
-with Ada.Strings.Unbounded.Text_IO; use Ada.Strings.Unbounded.Text_IO;
-with Ada.Text_IO; use Ada.Text_IO;
-
-with GNAT.Spitbol; use GNAT.Spitbol;
-with GNAT.Spitbol.Patterns; use GNAT.Spitbol.Patterns;
-
-with CSinfo;
-
-procedure XSinfo is
-
- Done : exception;
- Err : exception;
-
- A : VString := Nul;
- Arg : VString := Nul;
- Comment : VString := Nul;
- Line : VString := Nul;
- N : VString := Nul;
- N1, N2 : VString := Nul;
- Nam : VString := Nul;
- Rtn : VString := Nul;
- Term : VString := Nul;
-
- InS : File_Type;
- Ofile : File_Type;
-
- wsp : constant Pattern := Span (' ' & ASCII.HT);
- Wsp_For : constant Pattern := wsp & "for";
- Is_Cmnt : constant Pattern := wsp & "--";
- Typ_Nod : constant Pattern := wsp * A & "type Node_Kind is";
- Get_Nam : constant Pattern := wsp * A & "N_" & Break (",)") * Nam
- & Len (1) * Term;
- Sub_Typ : constant Pattern := wsp * A & "subtype " & Break (' ') * N;
- No_Cont : constant Pattern := wsp & Break (' ') * N1
- & " .. " & Break (';') * N2;
- Cont_N1 : constant Pattern := wsp & Break (' ') * N1 & " .." & Rpos (0);
- Cont_N2 : constant Pattern := Span (' ') & Break (';') * N2;
- Is_Func : constant Pattern := wsp * A & "function " & Rest * Nam;
- Get_Arg : constant Pattern := wsp & "(N : " & Break (')') * Arg
- & ") return " & Break (';') * Rtn
- & ';' & wsp & "--" & wsp & Rest * Comment;
-
- NKV : Natural;
-
- M : Match_Result;
-
- procedure Getline;
- -- Get non-comment, non-blank line. Also skips "for " rep clauses
-
- -------------
- -- Getline --
- -------------
-
- procedure Getline is
- begin
- loop
- Line := Get_Line (InS);
-
- if Line /= ""
- and then not Match (Line, Wsp_For)
- and then not Match (Line, Is_Cmnt)
- then
- return;
-
- elsif Match (Line, " -- End functions (note") then
- raise Done;
- end if;
- end loop;
- end Getline;
-
--- Start of processing for XSinfo
-
-begin
- -- First run CSinfo to check for errors. Note that CSinfo is also a
- -- stand-alone program that can be run separately.
-
- CSinfo;
-
- Set_Exit_Status (1);
- Anchored_Mode := True;
-
- if Argument_Count > 0 then
- Create (Ofile, Out_File, Argument (1));
- else
- Create (Ofile, Out_File, "sinfo.h");
- end if;
-
- Open (InS, In_File, "sinfo.ads");
-
- -- Write header to output file
-
- loop
- Line := Get_Line (InS);
- exit when Line = "";
-
- Match
- (Line,
- "-- S p e c ",
- "-- C Header File ");
-
- Match (Line, "--", "/*");
- Match (Line, Rtab (2) * A & "--", M);
- Replace (M, A & "*/");
- Put_Line (Ofile, Line);
- end loop;
-
- -- Skip to package line
-
- loop
- Getline;
- exit when Match (Line, "package");
- end loop;
-
- -- Skip to first node kind line
-
- loop
- Getline;
- exit when Match (Line, Typ_Nod);
- Put_Line (Ofile, Line);
- end loop;
-
- Put_Line (Ofile, "");
-
- Put_Line (Ofile, "#ifdef __cplusplus");
- Put_Line (Ofile, "extern ""C"" {");
- Put_Line (Ofile, "#endif");
-
- NKV := 0;
-
- -- Loop through node kind codes
-
- loop
- Getline;
-
- if Match (Line, Get_Nam) then
- Put_Line (Ofile, A & "#define N_" & Nam & ' ' & NKV);
- NKV := NKV + 1;
- exit when not Match (Term, ",");
-
- else
- Put_Line (Ofile, Line);
- end if;
- end loop;
-
- Put_Line (Ofile, "");
- Put_Line (Ofile, A & "#define Number_Node_Kinds " & NKV);
-
- -- Loop through subtype declarations
-
- loop
- Getline;
-
- if not Match (Line, Sub_Typ) then
- exit when Match (Line, " function");
- Put_Line (Ofile, Line);
-
- else
- Put_Line (Ofile, A & "SUBTYPE (" & N & ", Node_Kind, ");
- Getline;
-
- -- Normal case
-
- if Match (Line, No_Cont) then
- Put_Line (Ofile, A & " " & N1 & ", " & N2 & ')');
-
- -- Continuation case
-
- else
- if not Match (Line, Cont_N1) then
- raise Err;
- end if;
-
- Getline;
-
- if not Match (Line, Cont_N2) then
- raise Err;
- end if;
-
- Put_Line (Ofile, A & " " & N1 & ',');
- Put_Line (Ofile, A & " " & N2 & ')');
- end if;
- end if;
- end loop;
-
- -- Loop through functions. Note that this loop is terminated by
- -- the call to Getfile encountering the end of functions sentinel
-
- loop
- if Match (Line, Is_Func) then
- Getline;
- if not Match (Line, Get_Arg) then
- raise Err;
- end if;
- Put_Line
- (Ofile,
- A & "INLINE " & Rpad (Rtn, 9)
- & ' ' & Rpad (Nam, 30) & " (" & Arg & " N)");
-
- Put_Line (Ofile, A & " { return " & Comment & " (N); }");
-
- else
- Put_Line (Ofile, Line);
- end if;
-
- Getline;
- end loop;
-
- -- Can't get here since above loop only left via raise
-
-exception
- when Done =>
- Close (InS);
- Put_Line (Ofile, "");
- Put_Line (Ofile, "#ifdef __cplusplus");
- Put_Line (Ofile, "}");
- Put_Line (Ofile, "#endif");
- Close (Ofile);
- Set_Exit_Status (0);
-
-end XSinfo;
diff --git a/gcc/ada/xsnamest.adb b/gcc/ada/xsnamest.adb
index 941e2e8..60e7b3c 100644
--- a/gcc/ada/xsnamest.adb
+++ b/gcc/ada/xsnamest.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/xtreeprs.adb b/gcc/ada/xtreeprs.adb
deleted file mode 100644
index 9469e28..0000000
--- a/gcc/ada/xtreeprs.adb
+++ /dev/null
@@ -1,357 +0,0 @@
-------------------------------------------------------------------------------
--- --
--- GNAT SYSTEM UTILITIES --
--- --
--- X T R E E P R S --
--- --
--- 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. 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. --
--- --
-------------------------------------------------------------------------------
-
--- Program to construct the spec of the Treeprs package
-
--- Input files:
-
--- sinfo.ads Spec of Sinfo package
--- treeprs.adt Template for Treeprs package
-
--- Output files:
-
--- treeprs.ads Spec of Treeprs package
-
--- Note: this program assumes that sinfo.ads has passed the error checks which
--- are carried out by the CSinfo utility so it does not duplicate these checks
-
--- An optional argument allows the specification of an output file name to
--- override the default treeprs.ads file name for the generated output file.
-
-with Ada.Command_Line; use Ada.Command_Line;
-with Ada.Strings.Unbounded; use Ada.Strings.Unbounded;
-with Ada.Strings.Unbounded.Text_IO; use Ada.Strings.Unbounded.Text_IO;
-with Ada.Text_IO; use Ada.Text_IO;
-with Ada.Streams.Stream_IO; use Ada.Streams.Stream_IO;
-
-with GNAT.Spitbol; use GNAT.Spitbol;
-with GNAT.Spitbol.Patterns; use GNAT.Spitbol.Patterns;
-with GNAT.Spitbol.Table_Boolean; use GNAT.Spitbol.Table_Boolean;
-with GNAT.Spitbol.Table_VString; use GNAT.Spitbol.Table_VString;
-
-procedure XTreeprs is
-
- package TB renames GNAT.Spitbol.Table_Boolean;
- package TV renames GNAT.Spitbol.Table_VString;
-
- Err : exception;
- -- Raised on fatal error
-
- A : VString := Nul;
- Ffield : VString := Nul;
- Field : VString := Nul;
- Fieldno : VString := Nul;
- Flagno : VString := Nul;
- Line : VString := Nul;
- Name : VString := Nul;
- Node : VString := Nul;
- Outstring : VString := Nul;
- Prefix : VString := Nul;
- S : VString := Nul;
- S1 : VString := Nul;
- Syn : VString := Nul;
- Synonym : VString := Nul;
- Term : VString := Nul;
-
- subtype Sfile is Ada.Streams.Stream_IO.File_Type;
-
- OutS : Sfile;
- -- Output file
-
- InS : Ada.Text_IO.File_Type;
- -- Read sinfo.ads
-
- InT : Ada.Text_IO.File_Type;
- -- Read treeprs.adt
-
- Special : TB.Table (20);
- -- Table of special fields. These fields are not included in the table
- -- constructed by Xtreeprs, since they are specially handled in treeprs.
- -- This means these field definitions are completely ignored.
-
- Names : array (1 .. 500) of VString;
- -- Table of names of synonyms
-
- Positions : array (1 .. 500) of Natural;
- -- Table of starting positions in Pchars string for synonyms
-
- Strings : TV.Table (300);
- -- Contribution of each synonym to Pchars string, indexed by name
-
- Count : Natural := 0;
- -- Number of synonyms processed so far
-
- Curpos : Natural := 1;
- -- Number of characters generated in Pchars string so far
-
- Lineno : Natural := 0;
- -- Line number in sinfo.ads
-
- Field_Base : constant := Character'Pos ('#');
- -- Fields 1-5 are represented by the characters #$%&' (i.e. by five
- -- contiguous characters starting at # (16#23#)).
-
- Flag_Base : constant := Character'Pos ('(');
- -- Flags 1-18 are represented by the characters ()*+,-./0123456789
- -- (i.e. by 18 contiguous characters starting at (16#28#)).
-
- Fieldch : Character;
- -- Field character, as per above tables
-
- Sp : aliased Natural;
- -- Space left on line for Pchars output
-
- wsp : constant Pattern := Span (' ' & ASCII.HT);
- Is_Temp : constant Pattern := BreakX ('T') * A & "T e m p l a t e";
- Get_Node : constant Pattern := wsp & "-- N_" & Rest * Node;
- Tst_Punc : constant Pattern := Break (" ,.");
- Get_Syn : constant Pattern := Span (' ') & "-- " & Break (' ') * Synonym
- & " (" & Break (')') * Field;
- Brk_Min : constant Pattern := Break ('-') * Ffield;
- Is_Flag : constant Pattern := "Flag" & Rest * Flagno;
- Is_Field : constant Pattern := Rtab (1) & Len (1) * Fieldno;
- Is_Syn : constant Pattern := wsp & "N_" & Break (",)") * Syn
- & Len (1) * Term;
- Brk_Node : constant Pattern := Break (' ') * Node & ' ';
- Chop_SP : constant Pattern := Len (Sp'Unrestricted_Access) * S1;
-
- M : Match_Result;
-
- procedure Put_Line (F : Sfile; S : String);
- procedure Put_Line (F : Sfile; S : VString);
- -- Local version of Put_Line ensures Unix style line endings
-
- procedure Put_Line (F : Sfile; S : String) is
- begin
- String'Write (Stream (F), S);
- Character'Write (Stream (F), ASCII.LF);
- end Put_Line;
-
- procedure Put_Line (F : Sfile; S : VString) is
- begin
- Put_Line (F, To_String (S));
- end Put_Line;
-
--- Start of processing for XTreeprs
-
-begin
- Anchored_Mode := True;
-
- if Argument_Count > 0 then
- Create (OutS, Out_File, Argument (1));
- else
- Create (OutS, Out_File, "treeprs.ads");
- end if;
-
- Open (InS, In_File, "sinfo.ads");
- Open (InT, In_File, "treeprs.adt");
-
- -- Initialize special fields table
-
- Set (Special, "Analyzed", True);
- Set (Special, "Cannot_Be_Constant", True);
- Set (Special, "Chars", True);
- Set (Special, "Comes_From_Source", True);
- Set (Special, "Error_Posted", True);
- Set (Special, "Etype", True);
- Set (Special, "Has_No_Side_Effects", True);
- Set (Special, "Is_Controlling_Actual", True);
- Set (Special, "Is_Overloaded", True);
- Set (Special, "Is_Static_Expression", True);
- Set (Special, "Left_Opnd", True);
- Set (Special, "Must_Check_Expr", True);
- Set (Special, "No_Overflow_Expr", True);
- Set (Special, "Paren_Count", True);
- Set (Special, "Raises_Constraint_Error", True);
- Set (Special, "Right_Opnd", True);
-
- -- Read template header and generate new header
-
- loop
- Line := Get_Line (InT);
-
- -- Skip lines describing the template
-
- if Match (Line, "-- This file is a template") then
- loop
- Line := Get_Line (InT);
- exit when Line = "";
- end loop;
- end if;
-
- exit when Match (Line, "package");
-
- if Match (Line, Is_Temp, M) then
- Replace (M, A & " S p e c ");
- end if;
-
- Put_Line (OutS, Line);
- end loop;
-
- Put_Line (OutS, Line);
-
- -- Copy rest of comments up to template insert point to spec
-
- loop
- Line := Get_Line (InT);
- exit when Match (Line, "!!TEMPLATE INSERTION POINT");
- Put_Line (OutS, Line);
- end loop;
-
- -- Here we are doing the actual insertions
-
- Put_Line (OutS, " Pchars : constant String :=");
-
- -- Loop through comments describing nodes, picking up fields
-
- loop
- Line := Get_Line (InS);
- Lineno := Lineno + 1;
- exit when Match (Line, " type Node_Kind");
-
- if Match (Line, Get_Node)
- and then not Match (Node, Tst_Punc)
- then
- Outstring := Node & ' ';
-
- loop
- Line := Get_Line (InS);
- exit when Line = "";
-
- if Match (Line, Get_Syn)
- and then not Match (Synonym, "plus")
- and then not Present (Special, Synonym)
- then
- -- Convert this field into the character used to
- -- represent the field according to the table:
-
- -- Field1 '#'
- -- Field2 '$'
- -- Field3 '%'
- -- Field4 '&'
- -- Field5 "'"
- -- Flag4 '+'
- -- Flag5 ','
- -- Flag6 '-'
- -- Flag7 '.'
- -- Flag8 '/'
- -- Flag9 '0'
- -- Flag10 '1'
- -- Flag11 '2'
- -- Flag12 '3'
- -- Flag13 '4'
- -- Flag14 '5'
- -- Flag15 '6'
- -- Flag16 '7'
- -- Flag17 '8'
- -- Flag18 '9'
-
- if Match (Field, Brk_Min) then
- Field := Ffield;
- end if;
-
- if Match (Field, Is_Flag) then
- Fieldch := Char (Flag_Base - 1 + N (Flagno));
-
- elsif Match (Field, Is_Field) then
- Fieldch := Char (Field_Base - 1 + N (Fieldno));
-
- else
- Put_Line
- (Standard_Error,
- "*** Line " &
- Lineno &
- " has unrecognized field name " &
- Field);
- raise Err;
- end if;
-
- Append (Outstring, Fieldch & Synonym);
- end if;
- end loop;
-
- Set (Strings, Node, Outstring);
- end if;
- end loop;
-
- -- Loop through actual definitions of node kind enumeration literals
-
- loop
- loop
- Line := Get_Line (InS);
- Lineno := Lineno + 1;
- exit when Match (Line, Is_Syn);
- end loop;
-
- S := Get (Strings, Syn);
- Match (S, Brk_Node, "");
- Count := Count + 1;
- Names (Count) := Syn;
- Positions (Count) := Curpos;
- Curpos := Curpos + Length (S);
- Put_Line (OutS, " -- " & Node);
- Prefix := V (" ");
- exit when Term = ")";
-
- -- Loop to output the string literal for Pchars
-
- loop
- Sp := 79 - 4 - Length (Prefix);
- exit when Size (S) <= Sp;
- Match (S, Chop_SP, "");
- Put_Line (OutS, Prefix & '"' & S1 & """ &");
- Prefix := V (" ");
- end loop;
-
- Put_Line (OutS, Prefix & '"' & S & """ &");
- end loop;
-
- Put_Line (OutS, " """";");
- Put_Line (OutS, "");
- Put_Line
- (OutS, " type Pchar_Pos_Array is array (Node_Kind) of Positive;");
- Put_Line
- (OutS,
- " Pchar_Pos : constant Pchar_Pos_Array := Pchar_Pos_Array'(");
-
- -- Output lines for Pchar_Pos_Array values
-
- for M in 1 .. Count - 1 loop
- Name := Rpad ("N_" & Names (M), 40);
- Put_Line (OutS, " " & Name & " => " & Positions (M) & ',');
- end loop;
-
- Name := Rpad ("N_" & Names (Count), 40);
- Put_Line (OutS, " " & Name & " => " & Positions (Count) & ");");
-
- Put_Line (OutS, "");
- Put_Line (OutS, "end Treeprs;");
-
-exception
- when Err =>
- Put_Line (Standard_Error, "*** fatal error");
- Set_Exit_Status (1);
-
-end XTreeprs;
diff --git a/gcc/ada/xutil.adb b/gcc/ada/xutil.adb
index 8f85668..ddc7f40 100644
--- a/gcc/ada/xutil.adb
+++ b/gcc/ada/xutil.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute 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 8172595..746f743 100644
--- a/gcc/ada/xutil.ads
+++ b/gcc/ada/xutil.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --